Lisa_Sunshine
Programmer
This is referencing this thread "thread181-1346884"
I works with one exception, Outlook doesn't recognized the file type even with the .msg.
I manually drag & drop an email into the same location where I'm storing the email copies.
I am able to open this file in Outlook, but when I generate a .msg from my Access form using this code, it appears to have worked but creates a 'text' file in reality. Outlook doesn't recognize the code page.
I opened both .msg (one generated by my code, the other by Outlook) in NotePad++, it's clear that its a code page issue. I can read my .msg file generated by my code in NotePad++. Which I believe it's in 1252 Unicode format. When I open the .msg generated by Outlook in NotePad++, I'm not able to read it.
I also switched the memo to a hyperlink field. I manually added the path to the database, opened the form and it opens the Outlook generated .msg but not my code generated drag & drop .msg file. It's because Outlook does not recognize the file code page. I'm thinking. I hope someone can help me solve this.
My code:
Private Sub Email_Dirty(Cancel As Integer)
StartOutlook
'I got the guts of this sub from Remou on tek-tips.com. S/he told me I can drag and drop an
'email to a memo field, then gave me the object control code to save the file.
' Dim olApp As Object 'Outlook.Application
Dim olExp As Object 'Outlook.Explorer
Dim olSel As Object 'Outlook.Selection
Dim oMail As Object 'Outlook.MailItem
Dim i, intCounter, intResponse As Integer
Dim strFilename, strSQL, strFolderPath, strPathAndFile, strMsg, strVendorID As String
Dim fs As Object
Dim fsFolder As Object
Dim blnFolderExists, blnFileExists As Boolean
'strVendorID = VendorID
'This field is used to control attaching emails by dropping them on the field.
'To allow this the field must be editable. This means the user could accidentally
'type in the field and trigger the code to attach an email. Therefore, this user
'verification makes sure the user intentionally dropped an email on the field.
strMsg = "WARNING: You have triggered the E-mail Attachment Function. CHOOSE CAREFULLY ..." & vbCr & vbCr
strMsg = strMsg & "If you intended to attach an e-mail to this note, answer Yes below. "
strMsg = strMsg & "If you did not intend to attach an e-mail and don't know what's going on, "
strMsg = strMsg & "answer No below." & vbCr & vbCr
strMsg = strMsg & "Did you intentionally drag and drop an e-mail to attach it to this note?"
intResponse = MsgBox(strMsg, vbYesNo)
If intResponse = 7 Then 'No
Cancel = True
Exit Sub
End If
'My network consultant advises not putting too many files in a folder - like our Permanent Images.
'Therefore, I will separate emails into a new folder each year. This code allows me
'to never check on it, by creating the folder automatically when the year changes.
Set fsFolder = CreateObject("Scripting.FileSystemObject")
strFolderPath = CurrentProject.Path & "\EmailHistory\" & Me![VendorID]
If fsFolder.FolderExists(strFolderPath) = False Then
fsFolder.CreateFolder (strFolderPath)
End If
strFilename = Me![VendorID] & "_" & Str(Now()) & ".msg" 'Me![SvcNoteID] & ".msg"
'Create the filename as a message file from the ClientID and the NoteID - which will be unique
If InStr(strFilename, "/") > 0 Then
strFilename = Replace(strFilename, "/", "")
strFilename = Replace(strFilename, ":", "")
strFilename = Replace(strFilename, " ", "_")
End If
'Combine for full path and file name
strPathAndFile = strFolderPath & "\" & strFilename
'Make sure this file does not already exist to avoid overwriting email files when there is a
'system glitch.
Set fs = CreateObject("Scripting.FileSystemObject")
blnFileExists = fs.FileExists(strPathAndFile)
If blnFileExists = False Then
'There's not already a file for this client and noteID. This is the way it always
'should be. But stuff happens. So, I'm checking.
'Save the email to the filename just created as a message file
Set olApp = GetObject("", "Outlook.Application") 'First argument is blank to return the currently active Outlook object, otherwise runtime fails
Set olExp = olApp.ActiveExplorer
Set olSel = olExp.Selection
For i = 1 To olSel.Count
olSel.Item(1).SaveAs strPathAndFile, olMSG
Next
Else
'There's already a file for this client and noteID. This should be impossible,
'but stuff happens. In this case we notify the user and then re-establish the links
'so the user can handle it.
strMsg = "ATTENTION: The system detected an e-mail file already created for this note. "
strMsg = strMsg & "That e-mail is now linked to this note ID. Please do the following:" & vbCr & vbCr
strMsg = strMsg & "1. View the e-mail normally." & vbCr
strMsg = strMsg & "2. If it is the correct e-mail, you don't need to do anything else." & vbCr
strMsg = strMsg & "3. If it is the wrong e-mail, use the Un-Attach E-mail button to get rid of it. "
strMsg = strMsg & "Then attach the correct e-mail."
MsgBox strMsg
End If
'Update the location field with the location.
Cancel = True 'To roll back changes caused by the drop.
Me! = strPathAndFile
'Me.Email = "EMAIL ATTACHED: Click Here To View"
Me.Email.Locked = True
Me.Dirty = False 'To save the changes.
Set fsFolder = Nothing
Set fs = Nothing
Set olSel = Nothing
Set olExp = Nothing
Set olApp = Nothing
End Sub
****************
Private Sub StartOutlook()
On Error GoTo Error_Handler
Dim oOutlook As Object
Dim sAPPPath As String
If IsAppRunning("Outlook.Application") = True Then 'Outlook was already running
Set oOutlook = GetObject(, "Outlook.Application") 'Bind to existing instance of Outlook
Else 'Could not get instance of Outlook, so create a new one
sAPPPath = GetAppExePath("outlook.exe") 'determine outlook's installation path
Shell (sAPPPath) 'start outlook
Do While Not IsAppRunning("Outlook.Application")
DoEvents
Loop
Set oOutlook = GetObject(, "Outlook.Application") 'Bind to existing instance of Outlook
End If
Const olMailItem = 0
' Dim oOutlookMsg As Object
' Set oOutlookMsg = oOutlook.CreateItem(olMailItem) 'Start a new e-mail message
' oOutlookMsg.Display 'Show the message to the user
Error_Handler_Exit:
On Error Resume Next
Set oOutlook = Nothing
Exit Sub
Error_Handler:
MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: StartOutlook" & vbCrLf & _
"Error Description: " & Err.Description _
, vbOKOnly + vbCritical, "An Error has Occured!"
Resume Error_Handler_Exit
End Sub
*********
Function GetAppExePath(ByVal sExeName As String) As String
On Error GoTo Error_Handler
Dim WSHShell As Object
Set WSHShell = CreateObject("Wscript.Shell")
GetAppExePath = WSHShell.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\" & sExeName & "\")
Error_Handler_Exit:
On Error Resume Next
Set WSHShell = Nothing
Exit Function
Error_Handler:
If Err.Number = -2147024894 Then
'Cannot locate requested exe????
Else
MsgBox "The following error has occured." & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: GetAppExePath" & vbCrLf & _
"Error Description: " & Err.Description, _
vbCritical, "An Error has Occured!"
End If
Resume Error_Handler_Exit
End Function
Function IsAppRunning(sApp As String) As Boolean
On Error GoTo Error_Handler
Dim oApp As Object
Set oApp = GetObject(, sApp)
IsAppRunning = True
Error_Handler_Exit:
On Error Resume Next
Set oApp = Nothing
Exit Function
Error_Handler:
Resume Error_Handler_Exit
End Function
I works with one exception, Outlook doesn't recognized the file type even with the .msg.
I manually drag & drop an email into the same location where I'm storing the email copies.
I am able to open this file in Outlook, but when I generate a .msg from my Access form using this code, it appears to have worked but creates a 'text' file in reality. Outlook doesn't recognize the code page.
I opened both .msg (one generated by my code, the other by Outlook) in NotePad++, it's clear that its a code page issue. I can read my .msg file generated by my code in NotePad++. Which I believe it's in 1252 Unicode format. When I open the .msg generated by Outlook in NotePad++, I'm not able to read it.
I also switched the memo to a hyperlink field. I manually added the path to the database, opened the form and it opens the Outlook generated .msg but not my code generated drag & drop .msg file. It's because Outlook does not recognize the file code page. I'm thinking. I hope someone can help me solve this.
My code:
Private Sub Email_Dirty(Cancel As Integer)
StartOutlook
'I got the guts of this sub from Remou on tek-tips.com. S/he told me I can drag and drop an
'email to a memo field, then gave me the object control code to save the file.
' Dim olApp As Object 'Outlook.Application
Dim olExp As Object 'Outlook.Explorer
Dim olSel As Object 'Outlook.Selection
Dim oMail As Object 'Outlook.MailItem
Dim i, intCounter, intResponse As Integer
Dim strFilename, strSQL, strFolderPath, strPathAndFile, strMsg, strVendorID As String
Dim fs As Object
Dim fsFolder As Object
Dim blnFolderExists, blnFileExists As Boolean
'strVendorID = VendorID
'This field is used to control attaching emails by dropping them on the field.
'To allow this the field must be editable. This means the user could accidentally
'type in the field and trigger the code to attach an email. Therefore, this user
'verification makes sure the user intentionally dropped an email on the field.
strMsg = "WARNING: You have triggered the E-mail Attachment Function. CHOOSE CAREFULLY ..." & vbCr & vbCr
strMsg = strMsg & "If you intended to attach an e-mail to this note, answer Yes below. "
strMsg = strMsg & "If you did not intend to attach an e-mail and don't know what's going on, "
strMsg = strMsg & "answer No below." & vbCr & vbCr
strMsg = strMsg & "Did you intentionally drag and drop an e-mail to attach it to this note?"
intResponse = MsgBox(strMsg, vbYesNo)
If intResponse = 7 Then 'No
Cancel = True
Exit Sub
End If
'My network consultant advises not putting too many files in a folder - like our Permanent Images.
'Therefore, I will separate emails into a new folder each year. This code allows me
'to never check on it, by creating the folder automatically when the year changes.
Set fsFolder = CreateObject("Scripting.FileSystemObject")
strFolderPath = CurrentProject.Path & "\EmailHistory\" & Me![VendorID]
If fsFolder.FolderExists(strFolderPath) = False Then
fsFolder.CreateFolder (strFolderPath)
End If
strFilename = Me![VendorID] & "_" & Str(Now()) & ".msg" 'Me![SvcNoteID] & ".msg"
'Create the filename as a message file from the ClientID and the NoteID - which will be unique
If InStr(strFilename, "/") > 0 Then
strFilename = Replace(strFilename, "/", "")
strFilename = Replace(strFilename, ":", "")
strFilename = Replace(strFilename, " ", "_")
End If
'Combine for full path and file name
strPathAndFile = strFolderPath & "\" & strFilename
'Make sure this file does not already exist to avoid overwriting email files when there is a
'system glitch.
Set fs = CreateObject("Scripting.FileSystemObject")
blnFileExists = fs.FileExists(strPathAndFile)
If blnFileExists = False Then
'There's not already a file for this client and noteID. This is the way it always
'should be. But stuff happens. So, I'm checking.
'Save the email to the filename just created as a message file
Set olApp = GetObject("", "Outlook.Application") 'First argument is blank to return the currently active Outlook object, otherwise runtime fails
Set olExp = olApp.ActiveExplorer
Set olSel = olExp.Selection
For i = 1 To olSel.Count
olSel.Item(1).SaveAs strPathAndFile, olMSG
Next
Else
'There's already a file for this client and noteID. This should be impossible,
'but stuff happens. In this case we notify the user and then re-establish the links
'so the user can handle it.
strMsg = "ATTENTION: The system detected an e-mail file already created for this note. "
strMsg = strMsg & "That e-mail is now linked to this note ID. Please do the following:" & vbCr & vbCr
strMsg = strMsg & "1. View the e-mail normally." & vbCr
strMsg = strMsg & "2. If it is the correct e-mail, you don't need to do anything else." & vbCr
strMsg = strMsg & "3. If it is the wrong e-mail, use the Un-Attach E-mail button to get rid of it. "
strMsg = strMsg & "Then attach the correct e-mail."
MsgBox strMsg
End If
'Update the location field with the location.
Cancel = True 'To roll back changes caused by the drop.
Me! = strPathAndFile
'Me.Email = "EMAIL ATTACHED: Click Here To View"
Me.Email.Locked = True
Me.Dirty = False 'To save the changes.
Set fsFolder = Nothing
Set fs = Nothing
Set olSel = Nothing
Set olExp = Nothing
Set olApp = Nothing
End Sub
****************
Private Sub StartOutlook()
On Error GoTo Error_Handler
Dim oOutlook As Object
Dim sAPPPath As String
If IsAppRunning("Outlook.Application") = True Then 'Outlook was already running
Set oOutlook = GetObject(, "Outlook.Application") 'Bind to existing instance of Outlook
Else 'Could not get instance of Outlook, so create a new one
sAPPPath = GetAppExePath("outlook.exe") 'determine outlook's installation path
Shell (sAPPPath) 'start outlook
Do While Not IsAppRunning("Outlook.Application")
DoEvents
Loop
Set oOutlook = GetObject(, "Outlook.Application") 'Bind to existing instance of Outlook
End If
Const olMailItem = 0
' Dim oOutlookMsg As Object
' Set oOutlookMsg = oOutlook.CreateItem(olMailItem) 'Start a new e-mail message
' oOutlookMsg.Display 'Show the message to the user
Error_Handler_Exit:
On Error Resume Next
Set oOutlook = Nothing
Exit Sub
Error_Handler:
MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: StartOutlook" & vbCrLf & _
"Error Description: " & Err.Description _
, vbOKOnly + vbCritical, "An Error has Occured!"
Resume Error_Handler_Exit
End Sub
*********
Function GetAppExePath(ByVal sExeName As String) As String
On Error GoTo Error_Handler
Dim WSHShell As Object
Set WSHShell = CreateObject("Wscript.Shell")
GetAppExePath = WSHShell.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\" & sExeName & "\")
Error_Handler_Exit:
On Error Resume Next
Set WSHShell = Nothing
Exit Function
Error_Handler:
If Err.Number = -2147024894 Then
'Cannot locate requested exe????
Else
MsgBox "The following error has occured." & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: GetAppExePath" & vbCrLf & _
"Error Description: " & Err.Description, _
vbCritical, "An Error has Occured!"
End If
Resume Error_Handler_Exit
End Function
Function IsAppRunning(sApp As String) As Boolean
On Error GoTo Error_Handler
Dim oApp As Object
Set oApp = GetObject(, sApp)
IsAppRunning = True
Error_Handler_Exit:
On Error Resume Next
Set oApp = Nothing
Exit Function
Error_Handler:
Resume Error_Handler_Exit
End Function