Clever Geek Handbook

Run multiple macros with one macro, run in Compile Error

I tried to write two macros to automatically print attachments when new letters are received and only print the first page of the letter. the code looks like this:

Private Declare Function ShellExecute Lib "shell32.dll" Alias _
  "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
  ByVal lpFile As String, ByVal lpParameters As String, _
  ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()
  Dim Ns As Outlook.NameSpace
  Dim Folder As Outlook.MAPIFolder

  Set Ns = Application.GetNamespace("MAPI")
  Set Folder = Ns.GetDefaultFolder(olFolderInbox)
  Set Items = Folder.Items
End Sub

Private Sub Items_ItemAdd(ByVal Item As Object)
  If TypeOf Item Is Outlook.MailItem Then
    Printattachments Item
  End If
End Sub

Private Sub Printattachments(oMail As Outlook.MailItem)
  On Error Resume Next
  Dim colAtts As Outlook.Attachments
  Dim oAtt As Outlook.Attachment
  Dim sFile As String
  Dim sDirectory As String
  Dim sFileType As String

  sDirectory = "D:\Attachments\"

  Set colAtts = oMail.Attachments

  If colAtts.Count Then
    For Each oAtt In colAtts

' This code looks at the last 4 characters in a filename
      sFileType = LCase$(Right$(oAtt.FileName, 4))

      Select Case sFileType

' Add additional file types below
      Case "xlsx", "docx", ".pdf", ".doc", ".xls"


        sFile = sDirectory & oAtt.FileName
        oAtt.SaveAsFile sFile
        ShellExecute 0, "print", sFile, vbNullString, vbNullString, 0
      End Select
    Next
  End If
End Sub

Sub PrintOnePage()
    SendKeys "%F", False
    SendKeys "P"
    SendKeys "{TAB 2}", True
    SendKeys "{DOWN}", True
    SendKeys "1"
    SendKeys "{ENTER}"
End Sub

Sub RunAll()
    Call Printattachments
    Call PrintOnePage
End Sub

Then I clicked the General and Run All buttons and ran into a compilation error: the argument is optional.

Any input will be very much appreciated!

+3


source to share


2 answers


What you need to do is change your PrintOnePage

on

Public Sub PrintOnePage(ByVal Item As Object)
    SendKeys "%FPR"
    SendKeys "%S"
    SendKeys "1"
    SendKeys "{ENTER}"
End Sub

And then on ItemAdd Events just add

Private Sub Items_ItemAdd(ByVal Item As Object)
  If TypeOf Item Is Outlook.MailItem Then
    Printattachments Item
    PrintOnePage Item '<-------- add
  End If
End Sub

Remember now, as soon as you receive the email, it will print one page of the email body.



To print only body elements with attachments, move PrintOnePage Item

to

Example

Private Sub Printattachments(ByVal Item As Outlook.MailItem)
    Dim colAtts As Outlook.Attachments
    Dim oAtt As Outlook.Attachment
    Dim sFile As String
    Dim sDirectory As String
    Dim sFileType As String

    sDirectory = "D:\Attachments\"

    Set colAtts = Item.Attachments

    If colAtts.Count Then
        For Each oAtt In colAtts

            ' This code looks at the last 4 characters in a filename
            sFileType = LCase$(Right$(oAtt.FileName, 4))

            Select Case sFileType
                ' Add additional file types below
                Case "xlsx", "docx", ".pdf", ".doc", ".xls"

                sFile = sDirectory & oAtt.FileName
                oAtt.SaveAsFile sFile
                ShellExecute 0, "print", sFile, vbNullString, vbNullString, 0
            End Select
        Next
    End If

    PrintOnePage Item '<-------- add

End Sub


Items.ItemAdd Event Occurs when one or more items are added to the specified collection. This event is not triggered when a large number of items are added to a folder at once.



+1


source


Related to this post, I would add your Subs to this code (it goes in place Sub RunAll

):

Private WithEvents Items As Outlook.Items 
Private Sub Application_Startup() 
  Dim olApp As Outlook.Application 
  Dim objNS As Outlook.NameSpace 
  Set olApp = Outlook.Application 
  Set objNS = olApp.GetNamespace("MAPI") 
  ' default local Inbox
  Set Items = objNS.GetDefaultFolder(olFolderInbox).Items 
End Sub
Private Sub Items_ItemAdd(ByVal item As Object) 

  On Error Goto ErrorHandler 
  Dim Msg As Outlook.MailItem 
  If TypeName(item) = "MailItem" Then
    Set Msg = item 
    ' ******************
    Call Printattachments(Msg)
    Call PrintOnePage
    ' ******************
  End If
ProgramExit: 
  Exit Sub
ErrorHandler: 
  MsgBox Err.Number & " - " & Err.Description 
  Resume ProgramExit 
End Sub

IMPORTANT



Paste all your code into a module ThisOutlookSession

.

This will run the macro after receiving any email (you need to restart Outlook).

0


source






More articles:


All Articles