Dragging an outlook email to my VB6 app

Some functionality I would like to add to an old vb6 app.

Currently, I can drag an outlook email to the desktop and it'll create a file like this: "Email subject.msg".

Then I'm using this code to open that file/email from vb6 and it allows me to extract some informations:

Code:

---

            Dim OL As Outlook.Application
            Dim Msg As Outlook.MailItem
           
            Set OL = New Outlook.Application
            Set Msg = OL.CreateItemFromTemplate(fld & "\" & fil.Name)
           
            ' now use msg to get at the email parts
            'MsgBox Msg.Subject
            strFinal = Msg.body
            strTo = Msg.To
            strToEmail = Msg.Recipients.Item(1).Address
            Set OL = Nothing
            Set Msg = Nothing

---

This is fun. But now I wanted to do the same thing, but instead of dragging the email onto the desktop, I'd be dragging it straight into my vb6 form (example: on a textbox).
The Text1_OLEDragDrop event gets fired but I wouldn't know how to use "Data As DataObject". There could be some way of interacting with outlook in a much more sophisticated and optimized method, but honestly, if this drag-drop event could just allow me to save the .msg to, say, c:\temp\temp_email.msg, I'd be good to go with method shown above. That would completely do it.

Any idea on how to save it to file?

Thank you!

Can you make up a small(or trimmed) project which has all of your Outlook drag code working.
If you attach that, I will compare it to code I have that is part of a large application.
My code actually is designed to allow dragging of Outlook message (which has an attachment), into my VB6 program, and the attachment is copied into a folder on the hard disc.
I notice that as an unwanted side effect, it ALSO drops the email file into the App.Path (My App.paths are not in the 'Programs' folder, they are in a folder we created). (I never use the 'Programs' folder. My programs do not require installation, so we create a folder in the C directory, for locating the VB6 program)
Once i see your code and compare it to mine, there is a chance I can tweak your code to do similar (drop the email into your chosen folder).

Rob

This may interest you...


As noted in the code rems my original ref/ link for this code has gone 404, but the first bold post in this http://www.44342.com/Visual-Basic-f948-t18515-p1.htm is by the same author (Cees Verburg) and contains similar albeit incomplete code.

When I tried to open the demo I got:

I get the same thing (as is usual) if I double click on the vbp from inside the compressed zip folder. You must right click on the zip select Extract all and then double click the vbp from inside the uncompressed folder.

Hi,

well I don't Drag and Drop Emails and save them.
Perhaps you can change this it saves new Emails to a Folder....

Code:

---

Private Sub Command3_Click()
Save_InboxFolder
End Sub

Public Function Save_InboxFolder()
 
  Dim appOL As Outlook.Application
  Dim myPost As Outlook.MailItem
  Dim nsp As Outlook.NameSpace
  Dim fld As Outlook.MAPIFolder
  Dim J As Long
 
  Set appOL = New Outlook.Application
  Set nsp = appOL.GetNamespace("MAPI")
  Set fld = nsp.GetDefaultFolder(olFolderInbox)
  For J = 1 To fld.Items.Count
    On Error Resume Next
    Set myPost = fld.Items(J)
      'If myPost.UnRead = True Then '<-- save only new Posts to the c:\temp folder
    If Err = 0 Then
      myPost.SaveAs "c:\Temp\" & Format(J, "000") & myPost.SenderName & ".msg", olMSG
    Else
      MsgBox "Item(" & J & ") Is not a Mailitem"
    End If
  ' End If
  Next
  Set myPost = Nothing
  Set fld = Nothing
  Set appOL = Nothing
End Function

---

regards
Chris

These may help -

This answer was provided by Edanmo the most prolific expert on Outlook drag/drop
http://forums.devx.com/showthread.ph...ail-to-listbox

This apparently will get the contents of the email for you
http://www.tek-tips.com/viewthread.cfm?qid=516846

Rob

Using Automation of Outlook only try;

In a new Form

Code:

---

Option Explicit

'from an idea at http://www.xtremevbtalk.com/word-powerpoint-outlook-and-other-office-products/56914-drag-email-messages-outlook-vb-form.html

Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal HWND As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long

Private Sub Form_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
   
    Dim i&, j&
    Dim Subject$, sWindowClass$
   
    sWindowClass = GetWindowClass(GetForegroundWindow)
    'is Outlook have focus
    If InStr(1, sWindowClass, "rctrl_renwnd32") Then
        'yes it does so drag must be coming from it
        With GetObject(, "Outlook.Application") 'New Outlook.Application
            With .ActiveExplorer
                With .Selection
                    For i = 1 To .Count    'the number of emails selected
                        Debug.Print .Item(i).Subject
                        Debug.Print .Item(i).Body
                        Debug.Print .Item(i).Attachments.Count
                        'to save the email as a msg file (with attachments)
                        ' first strip out characters which should not be included in file names
                        Subject$ = Replace$(.Item(i).Subject, ":", "")
                        Subject$ = Replace$(Subject$, "/", "")
                        Subject$ = Replace$(Subject$, "\", "")
                        'etc. there are more 'illegal' file chars e.g. *, ?, .
                        .Item(i).SaveAs CurDir$ & "\" & Subject$ & ".msg", olMSG
                        With .Item(i)
                            For j = 1 To .Attachments.Count 'the number of attachments to the email
                                Debug.Print .Attachments(j).FileName
                                'to save the attachments separately
                                .Attachments(j).SaveAsFile CurDir$ & "\" & .Attachments(j).FileName
                            Next
                        End With
                    Next
                End With
            End With
        End With
    End If
   
End Sub

Private Function GetWindowClass(ByVal HWND As Long) As String
' Return the class name of the specified window
    Dim sClass As String
    sClass = Space$(256)
    GetClassName HWND, sClass, 255
    GetWindowClass = Left$(sClass, InStr(sClass, vbNullChar) - 1)
End Function

---

Drag emails from Outlook onto the Form surface.
If you want to run/ debug the above in the IDE you must run it in 'normal' mode i.e. Not as Administrator.

I was searching my extensive collection of saved VB6 projects, and web pages, to help another thread, and came across this on one of my saved web pages. I did a Google to find the current live web page and could not find it. So I will paste the code (and credit for the source) -

Access Each Message in Outlook Inbox
Author: Intelligent Solutions Inc. (Featured Developer)
Category: Office/VBA
Type: Snippets
Difficulty: Beginning
Version Compatibility: Visual Basic 6

More information: This routine gets access the outlook inbox folder on the local machine, loops through each message, reads basic info about the message, and saves the message and all of it's attachments. It is designed to give you a basic idea of what you can do with the outlook object model, especially the contents of folders. A reference to Microsoft Outlook Type Library is required.

This code has been viewed 156880 times. (AND THAT WAS WHEN I SAVED THIS PAGE IN 2009)

Instructions: Copy the declarations and code below and paste directly into your VB project.

Declarations:

'(None)

Code:

Code:

---

Public Sub ProcessInbox()
Dim oOutlook As Outlook.Application
Dim oNs As Outlook.NameSpace
Dim oFldr As Outlook.MAPIFolder
Dim oAttachments As Outlook.Attachments
Dim oAttachment As Outlook.Attachment
Dim iMsgCount As Integer

Dim oMessage As Outlook.MailItem

Dim iCtr As Long, iAttachCnt As Long

Dim sFileNames As String
Dim aFileNames() As String


'get reference to inbox
Set oOutlook = New Outlook.Application
Set oNs = oOutlook.GetNamespace("MAPI")
Set oFldr = oNs.GetDefaultFolder(olFolderInbox)
Debug.Print "Total Items: "; oFldr.Items.Count
Debug.Print "Total Unread items = " & oFldr.UnReadItemCount


For Each oMessage In oFldr.Items
       
        With oMessage
        'basic info about message
            Debug.Print .To
            Debug.Print .CC
            Debug.Print .Subject
            Debug.Print .Body
            If .UnRead Then
                Debug.Print "Message has not been read"
            Else
                Debug.Print "Message has been read"
            End If
            iMsgCount = iMsgCount + 1
            'save message as text file
            .SaveAs "C:\message" & iMsgCount & ".txt", olTXT

            'reference and save all attachments
            With oMessage.Attachments
                iAttachCnt = .Count
                If iAttachCnt > 0 Then
                    For iCtr = 1 To iAttachCnt

            .Item(iCtr).SaveAsFile "C:\" & .Item(iCtr).FileName

                    Next iCtr
                End If
            End With
        End With
        DoEvents

    Next oMessage   
   
    Set oAttachment = Nothing
    Set oAttachments = Nothing
    Set oMessage = Nothing
    Set oFldr = Nothing
    Set oNs = Nothing
    Set oOutlook = Nothing
   
End Sub

---

HTH,
Rob
PS I did come across this live page -
http://www.freevbcode.com/ShowCode.asp?ID=4837
Same site, same author, but page looks different.
Not sure which is the latest/best ?

it is easy enough to know if an outlook message has been dropped to your app, then automate outlook to process the still selected items from the outlook object currentfolder

more of a work around than an actual solution, but the user won't notice

Hi,

I extenden the Code from my Post#2 and Bobbles Code from Post#9
EDIT: I meant Post#6 and #9

Code:

---

Option Explicit

Private Sub Command1_Click()
SaveOlInboxToTemp
End Sub

Public Function SaveOlInboxToTemp()
  Dim appOL As Outlook.Application
  Dim myPost As Outlook.MailItem
  Dim nsp As Outlook.NameSpace
  Dim fld As Outlook.MAPIFolder
  Dim myFolderName As String
 
  Dim j As Long
  Dim i As Long
  Dim Anzahl As Long
  Set appOL = New Outlook.Application
  Set nsp = appOL.GetNamespace("MAPI")
  Set fld = nsp.GetDefaultFolder(olFolderInbox)
  For j = 1 To fld.Items.Count
    On Error Resume Next
    Set myPost = fld.Items(j)
    If Err = 0 Then
    'create a Folder with SenderName
        myFolderName = "C:\TestPic\" & myPost.SenderName
                    MkDir myFolderName
 
  'now save the Email to that specific Folder
    myFolderName = "C:\TestPic\" & myPost.SenderName & "\"
    myPost.SaveAs myFolderName & Format(j, "000") & " - " & myPost.SenderName & ".msg", olMSG
    End If
    Next
   
    'now save the Attachments to that specific Folder separately
    For Each myPost In fld.Items
        With myPost
          '  If .UnRead = True Then
                Anzahl = .Attachments.Count
                If Anzahl > 0 Then
                    myFolderName = "C:\TestPic\" & myPost.SenderName
'                    MkDir myFolderName
                    For i = 1 To Anzahl
                        .Attachments.Item(i).SaveAsFile myFolderName & "\" & .Attachments.Item(i).FileName
                    Next i
                End If
        '  End If
        End With
    Next myPost
  Set myPost = Nothing
  Set fld = Nothing
  Set appOL = Nothing
End Function

---

regards
Chris

Quote:

---

Originally Posted by ChrisE

Hi,

I extenden the Code from my Post#2 and Bobbles Code from Post#9
EDIT: I meant Post#6 and #9

Code:

---

Option Explicit

Private Sub Command1_Click()
SaveOlInboxToTemp
End Sub

Public Function SaveOlInboxToTemp()
  Dim appOL As Outlook.Application
  Dim myPost As Outlook.MailItem
  Dim nsp As Outlook.NameSpace
  Dim fld As Outlook.MAPIFolder
  Dim myFolderName As String
 
  Dim j As Long
  Dim i As Long
  Dim Anzahl As Long
  Set appOL = New Outlook.Application
  Set nsp = appOL.GetNamespace("MAPI")
  Set fld = nsp.GetDefaultFolder(olFolderInbox)
  For j = 1 To fld.Items.Count
    On Error Resume Next
    Set myPost = fld.Items(j)
    If Err = 0 Then
    'create a Folder with SenderName
        myFolderName = "C:\TestPic\" & myPost.SenderName
                    MkDir myFolderName
 
  'now save the Email to that specific Folder
    myFolderName = "C:\TestPic\" & myPost.SenderName & "\"
    myPost.SaveAs myFolderName & Format(j, "000") & " - " & myPost.SenderName & ".msg", olMSG
    End If
    Next
   
    'now save the Attachments to that specific Folder separately
    For Each myPost In fld.Items
        With myPost
          '  If .UnRead = True Then
                Anzahl = .Attachments.Count
                If Anzahl > 0 Then
                    myFolderName = "C:\TestPic\" & myPost.SenderName
'                    MkDir myFolderName
                    For i = 1 To Anzahl
                        .Attachments.Item(i).SaveAsFile myFolderName & "\" & .Attachments.Item(i).FileName
                    Next i
                End If
        '  End If
        End With
    Next myPost
  Set myPost = Nothing
  Set fld = Nothing
  Set appOL = Nothing
End Function

---

regards
Chris

---

Just trying it out of the box it keeps trying to create the same folder in a loop:

'create a Folder with SenderName
myFolderName = "C:\TestPic\" & myPost.SenderName
MkDir myFolderName

Hi Tyson,

I'm sure you could have changed it;-))

Code:

---

'create a Folder with SenderName
  myFolderName = "C:\TestPic\" & myPost.SenderName
                        For i = 1 To myFolderName
                            MkDir myFolderName
                    Next i

---

EDIT:
thinking about creating the Folders, perhaps it is better using the Contacts rather than
the Inbox. In the Inbox the could be 5x [email protected] messages.

so the Folder creation Logic should come from what in the Contacts Folder
if an incomming Email is not in the Contacts Folder then there should be an extra Folder -others-

perhaps that is what you mean?

regards
Chris

Hello Bobbles (and everyone part of this thread).
I'll be back to this little project of mine soon and I am still experiencing trouble doing this little simple task.

If I drag an email from desktop to my app, it works great - I can extract Subject/Body.

If I drag STRAIGHT from Outlook, I wouldn't quite know how to extract Subject/Body.

One workaround could be to copy the data to C:\TempEmail.msg and go from that. Could this work?

I've attached a very simple and small VB6 project, thank you for taking a look!

Magic Ink's post (post #8) did the job!... Works nicely! Thank you!

Good.

each method i have seen show how to loop through and save all attachments, how can i drag only one file ( if 3 files attached) and only save that one