I am trying to allow users to drag and drop an Outlook email on to a form and have it save the .msg to a destination folder and store the information in a table.
I have read the tutorials and achieved this for regular files (drag and drop via explorer) using a ListView control but Outlook emails are handled differently. When I tried to adapt code (from tek tips threads) I get a runtime error 287 "Application-defined or object-defined error" in the line in blue below.
Using both Outlook and Access 2016 - need it to work with Outlook 2010 as well.
Any suggestions?
I have read the tutorials and achieved this for regular files (drag and drop via explorer) using a ListView control but Outlook emails are handled differently. When I tried to adapt code (from tek tips threads) I get a runtime error 287 "Application-defined or object-defined error" in the line in blue below.
Using both Outlook and Access 2016 - need it to work with Outlook 2010 as well.
Any suggestions?
Code:
Private Sub ListView2_OLEDragDrop(Data As Object, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
'Code originally from tek tips user jhaganjr.
Dim olApp As Outlook.Application
Dim olExp As Outlook.Explorer
Dim olSel As Outlook.Selection
Dim i, intCounter, intResponse As Integer
Dim strFilename, strSQL, strFolderPath, strPathAndFile, strMsg As String
Dim fs As Object
Dim fsFolder As Object
Dim blnFolderExists, blnFileExists As Boolean
Dim Cancel As Integer
'Set folder path
Set fsFolder = CreateObject("Scripting.FileSystemObject")
strFolderPath = "C:\temp"
If fsFolder.FolderExists(strFolderPath) = False Then
fsFolder.CreateFolder (strFolderPath)
End If
'Create the filename as a message file from the ClientID and the NoteID - which will be unique
strFilename = Me.DocID & "_" & "temp" & ".msg"
'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
[COLOR=Blue] olSel.Item(i).SaveAs strPathAndFile, olMSG[/COLOR]
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![DocLocation] = strPathAndFile
Me.EmailMemo = "EMAIL ATTACHED: Click Here To View"
Me.EmailMemo.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