MSG files

[exandbeyond]

Operating System:
Microsoft XP
Applications:
Excel 2007
Outlook 2007


I am trying to write a macro that would extract the data from selected msg file(s) within a folder and paste the data in to the next available row. I already have an existing workbook with data on it.

It should look like this when done:



[TABLE="class: grid, width: 500"]
<TBODY>[TR]
[TD]A1
[/TD]
[TD]B2
[/TD]
[TD]C2
[/TD]
[TD]D3
[/TD]
[TD]E3
[/TD]
[TD]F3
[/TD]
[/TR]
[TR]
[TD]Date Received
[/TD]
[TD]From
[/TD]
[TD]Department
[/TD]
[TD]Subject
[/TD]
[TD]Attachment #1
[/TD]
[TD]Attachment #2
[/TD]
[/TR]
</TBODY>[/TABLE]


You can get the department by clicking on the person's name causing a new message box to open. Those who work or have worked in organizations that have an address book directory should know what I am talking about because I am not sure what its called.

I don't know how many attachements the email will have so I need it to keep adding columns for all the atttachments.


This is what I have so far:

 Dim olA As Object
    Dim aPaths() As String 'paths to *.msg files
    Dim vSubjects() As Variant 'list of subjects
    Dim vSelItems As Variant 'to get selected items
    Dim i As Long
    Dim rDest As Range 'where Subject lines will be written

Set olA = CreateObject("Outlook.Application")
Set rDest = Range("B1")
With Application.FileDialog(msoFileDialogFilePicker)
    .AllowMultiSelect = True
    .Filters.Add "Messages", "*.msg", 1
    .FilterIndex = 1
    If .Show = -1 Then
    ReDim aPaths(0 To .SelectedItems.Count - 1)
        For i = 0 To .SelectedItems.Count - 1
            aPaths(i) = .SelectedItems(i + 1)
        Next i
    End If
End With
Application.ScreenUpdating = False

rDest.EntireColumn.Clear
With rDest(1, 1)
 .Value = "Subjects"
    .Font.Bold = True
End With
ReDim vSubjects(1 To UBound(aPaths) + 1, 1 To 1)
For i = 0 To UBound(aPaths)
    vSubjects(i + 1, 1) = olA.CreateItemFromTemplate(aPaths(i)).Subject
Next i
Set rDest = rDest.Offset(rowoffset:=1).Resize(rowsize:=UBound(vSubjects))
rDest = vSubjects
rDest.EntireColumn.AutoFit
Application.ScreenUpdating = True
Set olA = Nothing
End Sub

Hope I can I can get some help for this. Thanks in advance

Cliffs: I have a ton of msg files saved and I need to put the data from those files into a spreadsheet.

 

[exandbeyond]

I made a mistake on how the data should look like. It should look like this.

[TABLE="class: cms_table_grid"]
<TBODY>[TR]
[TD]A1[/TD]
[TD]B1[/TD]
[TD]C1[/TD]
[TD]D1[/TD]
[TD]E1[/TD]
[TD]F1[/TD]
[/TR]
[TR]
[TD]Date Received[/TD]
[TD]From[/TD]
[TD]Department[/TD]
[TD]Subject[/TD]
[TD]Attachment #1[/TD]
[TD]Attachment #2 [/TD]
[/TR]
</TBODY>[/TABLE]