Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

Register Log in
  • Congratulations Westi on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!

Running a Sub from a Button

Status
Not open for further replies.
travismallen

travismallen

Programmer
Aug 5, 2003
15
US
Hi all,

I am creating a form that needs a 2 buttons:1 that runs 2 diferent Subs; each sub sends emails from query results, and 1 that runs 1 sub that also sends emails. (Note: I "inherited" this code and vaguely understand it as I'm not a VBA programmer, but I'm learning!). I think I have to create an event to call them or make a funtion that does, but I don't know how (mainly syntax issues).

Below is the code from the 3 modules holding the Subs. The first 2 need to be run by 1 button, that last from another button.

The first Module, "NewHireEmail"
Code: 
 Option Compare Database

Option Explicit
Private Const SW_HIDE = 0
Private Const SW_SHOWNORMAL = 1
Private Const SW_NORMAL = 1
Private Const SW_SHOWMINIMIZED = 2
Private Const SW_SHOWMAXIMIZED = 3
Private Const SW_MAXIMIZE = 3
Private Const SW_SHOWNOACTIVATE = 4
Private Const SW_SHOW = 5
Private Const SW_MINIMIZE = 6
Private Const SW_SHOWMINNOACTIVE = 7
Private Const SW_SHOWNA = 8
Private Const SW_RESTORE = 9
Private Const SW_SHOWDEFAULT = 10
Private Const SW_MAX = 10
Private Declare Function apiFindWindow Lib "user32" Alias _
    "FindWindowA" (ByVal strClass As String, _
    ByVal lpWindow As String) As Long

Private Declare Function apiSendMessage Lib "user32" Alias _
    "SendMessageA" (ByVal hwnd As Long, ByVal msg As Long, ByVal _
    wParam As Long, lParam As Long) As Long
    
Private Declare Function apiSetForegroundWindow Lib "user32" Alias _
    "SetForegroundWindow" (ByVal hwnd As Long) As Long
    
Private Declare Function apiShowWindow Lib "user32" Alias _
    "ShowWindow" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
    
Private Declare Function apiIsIconic Lib "user32" Alias _
    "IsIconic" (ByVal hwnd As Long) As Long
Dim appOL As Outlook.Application
Dim olNameSpace As Outlook.NameSpace
Dim olMSG As Outlook.MailItem
Dim olRecipient As Outlook.Recipient
Dim dbname As DAO.Database
Dim AppOpen As Boolean

Sub OutlookPump()
Dim daoRS As DAO.Recordset
Dim icnt As Integer
On Error GoTo Error_Handler
Set dbname = CurrentDb()
'Create RecordSet
Set daoRS = dbname.OpenRecordset("Notification Step 1: 90 or less Email list")
'activate Outlook
AppOpen = fIsAppRunning("Outlook2000")
If AppOpen Then
    Set appOL = GetObject(, "Outlook.Application")
Else
    Set appOL = CreateObject("Outlook.Application")
End If
Set olNameSpace = appOL.GetNamespace("MAPI")
'Create and send message for each record in RecordSet
With daoRS
        Do While Not .EOF
'       Create the message item here.
        Set olMSG = appOL.CreateItemFromTemplate("G:\TI_InfoSec\IS Program Office\IS New Hire Orientation (Strategic)\NewHireMSG.oft")
'       Add email addr to recipient list if not NULL.
        If Not ![Email Address] = " " Then
            olMSG.Recipients.Add ![Email Address]
'           Add email addr to recipient list if not N/A.
            olMSG.Recipients.Add "cti.is.awareness@iuo.ssmb.com"
'           Set  SentOnBehalfOfName value and subject.
            olMSG.SentOnBehalfOfName = "cti.is.awareness@imcnam.ssmb.com"
            
            olMSG.Send
        End If
'       move to the next record.
        .MoveNext
        DoEvents
    
    Loop
End With
Exit_Handler:
    If Not AppOpen Then
        appOL.Quit
    End If
    Set olMSG = Nothing
    Set olNameSpace = Nothing
    Set appOL = Nothing
    Exit Sub
Error_Handler:
    Select Case Err.Number
        Case Else
            MsgBox Err.Number & " - " & Err.Description
    End Select
    GoTo Exit_Handler
    MsgBox Err.Number & " - " & Err.Description
    GoTo Exit_Handler
End Sub

Function fIsAppRunning(ByVal strAppName As String, _
        Optional fActivate As Boolean) As Boolean
