Merging two macros

Hello everyone,

I need help with merging two macros in one another.

The first macro extracts XLS* attachments from selected e-mails in outlook and saves them in a specified directory.
The second macro writes down mail subject, sender and date sent inside a file.

What I need is a macro that extracts XLS* attachments from selected e-mails in outlook, writes down mail subject, sender and date sent inside the attachment and save it in a specified directory.

Here is the first code:

Public Sub SaveAttachments()

Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim mySplit As String


strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
On Error Resume Next
Set objOL = CreateObject("Outlook.Application")
Set objSelection = objOL.ActiveExplorer.Selection
strFolderpath = strFolderpath & "\Attachments\"
For Each objMsg In objSelection
    Set objAttachments = objMsg.Attachments
    lngCount = objAttachments.Count
    If lngCount > 0 Then
        For i = lngCount To 1 Step -1
            strFile = objAttachments.Item(i).FileName
            mySplit = Right(strFile, 4)
                Select Case mySplit
                    Case ".xls", "xlsm", "xlsx", "xlsb"
                        strFile = strFolderpath & strFile
                        objAttachments.Item(i).SaveAsFile strFile
                    Case Else
                End Select
        Next i
    End If
Next

End Sub

Here is the second code:

Sub ExportToExcel()
On Error GoTo ErrHandler
Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strSheet As String
Dim strPath As String
Dim intRowCounter As Integer
Dim intColumnCounter As Integer
Dim msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
Dim itm As Object

strSheet = "OutlookItems.xls"
strPath = "C:\Documents and Settings\jbukovsk\My Documents\Attachments\"
strSheet = strPath & strSheet
Debug.Print strSheet


Set nms = Application.GetNamespace("MAPI")
Set fld = nms.PickFolder

If fld Is Nothing Then
    MsgBox "There are no mail messages to export", vbOKOnly, "Error"
    Exit Sub
    ElseIf fld.DefaultItemType <> olMailItem Then
        MsgBox "There are no mail messages to export", vbOKOnly, "Error"
        Exit Sub
        ElseIf fld.Items.Count = 0 Then
            MsgBox "There are no mail messages to export", vbOKOnly, "Error"
            Exit Sub
End If

Set appExcel = CreateObject("Excel.Application")
appExcel.Workbooks.Open (strSheet)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.ActiveSheet

wks.Activate
appExcel.Application.Visible = True


For Each itm In fld.Items
    Set msg = itm
    intColumnCounter = 4
    intRowCounter = 1
    Set msg = itm
    Set rng = wks.Cells(intRowCounter, intColumnCounter)
    rng.Value = GetDate(msg.SentOn)
    intColumnCounter = intColumnCounter + 1
    Set rng = wks.Cells(intRowCounter, intColumnCounter)
    rng.Value = msg.SenderName
    intColumnCounter = intColumnCounter + 1
    Set rng = wks.Cells(intRowCounter, intColumnCounter)
    rng.Value = msg.Subject
Next itm

Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
Exit Sub

ErrHandler:
If Err.Number = 1004 Then
    MsgBox strSheet & " doesn't exist", vbOKOnly, "Error"
        Else
        MsgBox Err.Number & "; Description: ", vbOKOnly, "Error"
End If

Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
End Sub

Function GetDate(dt As Date) As String
    GetDate = Year(dt) & "-" & Month(dt) & "-" & Day(dt)
End Function

I tried my best and failed. I'm grateful for any help.

Thanks in advance!

Originally Posted by patel45

did you try adding to the first macro (before end sub)

call ExportToExcel

That would probably work in some cases, but ExportToExcel saves the info in a specific file outlookitems.xls

I need the macro changed a bit so instead it opens the extracted xls attachment, make the modifications there, save and continue the cycle.

Bump.

this is not too time consuming, just a little missing piece of code.

Again, thanks in advance for help.