DevX Home    Today's Headlines   Articles Archive   Tip Bank   Forums   

Results 1 to 3 of 3

Thread: Outlook - Dragdrop whole mail to listbox

  1. #1
    Mats Edvardsson Guest

    Outlook - Dragdrop whole mail to listbox

    Hi
    In this discussiongroup I have found a lot of knowledge. Last issue I asked
    for was how to dragdrop a selected attachment and in just 24 hours I had a
    functional code. Thanks Edanmo.
    Now I have a problem in the same direction.
    How to dragdrop a WHOLE mail into a listbox. Save it as a msg file. All
    included like pictures and attachments. It has to work the same way as when
    you dragdrop a mail from Outlook to windows explorer.

    Thanks
    Mats



  2. #2
    Eduardo A. Morcillo [MVP] Guest

    Re: Outlook - Dragdrop whole mail to listbox

    > Now I have a problem in the same direction.
    > How to dragdrop a WHOLE mail into a listbox. Save it as a msg file.
    > All included like pictures and attachments. It has to work the same
    > way as when you dragdrop a mail from Outlook to windows explorer.



    Somebody said my name? Copy and paste the following code to a .bas
    module, then use SaveMessage to save the message file (it works with Outlook
    and OE messages).

    Option Explicit

    ' Clipboard formats
    Public CF_FileContents As Integer
    Public CF_FileGroupDescriptorW As Integer
    Public CF_FileGroupDescriptor As Integer
    Public CF_OutlookExpressMessages As Integer


    Public Function GetMessageFilename(ByVal Data As DataObject, ByVal Index As
    Long) As String
    Dim oDO As olelib.IDataObject
    Dim tFMT As olelib.FORMATETC
    Dim tSTGM As olelib.STGMEDIUM
    Dim tFDA As FILEDESCRIPTORA
    Dim tFDW As FILEDESCRIPTORW

    ' Get the IDataObject interface
    ' from the Data object
    Set oDO = IDataObjectFromData(Data)

    ' Initialize the FORMATETC structure
    With tFMT
    .cfFormat = CF_FileGroupDescriptorW
    .dwAspect = DVASPECT_CONTENT
    .lindex = -1
    .TYMED = TYMED_HGLOBAL
    End With

    If oDO.QueryGetData(tFMT) <> S_OK Then
    tFMT.cfFormat = CF_FileGroupDescriptor
    End If

    ' Get the data
    If oDO.GetData(tFMT, tSTGM) = S_OK Then

    Dim lPtr As Long
    Dim tFGD As FILEGROUPDESCRIPTORW

    ' Get a pointer to the data
    lPtr = GlobalLock(tSTGM.Data)

    ' Copy the structure
    MoveMemory tFGD, ByVal lPtr, LenB(tFGD)

    ReDim Files(0 To tFGD.cItems - 1)

    If tFMT.cfFormat = CF_FileGroupDescriptor Then

    ' Get the FILEDESCRIPTOR
    MoveMemory tFDA, ByVal lPtr + LenB(tFDA) * Index + 4, LenB(tFDA)

    ' Get the file name
    GetMessageFilename = StrConv(Left$(tFDA.cFileName,
    InStr(tFDA.cFileName, vbNullChar) - 1), vbUnicode)

    Else

    ' Get the FILEDESCRIPTOR
    MoveMemory tFDW, ByVal lPtr + LenB(tFDW) * Index + 4, LenB(tFDW)

    ' Get the file name
    GetMessageFilename = Left$(tFDW.cFileName, InStr(tFDW.cFileName,
    vbNullChar) - 1)

    End If

    ' Release the pointer
    GlobalUnlock tSTGM.Data

    ' Release the data
    ReleaseStgMedium tSTGM

    End If

    End Function

    Public Function GetMessageCount(ByVal Data As DataObject) As Long
    Dim oDO As olelib.IDataObject
    Dim tFMT As olelib.FORMATETC
    Dim tSTGM As olelib.STGMEDIUM
    Dim tFDA As FILEDESCRIPTORA
    Dim tFDW As FILEDESCRIPTORW
    Dim lIdx As Long

    ' Get the IDataObject interface
    ' from the Data object
    Set oDO = IDataObjectFromData(Data)

    ' Initialize the FORMATETC structure
    With tFMT
    .cfFormat = CF_FileGroupDescriptorW
    .dwAspect = DVASPECT_CONTENT
    .lindex = -1
    .TYMED = TYMED_HGLOBAL
    End With

    ' If the Unicode version is not available
    ' try to get the Ansi one
    If oDO.QueryGetData(tFMT) <> S_OK Then
    tFMT.cfFormat = CF_FileGroupDescriptor
    End If

    ' Get the data
    If oDO.GetData(tFMT, tSTGM) = S_OK Then

    Dim lPtr As Long
    Dim tFGD As FILEGROUPDESCRIPTORW

    ' Get a pointer to the data
    lPtr = GlobalLock(tSTGM.Data)

    ' Copy the structure
    MoveMemory tFGD, ByVal lPtr, LenB(tFGD)

    ' Release the pointer
    GlobalUnlock (tSTGM.Data)

    ' Return the number of messages
    GetMessageCount = tFGD.cItems

    ' Release the data
    ReleaseStgMedium tSTGM

    End If

    End Function

    '
    ' pvIDataObjectFromData
    '
    ' Returns the IDataObject interface from
    ' a VBRUN.DataObject object
    '
    Private Function IDataObjectFromData(ByVal Data As VBRUN.DataObject) As
    IDataObject
    Dim oTmpData As IDataObject

    ' Get an uncounted reference
    ' to the IDataObject interface
    MoveMemory oTmpData, ByVal ObjPtr(Data) + 16, 4

    ' Get a counted reference
    Set IDataObjectFromData = oTmpData

    ' Release the uncounted reference
    MoveMemory oTmpData, 0&, 4

    End Function

    '
    ' SaveMessage
    '
    ' Saves a dropped message to a file in the "Path" folder
    '
    Sub SaveMessage(ByVal Data As VBRUN.DataObject, ByVal Path As String,
    Optional ByVal Index As Long = 0)
    Dim oDO As IDataObject
    Dim tFMT As FORMATETC
    Dim tSTGM As STGMEDIUM
    Dim tIID As UUID
    Dim sFile As String

    ' Get the IDataObject interface
    ' from the Data object
    Set oDO = IDataObjectFromData(Data)

    ' Initialize the FORMATETC structure
    With tFMT
    .cfFormat = CF_FileContents
    .dwAspect = DVASPECT_CONTENT
    .lindex = Index
    .TYMED = TYMED_ISTREAM Or TYMED_ISTORAGE
    End With

    ' Get the data
    If oDO.GetData(tFMT, tSTGM) = S_OK Then

    ' Get the file name
    sFile = Path & "\" & GetMessageFilename(Data, Index)

    If tSTGM.TYMED = TYMED_ISTORAGE Then

    Dim oStg As IStorage
    Dim oFile As IStorage

    ' Get the storage reference
    Set oStg = ResolvePointer(tSTGM.Data)

    ' Create the file
    Set oFile = StgCreateDocfile(sFile, STGM_CREATE Or STGM_READWRITE
    Or STGM_SHARE_EXCLUSIVE)

    ' Copy from the message storage
    ' to the file storage
    oStg.CopyTo 0, tIID, vbNullString, oFile

    ' Commit the file changes
    oFile.Commit

    ' Release the file
    Set oFile = Nothing

    ' Release the storage
    Set oStg = Nothing

    Else

    Dim oStrm As IStream
    Dim tSTSTG As STATSTG
    Dim abData() As Byte
    Dim lFF As Long

    ' Get a reference to the stream
    Set oStrm = ResolvePointer(tSTGM.Data)

    ' Get the stream size
    oStrm.Stat tSTSTG, STATFLAG_NONAME
    tSTSTG.cbSize = tSTSTG.cbSize * 10000

    ' Allocate the array
    ReDim abData(0 To tSTSTG.cbSize)

    ' Read the data from the stream
    oStrm.Read abData(0), tSTSTG.cbSize

    ' Release the stream
    Set oStrm = Nothing

    ' Save the data to the file
    lFF = FreeFile
    Open sFile For Binary As lFF
    Put lFF, , abData
    Close lFF

    End If

    ' Release the data
    ReleaseStgMedium tSTGM

    End If

    End Sub

    Public Sub InitializeCFs()

    ' Register the clipboard formats
    CF_FileContents = &H8000 Or RegisterClipboardFormat(CFSTR_FILECONTENTS)
    And &H7FFF&
    CF_FileGroupDescriptor = &H8000 Or
    RegisterClipboardFormat(CFSTR_FILEDESCRIPTORA) And &H7FFF&
    CF_FileGroupDescriptorW = &H8000 Or
    RegisterClipboardFormat(CFSTR_FILEDESCRIPTORW) And &H7FFF&
    CF_OutlookExpressMessages = &H8000 Or
    RegisterClipboardFormat(CFSTR_OutlookExpressMessages) And &H7FFF&

    End Sub

    Private Function ResolvePointer(ByVal PtrObj As Long) As stdole.IUnknown
    Dim oUnk As stdole.IUnknown

    ' Get an uncounted reference
    ' to the IUnknown interface
    MoveMemory oUnk, PtrObj, 4&

    ' Get a counted reference
    Set ResolvePointer = oUnk

    ' Release the uncounted reference
    MoveMemory oUnk, 0&, 4&

    End Function

    --
    Eduardo A. Morcillo [MS MVP VB]
    http://www.domaindlx.com/e_morcillo



  3. #3
    Mats Edvardsson Guest

    Re: Outlook - Dragdrop whole mail to listbox

    Thanks for helping me again.
    But I have some trouble with this line of code:

    ' Get the data
    If oDO.GetData(tFMT, tSTGM) = S_OK Then

    It returns NOT ok, and jumps out of the SaveMessage sub.
    The call I use looks like this: Call modOutlook_2.SaveMessage(Data,
    mailDir)
    I drag two mails from mail explorer to a listbox and catch the event in
    dragdrop.
    ------------
    Another problem I have is how to separate Attachments and Complete mails
    when dragdrop. It has to be two separate calls depending on the type och
    object, I think.

    Best regards
    Mats


    "Eduardo A. Morcillo [MVP]" <emorcilloATmvps.org> skrev i meddelandet
    news:3e2afe72$1@tnews.web.devx.com...
    > > Now I have a problem in the same direction.
    > > How to dragdrop a WHOLE mail into a listbox. Save it as a msg file.
    > > All included like pictures and attachments. It has to work the same
    > > way as when you dragdrop a mail from Outlook to windows explorer.

    >
    >
    > Somebody said my name? Copy and paste the following code to a .bas
    > module, then use SaveMessage to save the message file (it works with

    Outlook
    > and OE messages).
    >
    > Option Explicit
    >
    > ' Clipboard formats
    > Public CF_FileContents As Integer
    > Public CF_FileGroupDescriptorW As Integer
    > Public CF_FileGroupDescriptor As Integer
    > Public CF_OutlookExpressMessages As Integer
    >
    >
    > Public Function GetMessageFilename(ByVal Data As DataObject, ByVal Index

    As
    > Long) As String
    > Dim oDO As olelib.IDataObject
    > Dim tFMT As olelib.FORMATETC
    > Dim tSTGM As olelib.STGMEDIUM
    > Dim tFDA As FILEDESCRIPTORA
    > Dim tFDW As FILEDESCRIPTORW
    >
    > ' Get the IDataObject interface
    > ' from the Data object
    > Set oDO = IDataObjectFromData(Data)
    >
    > ' Initialize the FORMATETC structure
    > With tFMT
    > .cfFormat = CF_FileGroupDescriptorW
    > .dwAspect = DVASPECT_CONTENT
    > .lindex = -1
    > .TYMED = TYMED_HGLOBAL
    > End With
    >
    > If oDO.QueryGetData(tFMT) <> S_OK Then
    > tFMT.cfFormat = CF_FileGroupDescriptor
    > End If
    >
    > ' Get the data
    > If oDO.GetData(tFMT, tSTGM) = S_OK Then
    >
    > Dim lPtr As Long
    > Dim tFGD As FILEGROUPDESCRIPTORW
    >
    > ' Get a pointer to the data
    > lPtr = GlobalLock(tSTGM.Data)
    >
    > ' Copy the structure
    > MoveMemory tFGD, ByVal lPtr, LenB(tFGD)
    >
    > ReDim Files(0 To tFGD.cItems - 1)
    >
    > If tFMT.cfFormat = CF_FileGroupDescriptor Then
    >
    > ' Get the FILEDESCRIPTOR
    > MoveMemory tFDA, ByVal lPtr + LenB(tFDA) * Index + 4, LenB(tFDA)
    >
    > ' Get the file name
    > GetMessageFilename = StrConv(Left$(tFDA.cFileName,
    > InStr(tFDA.cFileName, vbNullChar) - 1), vbUnicode)
    >
    > Else
    >
    > ' Get the FILEDESCRIPTOR
    > MoveMemory tFDW, ByVal lPtr + LenB(tFDW) * Index + 4, LenB(tFDW)
    >
    > ' Get the file name
    > GetMessageFilename = Left$(tFDW.cFileName, InStr(tFDW.cFileName,
    > vbNullChar) - 1)
    >
    > End If
    >
    > ' Release the pointer
    > GlobalUnlock tSTGM.Data
    >
    > ' Release the data
    > ReleaseStgMedium tSTGM
    >
    > End If
    >
    > End Function
    >
    > Public Function GetMessageCount(ByVal Data As DataObject) As Long
    > Dim oDO As olelib.IDataObject
    > Dim tFMT As olelib.FORMATETC
    > Dim tSTGM As olelib.STGMEDIUM
    > Dim tFDA As FILEDESCRIPTORA
    > Dim tFDW As FILEDESCRIPTORW
    > Dim lIdx As Long
    >
    > ' Get the IDataObject interface
    > ' from the Data object
    > Set oDO = IDataObjectFromData(Data)
    >
    > ' Initialize the FORMATETC structure
    > With tFMT
    > .cfFormat = CF_FileGroupDescriptorW
    > .dwAspect = DVASPECT_CONTENT
    > .lindex = -1
    > .TYMED = TYMED_HGLOBAL
    > End With
    >
    > ' If the Unicode version is not available
    > ' try to get the Ansi one
    > If oDO.QueryGetData(tFMT) <> S_OK Then
    > tFMT.cfFormat = CF_FileGroupDescriptor
    > End If
    >
    > ' Get the data
    > If oDO.GetData(tFMT, tSTGM) = S_OK Then
    >
    > Dim lPtr As Long
    > Dim tFGD As FILEGROUPDESCRIPTORW
    >
    > ' Get a pointer to the data
    > lPtr = GlobalLock(tSTGM.Data)
    >
    > ' Copy the structure
    > MoveMemory tFGD, ByVal lPtr, LenB(tFGD)
    >
    > ' Release the pointer
    > GlobalUnlock (tSTGM.Data)
    >
    > ' Return the number of messages
    > GetMessageCount = tFGD.cItems
    >
    > ' Release the data
    > ReleaseStgMedium tSTGM
    >
    > End If
    >
    > End Function
    >
    > '
    > ' pvIDataObjectFromData
    > '
    > ' Returns the IDataObject interface from
    > ' a VBRUN.DataObject object
    > '
    > Private Function IDataObjectFromData(ByVal Data As VBRUN.DataObject) As
    > IDataObject
    > Dim oTmpData As IDataObject
    >
    > ' Get an uncounted reference
    > ' to the IDataObject interface
    > MoveMemory oTmpData, ByVal ObjPtr(Data) + 16, 4
    >
    > ' Get a counted reference
    > Set IDataObjectFromData = oTmpData
    >
    > ' Release the uncounted reference
    > MoveMemory oTmpData, 0&, 4
    >
    > End Function
    >
    > '
    > ' SaveMessage
    > '
    > ' Saves a dropped message to a file in the "Path" folder
    > '
    > Sub SaveMessage(ByVal Data As VBRUN.DataObject, ByVal Path As String,
    > Optional ByVal Index As Long = 0)
    > Dim oDO As IDataObject
    > Dim tFMT As FORMATETC
    > Dim tSTGM As STGMEDIUM
    > Dim tIID As UUID
    > Dim sFile As String
    >
    > ' Get the IDataObject interface
    > ' from the Data object
    > Set oDO = IDataObjectFromData(Data)
    >
    > ' Initialize the FORMATETC structure
    > With tFMT
    > .cfFormat = CF_FileContents
    > .dwAspect = DVASPECT_CONTENT
    > .lindex = Index
    > .TYMED = TYMED_ISTREAM Or TYMED_ISTORAGE
    > End With
    >
    > ' Get the data
    > If oDO.GetData(tFMT, tSTGM) = S_OK Then
    >
    > ' Get the file name
    > sFile = Path & "\" & GetMessageFilename(Data, Index)
    >
    > If tSTGM.TYMED = TYMED_ISTORAGE Then
    >
    > Dim oStg As IStorage
    > Dim oFile As IStorage
    >
    > ' Get the storage reference
    > Set oStg = ResolvePointer(tSTGM.Data)
    >
    > ' Create the file
    > Set oFile = StgCreateDocfile(sFile, STGM_CREATE Or STGM_READWRITE
    > Or STGM_SHARE_EXCLUSIVE)
    >
    > ' Copy from the message storage
    > ' to the file storage
    > oStg.CopyTo 0, tIID, vbNullString, oFile
    >
    > ' Commit the file changes
    > oFile.Commit
    >
    > ' Release the file
    > Set oFile = Nothing
    >
    > ' Release the storage
    > Set oStg = Nothing
    >
    > Else
    >
    > Dim oStrm As IStream
    > Dim tSTSTG As STATSTG
    > Dim abData() As Byte
    > Dim lFF As Long
    >
    > ' Get a reference to the stream
    > Set oStrm = ResolvePointer(tSTGM.Data)
    >
    > ' Get the stream size
    > oStrm.Stat tSTSTG, STATFLAG_NONAME
    > tSTSTG.cbSize = tSTSTG.cbSize * 10000
    >
    > ' Allocate the array
    > ReDim abData(0 To tSTSTG.cbSize)
    >
    > ' Read the data from the stream
    > oStrm.Read abData(0), tSTSTG.cbSize
    >
    > ' Release the stream
    > Set oStrm = Nothing
    >
    > ' Save the data to the file
    > lFF = FreeFile
    > Open sFile For Binary As lFF
    > Put lFF, , abData
    > Close lFF
    >
    > End If
    >
    > ' Release the data
    > ReleaseStgMedium tSTGM
    >
    > End If
    >
    > End Sub
    >
    > Public Sub InitializeCFs()
    >
    > ' Register the clipboard formats
    > CF_FileContents = &H8000 Or RegisterClipboardFormat(CFSTR_FILECONTENTS)
    > And &H7FFF&
    > CF_FileGroupDescriptor = &H8000 Or
    > RegisterClipboardFormat(CFSTR_FILEDESCRIPTORA) And &H7FFF&
    > CF_FileGroupDescriptorW = &H8000 Or
    > RegisterClipboardFormat(CFSTR_FILEDESCRIPTORW) And &H7FFF&
    > CF_OutlookExpressMessages = &H8000 Or
    > RegisterClipboardFormat(CFSTR_OutlookExpressMessages) And &H7FFF&
    >
    > End Sub
    >
    > Private Function ResolvePointer(ByVal PtrObj As Long) As stdole.IUnknown
    > Dim oUnk As stdole.IUnknown
    >
    > ' Get an uncounted reference
    > ' to the IUnknown interface
    > MoveMemory oUnk, PtrObj, 4&
    >
    > ' Get a counted reference
    > Set ResolvePointer = oUnk
    >
    > ' Release the uncounted reference
    > MoveMemory oUnk, 0&, 4&
    >
    > End Function
    >
    > --
    > Eduardo A. Morcillo [MS MVP VB]
    > http://www.domaindlx.com/e_morcillo
    >
    >




Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  
HTML5 Development Center
 
 
FAQ
Latest Articles
Java
.NET
XML
Database
Enterprise
Questions? Contact us.
C++
Web Development
Wireless
Latest Tips
Open Source


   Development Centers

   -- Android Development Center
   -- Cloud Development Project Center
   -- HTML5 Development Center
   -- Windows Mobile Development Center