Dim lngH As Long, strClassName As String
Dim lngX As Long, lngTmp As Long
Const WM_USER = 1024
On Local Error GoTo fIsAppRunning_Err
fIsAppRunning = False
Select Case LCase$(strAppName)
    Case "excel":       strClassName = "XLMain"
    Case "word":        strClassName = "OpusApp"
    Case "access":      strClassName = "OMain"
    Case "powerpoint95": strClassName = "PP7FrameClass"
    Case "powerpoint97": strClassName = "PP97FrameClass"
    Case "notepad":     strClassName = "NOTEPAD"
    Case "paintbrush":  strClassName = "pbParent"
    Case "wordpad":     strClassName = "WordPadClass"
'   Additional Classes added
    Case "Outlook2000":     strClassName = "rctrl_renwnd32"
    Case "Calculator":  strClassName = "SciCalc"
    Case "Internet Explorer": strClassName = "IEFrame"
    Case "Frontpage2000": strClassName = "FrontPageExplorerWindow40"
    Case "CorelDraw7.0": strClassName = "CorelDRAW 7.0"
    Case Else:          strClassName = vbNullString
End Select

If strClassName = "" Then
    lngH = apiFindWindow(vbNullString, strAppName)
Else
    lngH = apiFindWindow(strClassName, vbNullString)
End If
If lngH <> 0 Then
    apiSendMessage lngH, WM_USER + 18, 0, 0
    lngX = apiIsIconic(lngH)
    If lngX <> 0 Then
        lngTmp = apiShowWindow(lngH, SW_SHOWNORMAL)
    End If
    If fActivate Then
        lngTmp = apiSetForegroundWindow(lngH)
    End If
    fIsAppRunning = True
End If
fIsAppRunning_Exit:
    Exit Function
fIsAppRunning_Err:
    fIsAppRunning = False
    Resume fIsAppRunning_Exit
End Function
The Second module, "NewHirePastDue_Round1"
Code: 
Option Compare Database

Option Explicit
Private Const SW_HIDE = 0
Private Const SW_SHOWNORMAL = 1
Private Const SW_NORMAL = 1
Private Const SW_SHOWMINIMIZED = 2
Private Const SW_SHOWMAXIMIZED = 3
Private Const SW_MAXIMIZE = 3
Private Const SW_SHOWNOACTIVATE = 4
Private Const SW_SHOW = 5
Private Const SW_MINIMIZE = 6
Private Const SW_SHOWMINNOACTIVE = 7
Private Const SW_SHOWNA = 8
Private Const SW_RESTORE = 9
Private Const SW_SHOWDEFAULT = 10
Private Const SW_MAX = 10
Private Declare Function apiFindWindow Lib "user32" Alias _
    "FindWindowA" (ByVal strClass As String, _
    ByVal lpWindow As String) As Long

Private Declare Function apiSendMessage Lib "user32" Alias _
    "SendMessageA" (ByVal hwnd As Long, ByVal msg As Long, ByVal _
    wParam As Long, lParam As Long) As Long
    
Private Declare Function apiSetForegroundWindow Lib "user32" Alias _
    "SetForegroundWindow" (ByVal hwnd As Long) As Long
    
Private Declare Function apiShowWindow Lib "user32" Alias _
    "ShowWindow" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
    
Private Declare Function apiIsIconic Lib "user32" Alias _
    "IsIconic" (ByVal hwnd As Long) As Long
Dim appOL As Outlook.Application
Dim olNameSpace As Outlook.NameSpace
Dim olMSG As Outlook.MailItem
Dim olRecipient As Outlook.Recipient
Dim dbname As DAO.Database
Dim AppOpen As Boolean
Sub OutlookPump()
Dim daoRS As DAO.Recordset
Dim icnt As Integer
On Error GoTo Error_Handler
Set dbname = CurrentDb()
'Create RecordSet
Set daoRS = dbname.OpenRecordset("Notification Step 3: Identify 2nd and 3rd")
'activate Outlook
AppOpen = fIsAppRunning("Outlook2000")
If AppOpen Then
    Set appOL = GetObject(, "Outlook.Application")
Else
    Set appOL = CreateObject("Outlook.Application")
End If
Set olNameSpace = appOL.GetNamespace("MAPI")
'Create and send message for each record in RecordSet
With daoRS
        Do While Not .EOF
'       Create the message item here.
        Set olMSG = appOL.CreateItemFromTemplate("G:\TI_InfoSec\IS Program Office\IS New Hire Orientation (Strategic)\NewHireRound1MSG.oft")
        olMSG.Body = ![First Name] & " " & ![Last Name] & ", " & vbCrLf & vbCrLf & olMSG.Body
'       Add email addr to recipient list if not NULL.
        If Not ![Email Address] = " " Then
            olMSG.Recipients.Add ![Email Address]
            olMSG.Recipients.Add ![Supervisor Email]
            olMSG.Recipients.Add "cti.is.awareness@iuo.ssmb.com"
'           Set  SentOnBehalfOfName value and subject.
            olMSG.SentOnBehalfOfName = "cti.is.awareness@imcnam.ssmb.com"
        
        olMSG.Send

        End If
