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.
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.
MVP Shon Oskar – VBATools.pl
Jeśli masz pytania dot. tego artykułu zapraszam na Forum
Skonfiguruj swój pakiet dodatków do Excela, Worda, PowerPointa i Outlooka
© Wszelkie prawa zastrzeżone. Żadna część ani całość tego artykułu nie może być powielana ani publikowana bez zgody autora.