I am not sure how to present this problem but here goes:
Below I have inserted three sections of code.
The first one is my accSendObject Module.
The seconde one is the Click/Yes Code.
The third one is code used when a checkbox is clicked that invokes a email.
I currently have a form in Access that when a Checkbox is clicked it sends an email. Below is the code that I am using. It is a module called accSendObject. My dilemma is because we are using Access2003 when Outlook is called it requires us to click yes about three times delaying the email while we are waiting. There is a click/yes program that alleviates that problem but my MIS department does not want us to use that program they want this functionality included in the code itself. I have also put a sample of the click/yes code below. My question is how to insert the click/yes code or where to insert the code to make it work?
Below the click/yes code is code that works off of a checkbox that is checked to invoke the email. I probably have confused everyone but please help if you can.
accSendObject Module Code
Click/Yes Code
Code invoked when checkbox is clicked
Below I have inserted three sections of code.
The first one is my accSendObject Module.
The seconde one is the Click/Yes Code.
The third one is code used when a checkbox is clicked that invokes a email.
I currently have a form in Access that when a Checkbox is clicked it sends an email. Below is the code that I am using. It is a module called accSendObject. My dilemma is because we are using Access2003 when Outlook is called it requires us to click yes about three times delaying the email while we are waiting. There is a click/yes program that alleviates that problem but my MIS department does not want us to use that program they want this functionality included in the code itself. I have also put a sample of the click/yes code below. My question is how to insert the click/yes code or where to insert the code to make it work?
Below the click/yes code is code that works off of a checkbox that is checked to invoke the email. I probably have confused everyone but please help if you can.
accSendObject Module Code
Code:
Option Compare Database
Option Explicit
Private MAPISession As MAPI.Session
Private MAPIMessage As message
Private MAPIRecipient As MAPI.Recipient
Private MAPIAttachment As MAPI.Attachment
Private reciparray
Private strFileName As String
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Private Const REG_SZ As Long = 1
Private Const REG_DWORD As Long = 4
Private Const HKEY_CURRENT_USER = &H80000001
Private Const ERROR_NONE = 0
Private Const ERROR_BADDB = 1
Private Const ERROR_BADKEY = 2
Private Const ERROR_CANTOPEN = 3
Private Const ERROR_CANTREAD = 4
Private Const ERROR_CANTWRITE = 5
Private Const ERROR_OUTOFMEMORY = 6
Private Const ERROR_INVALID_PARAMETER = 7
Private Const ERROR_ACCESS_DENIED = 8
Private Const ERROR_INVALID_PARAMETERS = 87
Private Const ERROR_NO_MORE_ITEMS = 259
Private Const KEY_ALL_ACCESS = &H3F
Private Const REG_OPTION_NON_VOLATILE = 0
Private Declare Function GetVersionEx Lib "kernel32" _
Alias "GetVersionExA" _
(ByRef lpVersionInformation As OSVERSIONINFO) As Long
Private Declare Function RegCloseKey Lib "ADVAPI32.dll" _
(ByVal hKey As Long) As Long
Private Declare Function RegOpenKeyEx Lib "ADVAPI32.dll" _
Alias "RegOpenKeyExA" _
(ByVal hKey As Long, _
ByVal lpSubKey As String, _
ByVal ulOptions As Long, _
ByVal samDesired As Long, _
phkResult As Long) As Long
Private Declare Function RegQueryValueExString Lib "ADVAPI32.dll" _
Alias "RegQueryValueExA" _
(ByVal hKey As Long, _
ByVal lpValueName As String, _
ByVal lpReserved As Long, _
lpType As Long, _
ByVal lpData As String, _
lpcbData As Long) As Long
Private Declare Function RegQueryValueExLong Lib "ADVAPI32.dll" _
Alias "RegQueryValueExA" _
(ByVal hKey As Long, _
ByVal lpValueName As String, _
ByVal lpReserved As Long, _
lpType As Long, lpData As Long, _
lpcbData As Long) As Long
Private Declare Function RegQueryValueExNULL Lib "ADVAPI32.dll" _
Alias "RegQueryValueExA" _
(ByVal hKey As Long, _
ByVal lpValueName As String, _
ByVal lpReserved As Long, _
lpType As Long, _
ByVal lpData As Long, _
lpcbData As Long) As Long
Private Declare Function GetTempPath Lib "kernel32" _
Alias "GetTempPathA" (ByVal nBufferLength As Long, _
ByVal lpBuffer As String) As Long
Public Enum accSendObjectOutputFormat
accOutputrtf = 1
accOutputTXT = 2
accOutputSNP = 3
accOutputXLS = 4
End Enum
Public Sub SendObject(Optional ObjectType As Access.AcSendObjectType = acSendNoObject, _
Optional ObjectName, _
Optional OutputFormat As accSendObjectOutputFormat, _
Optional EmailAddress, _
Optional CC, _
Optional BCC, _
Optional Subject, _
Optional MessageText, _
Optional EditMessage)
Dim strTmpPath As String * 512
Dim sTmpPath As String
Dim strExtension As String
Dim nRet As Long
StartMessagingAndLogon
Set MAPIMessage = MAPISession.Outbox.Messages.add
If ObjectType <> -1 Then
If IsMissing(ObjectName) Or IsMissing(OutputFormat) Then
MsgBox "The object type, name, or output format is not valid. Cannot send message.", vbCritical
MAPISession.Outbox.Messages.delete
GoTo accSendObject_Exit
Else
strExtension = GetExtension(OutputFormat)
nRet = GetTempPath(512, strTmpPath)
If (nRet > 0 And nRet < 512) Then
If InStr(strTmpPath, Chr(0)) > 0 Then
sTmpPath = RTrim(Left(strTmpPath, InStr(1, strTmpPath, Chr(0)) - 1))
End If
strFileName = sTmpPath & ObjectName & strExtension
End If
On Error Resume Next
DoCmd.OutputTo ObjectType, ObjectName, GetOutputFormat(OutputFormat), strFileName, False
If Err.Number = 0 Then
Set MAPIAttachment = MAPIMessage.Attachments.add
With MAPIAttachment
.Name = ObjectName
.Type = CdoFileData
.source = strFileName
End With
Kill strFileName
Else
MsgBox "The object type, name, or output format is not valid. Cannot send message.", vbCritical
MAPISession.Outbox.Messages.delete
GoTo accSendObject_Exit
End If
End If
End If
If Not IsMissing(EmailAddress) Then
reciparray = Split(EmailAddress, ";", -1, vbTextCompare)
ParseAddress CdoTo
Erase reciparray
End If
If Not IsMissing(CC) Then
reciparray = Split(CC, ";", -1, vbTextCompare)
ParseAddress CdoCc
Erase reciparray
End If
If Not IsMissing(BCC) Then
reciparray = Split(BCC, ";")
ParseAddress CdoBcc
Erase reciparray
End If
If Not IsMissing(Subject) Then
MAPIMessage.Subject = Subject
End If
If Not IsMissing(MessageText) Then
MAPIMessage.Text = MessageText
End If
If IsMissing(EditMessage) Then EditMessage = True
MAPIMessage.Update
MAPIMessage.Send savecopy:=True, ShowDialog:=EditMessage
accSendObject_Exit:
'Log off the MAPI session.
MAPISession.Logoff
Set MAPIAttachment = Nothing
Set MAPIRecipient = Nothing
Set MAPIMessage = Nothing
Set MAPISession = Nothing
Exit Sub
End Sub
Private Sub ParseAddress(RecipientType As MAPI.CdoRecipientType)
Dim I As Variant
For Each I In reciparray
Set MAPIRecipient = MAPIMessage.Recipients.add
With MAPIRecipient
.Name = I
.Type = RecipientType
.Resolve
End With
Set MAPIRecipient = Nothing
Next
End Sub
Private Function GetExtension(ObjectType As Long) As String
Select Case ObjectType
Case 1 'RTF
GetExtension = ".RTF"
Case 2 'TXT
GetExtension = ".TXT"
Case 3 'SNP
GetExtension = ".SNP"
Case 4 'XLS
GetExtension = ".XLS"
End Select
End Function
Private Function GetOutputFormat(ObjectType As Long)
Select Case ObjectType
Case 1 'RTF
GetOutputFormat = Access.acFormatRTF
Case 2 'TXT
GetOutputFormat = Access.acFormatTXT
Case 3 'SNP
GetOutputFormat = Access.acFormatSNP
Case 4 'XLS
GetOutputFormat = Access.acFormatXLS
End Select
End Function
Private Sub StartMessagingAndLogon()
Dim sKeyName As String
Dim sValueName As String
Dim sDefaultUserProfile As String
Dim osinfo As OSVERSIONINFO
Dim retvalue As Integer
On Error GoTo ErrorHandler
Set MAPISession = CreateObject("MAPI.Session")
'Try to log on. If this fails, the most likely reason is
'that you do not have an open session. The error
'-2147221231 MAPI_E_LOGON_FAILED returns. Trap
'the error in the ErrorHandler.
MAPISession.Logon ShowDialog:=False, NewSession:=False
Exit Sub
ErrorHandler:
Select Case Err.Number
Case -2147221231 'MAPI_E_LOGON_FAILED
'Need to determine what operating system is in use. The keys are different
'for WinNT and Win95.
osinfo.dwOSVersionInfoSize = 148
osinfo.szCSDVersion = Space$(128)
retvalue = GetVersionEx(osinfo)
Select Case osinfo.dwPlatformId
Case 0 'Unidentified
MsgBox "Unidentified Operating System. " & _
"Cannot log on to messaging."
Exit Sub
Case 1 'Win95
sKeyName = "Software\Microsoft\" & _
"Windows Messaging " & _
"Subsystem\Profiles"
Case 2 'NT
sKeyName = "Software\Microsoft\Windows NT\" & _
"CurrentVersion\" & _
"Windows Messaging Subsystem\Profiles"
End Select
sValueName = "DefaultProfile"
sDefaultUserProfile = QueryValue(sKeyName, sValueName)
MAPISession.Logon ProfileName:=sDefaultUserProfile, _
ShowDialog:=False
Exit Sub
Case Else
MsgBox "An error has occured while trying" & Chr(10) & _
"to create and to log on to a new ActiveMessage session." & _
Chr(10) & "Report the following error to your " & _
"System Administrator." & Chr(10) & Chr(10) & _
"Error Location: frmMain.StartMessagingAndLogon" & _
Chr(10) & "Error Number: " & Err.Number & Chr(10) & _
"Description: " & Err.Description
End Select
End Sub
Private Function QueryValue _
(sKeyName As String, _
sValueName As String)
Dim lRetVal As Long 'Result of the API functions.
Dim hKey As Long 'Handle of the opened key.
Dim vValue As Variant 'Setting of the queried value.
lRetVal = RegOpenKeyEx(HKEY_CURRENT_USER, _
sKeyName, _
0, _
KEY_ALL_ACCESS, _
hKey)
lRetVal = QueryValueEx(hKey, _
sValueName, _
vValue)
QueryValue = vValue
RegCloseKey (hKey)
End Function
Private Function QueryValueEx _
(ByVal lhKey As Long, _
ByVal szValueName As String, _
vValue As Variant) As Long
Dim cch As Long
Dim lrc As Long
Dim lType As Long
Dim lValue As Long
Dim sValue As String
On Error GoTo QueryValueExError
' Determine the size and the type of the data to be read.
lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)
If lrc <> ERROR_NONE Then Error 5
Select Case lType
' For strings
Case REG_SZ:
sValue = String(cch, 0)
lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, _
sValue, cch)
If lrc = ERROR_NONE Then
vValue = Left$(sValue, cch)
Else
vValue = Empty
End If
' For DWORDS
Case REG_DWORD:
lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, _
lValue, cch)
If lrc = ERROR_NONE Then vValue = lValue
Case Else
'All other data types that are not supported.
lrc = -1
End Select
QueryValueExExit:
QueryValueEx = lrc
Exit Function
QueryValueExError:
Resume QueryValueExExit
End FunctionClick/Yes Code
Code:
' Declare Windows' API functions
Private Declare Function RegisterWindowMessage _
Lib "user32" Alias "RegisterWindowMessageA" _
(ByVal lpString As String) As Long
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" (ByVal lpClassName As Any, _
ByVal lpWindowName As Any) As Long
Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" (ByVal hwnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, _
lParam As Any) As Long
Private Sub SomeProc()
Dim wnd As Long
Dim uClickYes As Long
Dim Res As Long
' Register a message to send
uClickYes = RegisterWindowMessage("CLICKYES_SUSPEND_RESUME")
' Find ClickYes Window by classname
wnd = FindWindow("EXCLICKYES_WND", 0&)
' Send the message to Resume ClickYes
Res = SendMessage(wnd, uClickYes, 1, 0)
' ...
' Do some Actions
' ...
' Send the message to Suspend ClickYes
Res = SendMessage(wnd, uClickYes, 0, 0)
End SubCode invoked when checkbox is clicked
Code:
Private Sub BMS_OMS_Click()
DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, , acMenuVer70
If Me.BMS_OMS.Value = True Then
SendMail4
End If
End Sub
Sub SendMail4()
DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, , acMenuVer70
Dim clsSendObject As accSendObject
Dim strMsg As String
Dim emailsubject As String
Dim emailtext As String
Dim SL As String, DL As String
SL = vbNewLine
DL = SL & SL
emailtext = "The Below named BMS-OMS needs updated for viewing or a New OMS was Created." & DL & _
"Process:=" & Me.Process & DL & _
"OMS Name:=" & Me.OMS_Name & DL & _
"If BMS-OMS does it require Immediate update:= " & Me.Combo448 & DL & _
"Thank you," & SL & _
Me.OMS_Worker
emailsubject = "Form #: " & Me.Form__.Value & "; BMS-OMS NEEDS UPDATED FOR VIEWING or NEW OMS WAS CREATED; " & _
"OMS Name:= " & Me.OMS_Name & "; Immediate Update Required:= " & Me.Combo448
Set clsSendObject = New accSendObject
strMsg = String(3000, "a")
clsSendObject.SendObject , , accOutputrtf, _
"abajacks@nmhg.com", "abmhende@nmhg.com", "", emailsubject, emailtext, True
Set clsSendObject = Nothing
End Sub