'       move to the next record.
        .MoveNext
        DoEvents
        
    Loop
End With
Exit_Handler:
    If Not AppOpen Then
        appOL.Quit
    End If
    Set olMSG = Nothing
    Set olNameSpace = Nothing
    Set appOL = Nothing
    Exit Sub
Error_Handler:
    Select Case Err.Number
        Case Else
            MsgBox Err.Number & " - " & Err.Description
    End Select
    GoTo Exit_Handler
    MsgBox Err.Number & " - " & Err.Description
    GoTo Exit_Handler
End Sub

Function fIsAppRunning(ByVal strAppName As String, _
        Optional fActivate As Boolean) As Boolean
Dim lngH As Long, strClassName As String
Dim lngX As Long, lngTmp As Long
Const WM_USER = 1024
On Local Error GoTo fIsAppRunning_Err
fIsAppRunning = False
Select Case LCase$(strAppName)
    Case "excel":       strClassName = "XLMain"
    Case "word":        strClassName = "OpusApp"
    Case "access":      strClassName = "OMain"
    Case "powerpoint95": strClassName = "PP7FrameClass"
    Case "powerpoint97": strClassName = "PP97FrameClass"
    Case "notepad":     strClassName = "NOTEPAD"
    Case "paintbrush":  strClassName = "pbParent"
    Case "wordpad":     strClassName = "WordPadClass"
'   Additional Classes added
    Case "Outlook2000":     strClassName = "rctrl_renwnd32"
    Case "Calculator":  strClassName = "SciCalc"
    Case "Internet Explorer": strClassName = "IEFrame"
    Case "Frontpage2000": strClassName = "FrontPageExplorerWindow40"
    Case "CorelDraw7.0": strClassName = "CorelDRAW 7.0"
    Case Else:          strClassName = vbNullString
End Select

If strClassName = "" Then
    lngH = apiFindWindow(vbNullString, strAppName)
Else
    lngH = apiFindWindow(strClassName, vbNullString)
End If
If lngH <> 0 Then
    apiSendMessage lngH, WM_USER + 18, 0, 0
    lngX = apiIsIconic(lngH)
    If lngX <> 0 Then
        lngTmp = apiShowWindow(lngH, SW_SHOWNORMAL)
    End If
    If fActivate Then
        lngTmp = apiSetForegroundWindow(lngH)
    End If
    fIsAppRunning = True
End If
fIsAppRunning_Exit:
    Exit Function
fIsAppRunning_Err:
    fIsAppRunning = False
    Resume fIsAppRunning_Exit
End Function
The third module,"NewHirePastDue_Round2"

Code: 
ption Compare Database

Option Explicit
Private Const SW_HIDE = 0
Private Const SW_SHOWNORMAL = 1
Private Const SW_NORMAL = 1
Private Const SW_SHOWMINIMIZED = 2
Private Const SW_SHOWMAXIMIZED = 3
Private Const SW_MAXIMIZE = 3
Private Const SW_SHOWNOACTIVATE = 4
Private Const SW_SHOW = 5
Private Const SW_MINIMIZE = 6
Private Const SW_SHOWMINNOACTIVE = 7
Private Const SW_SHOWNA = 8
Private Const SW_RESTORE = 9
Private Const SW_SHOWDEFAULT = 10
Private Const SW_MAX = 10
Private Declare Function apiFindWindow Lib "user32" Alias _
    "FindWindowA" (ByVal strClass As String, _
    ByVal lpWindow As String) As Long

Private Declare Function apiSendMessage Lib "user32" Alias _
    "SendMessageA" (ByVal hwnd As Long, ByVal msg As Long, ByVal _
    wParam As Long, lParam As Long) As Long
    
Private Declare Function apiSetForegroundWindow Lib "user32" Alias _
    "SetForegroundWindow" (ByVal hwnd As Long) As Long
    
Private Declare Function apiShowWindow Lib "user32" Alias _
    "ShowWindow" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
    
Private Declare Function apiIsIconic Lib "user32" Alias _
    "IsIconic" (ByVal hwnd As Long) As Long
Dim appOL As Outlook.Application
Dim olNameSpace As Outlook.NameSpace
Dim olMSG As Outlook.MailItem
Dim olRecipient As Outlook.Recipient
Dim dbname As DAO.Database
Dim AppOpen As Boolean
Sub OutlookPump()
Dim daoRS As DAO.Recordset
Dim icnt As Integer
On Error GoTo Error_Handler
Set dbname = CurrentDb()
'Create RecordSet
Set daoRS = dbname.OpenRecordset("Notification Step 5: Greater than 90 Email List")
'activate Outlook
AppOpen = fIsAppRunning("Outlook2000")
If AppOpen Then
    Set appOL = GetObject(, "Outlook.Application")
