W większości działów, a w szczególności dz. księgowości, wysyłane są faktury w formie elektronicznej jako załączniki do wiadomości email. Rozwiązuje to dwa potencjalne problemy jednocześnie:
 
1. W wiadomości może być nieskończona ilość załączników PDF i aby je wydrukować należy każdy z nich otwierać z osobna a następnie wydrukować.
2. AcrobatReader, który jest producentem formatu źle współpracuje z niektórymi drukarkami jak i programami, które generują plik, co jest efektem wydruku „krzaków”.
 
Polecam w tym celu instalacje dodatkowego, darmowego oprogramowania Foxit reader, który dzięki możliwości sparametryzowania z linii komend poprawnie wydrukuje plik bez jego uruchamiania. Co więcej, proces ten nie jest okraszony reklamami czy dodatkowymi komunikatami podczas pracy. Oczywiście może to być inny program, posiadające podobne właściwości.
 
Aby przygotować mechanizm należy zbudować interfejs złożony z dwóch textboxów, checkboxa, dwóch przycisków i jednego labela, jako opis pola dla domyślnej drukarki.
 
Widok interfejsu
Rys 1. Widok interfejsu dodatku.
 
Dzięki budowie takiego interfejsu można zaznaczać wiele wiadomości z załącznikami PDF w dowolnym folderze poczty i uruchomić opcje wydruku. Opcją dodatkową jest ograniczenie wydruku do załączników zawierających w nazwie zdefiniowane wcześniej słowo, co pozwala wydrukować tylko konkretne załączniki z całej puli zaznaczonych wiadomości.
 
Kod formy:
 
Option Explicit
Const APPNAME as String = "VBATools.pl"

Private Declare Function GetProfileStringA Lib "kernel32" _
    (ByVal lpAppName As String, _
    ByVal lpKeyName As String, _
    ByVal lpDefault As String, _
    ByVal lpReturnedString As _
    String, ByVal nSize As Long) As Long
    
Dim oMail As MailItem, item As Object
Dim oAtmt As Attachment, FileName$, x&
Dim aplikacja$

Private Sub PrintPDFAttachments4SelectionEmail(Optional AttName$)
    If FileExists("C:\Temp") = False Then MkDir "C:\Temp"
    On Error GoTo blad

    For Each item In Application.ActiveExplorer.Selection
        If item.Class = 43 Then
            Set oMail = item
            If oMail.Attachments.Count > 0 Then
                For Each oAtmt In oMail.Attachments
                    If Len(AttName) = 0 Then
