none
Calling an outlook macro from excel. RRS feed

  • General discussion

  • Hello Team,

    I ve this below code that works well. But my need is to call this macro from a excel button click 

    Please help me on this. Urgent for me.

    Sub Unzip()
        '''Variables for the main functionality
        Dim NS As NameSpace
        Dim InboX As MAPIFolder
        Dim SubFolder As MAPIFolder
        Dim MsG As Outlook.MailItem
        Dim AtcHmt As Attachment
        Dim ReceivedHour As Date
        Dim oFrom As Date
        Dim oEnd As Date
        '''Variables for unzipping
        Dim FSO As Object
        Dim ShellApp As Object
        Set FSO = CreateObject("Scripting.FileSystemObject")
        Set ShellApp = CreateObject("Shell.Application")
        Dim FileNameFolder As Variant
        Dim FileName As Variant

        '''Define the Outlook folder you want to scan
        Set NS = GetNamespace("MAPI")
        Set InboX = NS.GetDefaultFolder(olFolderInbox)
        Set SubFolder = InboX.Folders("TEST")

        '''Define the folder where you want to save attachments
        FileNameFolder = Environ$("USERPROFILE") & "\Documents\test\"

        '''Define the hours in between which you want to apply the extraction
        oFrom = CDate(InputBox("Please give Start time" & vbCrLf & _
                                "Example: 9AM", ("Shadowserver report"), "9AM"))
        oEnd = CDate(InputBox("Please give End time" & vbCrLf & _
                                "Example: 6PM", ("Shadowserver report"), "6PM"))

        For Each MsG In SubFolder.Items
            ReceivedHour = MsG.ReceivedTime
            If oFrom <= TimeValue(ReceivedHour) And _
                TimeValue(ReceivedHour) <= oEnd Then
                For Each AtcHmt In MsG.Attachments
                    FileName = AtcHmt.FileName
                    If LCase(Right(FileName, 3)) <> "zip" Then
                    Else
                        FileName = FileNameFolder & FileName
                        AtcHmt.SaveAsFile FileName

                        ShellApp.NameSpace(FileNameFolder).CopyHere _
                                ShellApp.NameSpace(FileName).Items

                        Kill (FileName)
                        On Error Resume Next
                        FSO.deletefolder Environ$("Temp") & "\Temporary Directory*", True
                    End If
                Next AtcHmt
            End If
        Next MsG
    End Sub

    Wednesday, May 17, 2017 12:47 PM

All replies

  • Try this version:

    Sub Unzip()
        '''Variables for the main functionality
        Dim app As Object
        Dim NS As Object
        Dim InboX As Object
        Dim SubFolder As Object
        Dim MsG As Object
        Dim AtcHmt As Object
        Dim ReceivedHour As Date
        Dim oFrom As Date
        Dim oEnd As Date
        Dim f As Boolean
        '''Variables for unzipping
        Dim FSO As Object
        Dim ShellApp As Object
        Set FSO = CreateObject("Scripting.FileSystemObject")
        Set ShellApp = CreateObject("Shell.Application")
        Dim FileNameFolder As Variant
        Dim FileName As Variant

        '''Define the Outlook folder you want to scan
        On Error Resume Next
        Set app = GetObject(Class:="Outlook.Application")
        If app Is Nothing Then
            Set app = CreateObject(Class:="Outlook.Application")
            f = True
        End If
        On Error GoTo ErrHandler
        Set NS = app.GetNamespace("MAPI")
        Set InboX = NS.GetDefaultFolder(6) ' olFolderInbox
        Set SubFolder = InboX.Folders("TEST")

        '''Define the folder where you want to save attachments
        FileNameFolder = Environ$("USERPROFILE") & "\Documents\test\"

        '''Define the hours in between which you want to apply the extraction
        oFrom = CDate(InputBox("Please give Start time" & vbCrLf & _
                                "Example: 9AM", ("Shadowserver report"), "9AM"))
        oEnd = CDate(InputBox("Please give End time" & vbCrLf & _
                                "Example: 6PM", ("Shadowserver report"), "6PM"))

        For Each MsG In SubFolder.Items
            ReceivedHour = MsG.ReceivedTime
            If oFrom <= TimeValue(ReceivedHour) And _
                TimeValue(ReceivedHour) <= oEnd Then
                For Each AtcHmt In MsG.Attachments
                    FileName = AtcHmt.FileName
                    If LCase(Right(FileName, 3)) = "zip" Then
                        FileName = FileNameFolder & FileName
                        AtcHmt.SaveAsFile FileName

                        ShellApp.Namespace(FileNameFolder).CopyHere _
                                ShellApp.Namespace(FileName).Items

                        Kill FileName
                        On Error Resume Next
                        FSO.Deletefolder Environ$("Temp") & "\Temporary Directory*", True
                    End If
                Next AtcHmt
            End If
        Next MsG

    ExitHandler:
        On Error Resume Next
        If f Then app.Quit
        Exit Sub

    ErrHandler:
        MsgBox Err.Description, vbExclamation
        Resume ExitHandler
    End Sub


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Wednesday, May 17, 2017 2:57 PM
  • Hello Hanse, This worked like a pro Thanks! dono how to mark this as a answer 
    Monday, May 22, 2017 10:10 AM