Else
    Set appOL = CreateObject("Outlook.Application")
End If
Set olNameSpace = appOL.GetNamespace("MAPI")
'Create and send message for each record in RecordSet
With daoRS
        Do While Not .EOF
'       Create the message item here.
        Set olMSG = appOL.CreateItemFromTemplate("G:\TI_InfoSec\IS Program Office\IS New Hire Orientation (Strategic)\NewHireRound2MSG.oft")
        olMSG.Body = ![First Name] & " " & ![Last Name] & ", " & vbCrLf & vbCrLf & olMSG.Body
'       Add email addr to recipient list if not NULL.
        If Not ![Email Address] = " " Then
            olMSG.Recipients.Add ![Email Address]
            olMSG.Recipients.Add ![Supervisor Email]
            olMSG.Recipients.Add "cti.is.awareness@iuo.ssmb.com"
'           Set  SentOnBehalfOfName value and subject.
            olMSG.SentOnBehalfOfName = "cti.is.awareness@imcnam.ssmb.com"
        
        olMSG.Send

        End If
'       move to the next record.
        .MoveNext
        DoEvents
        
    Loop
End With
Exit_Handler:
    If Not AppOpen Then
        appOL.Quit
    End If
    Set olMSG = Nothing
    Set olNameSpace = Nothing
    Set appOL = Nothing
    Exit Sub
Error_Handler:
    Select Case Err.Number
        Case Else
            MsgBox Err.Number & " - " & Err.Description
    End Select
    GoTo Exit_Handler
    MsgBox Err.Number & " - " & Err.Description
    GoTo Exit_Handler
End Sub

Function fIsAppRunning(ByVal strAppName As String, _
        Optional fActivate As Boolean) As Boolean
Dim lngH As Long, strClassName As String
Dim lngX As Long, lngTmp As Long
Const WM_USER = 1024
On Local Error GoTo fIsAppRunning_Err
fIsAppRunning = False
Select Case LCase$(strAppName)
    Case "excel":       strClassName = "XLMain"
    Case "word":        strClassName = "OpusApp"
    Case "access":      strClassName = "OMain"
    Case "powerpoint95": strClassName = "PP7FrameClass"
    Case "powerpoint97": strClassName = "PP97FrameClass"
    Case "notepad":     strClassName = "NOTEPAD"
    Case "paintbrush":  strClassName = "pbParent"
    Case "wordpad":     strClassName = "WordPadClass"
'   Additional Classes added
    Case "Outlook2000":     strClassName = "rctrl_renwnd32"
    Case "Calculator":  strClassName = "SciCalc"
    Case "Internet Explorer": strClassName = "IEFrame"
    Case "Frontpage2000": strClassName = "FrontPageExplorerWindow40"
    Case "CorelDraw7.0": strClassName = "CorelDRAW 7.0"
    Case Else:          strClassName = vbNullString
End Select

If strClassName = "" Then
    lngH = apiFindWindow(vbNullString, strAppName)
Else
    lngH = apiFindWindow(strClassName, vbNullString)
End If
If lngH <> 0 Then
    apiSendMessage lngH, WM_USER + 18, 0, 0
    lngX = apiIsIconic(lngH)
    If lngX <> 0 Then
        lngTmp = apiShowWindow(lngH, SW_SHOWNORMAL)
    End If
    If fActivate Then
        lngTmp = apiSetForegroundWindow(lngH)
    End If
    fIsAppRunning = True
End If
fIsAppRunning_Exit:
    Exit Function
fIsAppRunning_Err:
    fIsAppRunning = False
    Resume fIsAppRunning_Exit
End Function

just incase you need it, the Query names are:

"Notification Step 1: 90 or less Email list"
"Notification Step 3: Identify 2nd and 3rd"
"Notification Step 5: Greater than 90 Email List"

Thanks in advanced for your help!

T

___________________________
&quot;I am what I am&quot; - Popeye
Travis M. Allen
 
Status
Not open for further replies.

Similar threads

Zyborg
  • Locked
  • Question
Using a variable as reference to a form
Replies
5
Views
449
Zyborg
Zyborg
BFroeschlKC
  • Locked
  • Question
Publisher Automation from Access Frustration
Replies
3
Views
2K
dhookom
dhookom
Moss100
  • Locked
  • Question
Remove everything including the comma from the last comma of a string. 1
Replies
10
Views
720
Andrzejek
Andrzejek
V
  • Locked
  • Helpful tip
Capture Shift Key if Pressed on A form
Replies
3
Views
436
strongm
strongm
M
  • Locked
  • Question
display a calendar with appointments in body of html email with access vba
Replies
1
Views
3K
SoftwareRT
SoftwareRT

Part and Inventory Search

Sponsor

Back
Top