ones:
                    FileName = "C:\Temp\" & oAtmt.FileName
                    If FileExists(FileName) = True Then Kill FileName
                        If Right$(UCase(oAtmt.FileName), 3) = "PDF" Then
                            oAtmt.SaveAsFile FileName
                            'Shell """c:\Program Files (x86)\Adobe\Reader 9.0\Reader\acrord32.exe"" /h /p """ + FileName + """", vbHide
                            Shell "" & aplikacja & " -p """ + FileName + """", vbHide
                        End If
                    Else
                        If InStr(1, UCase(oAtmt.FileName), UCase(AttName)) > 0 Then GoTo ones
                    End If
                Next oAtmt
            End If
        End If
    Next item
Exit Sub
blad:
MsgBox Err.Number & vbCr & Err.Description, vbExclamation, APPNAME
End Sub

Private Sub Drukarka_zmien_Click()
    Dim Arg As String
    Dim TaskID
  Arg = "rundll32.exe shell32.dll,SHHelpShortcuts_RunDLL PrintersFolder"
  On Error Resume Next
    TaskID = Shell(Arg)
Unload Me
    If Err <> 0 Then
        MsgBox ("Nie można uruchomić aplikacji.")
    End If
End Sub

Sub DefaultPrinterInfo()
    Dim strLPT As String * 255
    Dim Result As String
    Dim Comma1 As Integer
    Dim Printer As String
    
    Call GetProfileStringA("Windows", "Device", "", strLPT, 254)
    Result = Trim(strLPT)
    Comma1 = InStr(1, Result, ",", 1)
    Printer = Left(Result, Comma1 - 1)
    Jaka_drukarka.text = Printer
End Sub

Private Sub Drukuj_Click()
aplikacja = fGetSpecialFolder(38) & "Foxit Software\Foxit Reader\Foxit Reader.exe"
If FileExists(aplikacja) = False Then
MsgBox "Brak zainstalownia aplikacji ''Foxit Reader'' do której przypisana jest funkcjonalność." & vbCr & _
       "Zainstaluj aplikację z wymiany lub z programów dostępnych w domenie (przez Panel Sterowania).", _
       vbExclamation, APPNAME
Exit Sub
Else
    If Me.Jesli_zawiera.value = True And Len(Trim(Slowo.text)) > 0 Then
        Call PrintPDFAttachments4SelectionEmail(Trim(Slowo.text))
    Else
        Call PrintPDFAttachments4SelectionEmail
    End If
End If
End Sub
Private Sub Jesli_zawiera_Click()
If Jesli_zawiera = True Then
    SaveSetting APPNAME, "Settings", "Jesli_zawiera", 1
    Slowo.BackColor = &H80000005
Else
    SaveSetting APPNAME, "Settings", "Jesli_zawiera", 0
    Slowo.BackColor = &H8000000F
End If
End Sub

Private Sub Slowo_Change()
    SaveSetting APPNAME, "Settings", "Slowo", Slowo.text
End Sub

Private Function FileExists(FilePath As String) As Boolean
On Error GoTo blad
    FileExists = Len(Dir(FilePath, vbDirectory Or vbHidden Or vbSystem)) > 0
Exit Function
blad:
FileExists = False
End Function

Private Sub UserForm_Activate()
Call DefaultPrinterInfo
End Sub
 
Kod modułu:
 
Option Explicit

Declare Function SHGetSpecialFolderLocation Lib "Shell32.dll" _
  (ByVal hwndOwner As Long, ByVal nFolder As Long, _
  pidl As ITEMIDLIST) As Long

Declare Function SHGetPathFromIDList Lib "Shell32.dll" _
  Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _
  ByVal pszPath As String) As Long

Public Type SH_ITEMID
    cb As Long
    abID As Byte
End Type

Public Type ITEMIDLIST
    mkid As SH_ITEMID
End Type

Public Const MAX_PATH As Integer = 260

Public Function fGetSpecialFolder(CSIDL As Long) As String
    Dim sPath As String
    Dim IDL As ITEMIDLIST
    fGetSpecialFolder = ""
    If SHGetSpecialFolderLocation(0, CSIDL, IDL) = 0 Then
        sPath = Space$(MAX_PATH)
        If SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal sPath) Then
            fGetSpecialFolder = Left$(sPath, InStr(sPath, vbNullChar) - 1) & "\"
        End If
    End If
End Function 
 
Interesującą w tej lekcji pozycją jest nie tylko możliwość wywołania komendy z parametrem, ale również zastosowania folderów specjalnych, ponieważ programy w dostępnych systemach Windows posiadają możliwość instalacji 32 oraz 64 bity. Folder specjalny definiuje instalacje oprogramowania gdzie dla x64 programy 32 bitowe są umieszczone w katalogu „Program Files (x86)” na co chciałem zwrócić dodatkową uwagę.
 
Program w postaci modułów VBA można pobrać z tej lokalizacji.
 
Artykuł dotyczy MS Outlook 2000/10.
Shon Oskar – www.VBATools.pl

© Wszelkie prawa zastrzeżone. Żadna część ani całość tego artykułu nie może być powielana ani publikowana bez zgody autora.
Oryginalny tekst jest zapisany pod tym adresem