Rename .XML to with .MSG subject header

[davulf]

Hi Dear Excel Friends,

It has been a while since I've posted, but I've moved back into a role that touches on Excel/Access/VBA on a nearly daily basis. As such, I'm in need of something of a refresher on VBA - so please bear with me during this process.

Right now I'm looking for a macro that will help me to do the following:

1. Loop through all files in a folder with extension .msg (saved Office e-mail)
2. Save attachment from .msg as <filename of .msg>.xml (all are in XML format)

I can do the next loop that takes all of the now .xml files properly named and collates them into one large sheet for analysis. I assume a .vbs will do the trick - but not sure how to go about it. Perhaps something like:

'Description: Combines all files in a folder to a master file.
Sub MergeFiles()
    Dim path As String, ThisWB As String, lngFilecounter As Long
    Dim wbDest As Workbook, shtDest As Worksheet, ws As Worksheet
    Dim Filename As String, Wkb As Workbook
    Dim CopyRng As Range, Dest As Range
    Dim RowofCopySheet As Integer

    RowofCopySheet = 2 ' Row to start on in the sheets you are copying from

    ThisWB = ActiveWorkbook.Name
    
    path = "C:\xxx"

    Application.EnableEvents = False
    Application.ScreenUpdating = False

    Set shtDest = ActiveWorkbook.Sheets(1)
    Filename = Dir(path & "\*", vbNormal)
    If Len(Filename) = 0 Then Exit Sub
    Do Until Filename = vbNullString
        If Not Filename = ThisWB Then
            Set Wkb = Workbooks.Open(Filename:=path & "\" & Filename, UpdateLinks:=0)

            Wkb.Close True
<THEN WHAT?>
        End If
        
        Filename = Dir()
    Loop

    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
  
End Sub

Any help appreciated.

Thanks!

D

 

[davulf]

Perhaps this is another place to mix and match, although this works from Outlook directly, not from .msg in a folder:

' The following Outlook VBScript saves all attachments of all emails in a given folder
' to the c:\data2\ folder.
' Visit my SPSS web site: http://pages.infinit.net/rlevesqu/index.htm

Public Sub SaveAttachments()
    ' Posted to the spss newsgroup by Raynald Levesque 2003/01/07
    Dim mynamespace As NameSpace
    Dim email As MailItem
    Dim atAttachs As Attachments
    Dim atAttach As Attachment
    Dim myfolder As MAPIFolder
    Dim myitem As MailItem
    Dim strPath As String
    Dim intCnt As Integer
    Dim intEmails As Integer

    strPath = "c:\data2\"
    Set mynamespace = Application.GetNamespace("MAPI")

    Set myfolder = mynamespace.PickFolder
    'Set myfolder = mynamespace.GetDefaultFolder(olFolderInbox)
    myfolder.Display

    ' Go through each email in the folder
    For intEmails = 1 To myfolder.Items.Count
        Set myitem = myfolder.Items(intEmails)
        'myitem.Display
        Debug.Print "# of attachemnts= " & myitem.Attachments.Count
        Set atAttachs = myitem.Attachments
        For intCnt = 1 To myitem.Attachments.Count
            'Go through each attachments
            Set atAttach = atAttachs(intCnt)
            atAttach.SaveAsFile (strPath & atAttach.FileName)
        Next
    Next intEmails

    End Sub

Thanks!