Outlook jest programem z pakietu Office, który chyba najczęściej współpracuje z Excelem w kontekście VBA. To właśnie dzięki niemu możemy zautomatyzować wysyłkę raportów. Taka dystrybucja plików mailem może być w bardzo prosty sposób spersonalizowana.
Dystrybucja raportów
W swojej pracy często spotykam się z potrzebą napisania makra, które będzie wysyłać raporty do wybranych osób z określoną częstotliwością.
Jest to przeważnie końcowy etap prac nad projektem. Raportowanie już działa – pliki są zapisywane do konkretnego katalogu. Zwykle są to skoroszyty Excela, dokumenty PDF czy nawet pliki graficzne ze screenami dashboardów.
Ze względu jednak na pewną wygodę i bezpieczeństwo dostępu do danych, konieczne jest napisanie dodatkowego kodu. Jego rolą jest właśnie wysyłka plików mailem.
Tabela krzyżowa
W takich sytuacjach znakomicie sprawdza się prosta tabelka (macierz). Zawiera ona kluczowe dane w pierwszej kolumnie i w pierwszym wierszu. Na przecięciu tych dwóch zmiennych znajduje się znak (np. X), który informuje nas, czy dana kombinacja ma zostać wzięta pod uwagę.
W naszym przypadku, w pierwszym wierszu tabeli zawarte są adresy e-mail, zaś w pierwszej kolumnie – ścieżki do plików.
Jak widzimy, nie są to raporty Excela lecz pliki graficzne, ale jest to bez znaczenia – najważniejszy jest prawidłowy adres pliku.
Kod VBA do wysyłki plików
Kod, który realizuje to zadanie wklejam poniżej.
Makro główne
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 |
Private Const msMODUL As String = "MMailing" Option Explicit Public Sub WyslijMejleDoZainteresowanych() Const sPROC As String = "WyslijMejleDoZainteresowanych" Dim avObszarDanych As Variant 'Cały zakres / tabela danych Dim avAdresyMail As Variant 'Tablica użytkowników, do których wyślemy mejle Dim sAdresMail As String 'Pojedynczy adres mail Dim sSciezkaDoPliku As String 'Pełna ścieżka do załącznika Dim bCzyIks As Boolean 'Informacja czy plik ma zostać dołączony Dim avZalaczniki() As Variant 'Tablica załączników Dim x As Long, r As Long 'Liczniki pętli Dim iLicznik As Integer 'Licznik załączników 'Aktywuj obsługę błędów na starcie 1 On Error GoTo ObslugaBledu 2 PrzyspieszMakro True, sInfoNaPasek(msMODUL, sPROC) 'Zaczytaj całą tabelę do tablicy 3 avObszarDanych = wksMail.Range("A1").CurrentRegion 'Przejdź w pętli po każdym adresie mail 4 For x = LBound(avObszarDanych, 2) + 1 To UBound(avObszarDanych, 2) 'Zaczytaj adres mail 5 sAdresMail = avObszarDanych(1, x) 'Przejedź w pętli po wszystkich plikach 6 For r = LBound(avObszarDanych, 1) + 1 To UBound(avObszarDanych, 1) 'Zaczytaj ścieżkę do pliku i iks 7 sSciezkaDoPliku = avObszarDanych(r, 1) 8 bCzyIks = CBool(avObszarDanych(r, x) = "x") 'Sprawdź czy dodać załącznik 9 If bCzyIks Then 'Zwiększ licznik 10 iLicznik = iLicznik + 1 'Zwiększ rozmiar tablicy 11 ReDim Preserve avZalaczniki(1 To iLicznik) 'Zaczytaj do tablicy załącznik 12 avZalaczniki(iLicznik) = sSciezkaDoPliku 13 End If '// If bCzyIks Then 14 Next r '// For r = LBound(avObszarDanych, 1) To UBound(avObszarDanych, 1) 'Działaj 15 If iLicznik <> 0 Then 'Wyślij mejla 16 WyslijZalaczniki sAdresMail, avZalaczniki 'Zresetuj licznik 17 iLicznik = 0 'Wyczyść tablicę załączników 18 Erase avZalaczniki 19 End If '// If iLicznik <> 0 Then 20 Next x '// For x = LBound(avObszarDanych, 2) To UBound(avObszarDanych, 2) Wyjscie: 21 PrzyspieszMakro False 22 On Error GoTo 0 23 Exit Sub ObslugaBledu: 24 Application.ScreenUpdating = True 25 If gbDEBUG_TRYB Then Stop 26 MsgBox "Wystąpił błąd nr " & Err.Number & " (" & Err.Description & ")." & _ vbCr & vbCr & "Linia kodu nr " & Erl & " w procedurze " & _ "'" & sPROC & "' modułu '" & msMODUL & "'.", vbInformation, "BŁĄD!" 27 Resume Wyjscie End Sub |
Makro pomocnicze
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 |
Public Sub WyslijZalaczniki(ByVal sJakiMail As String, ByVal avZalaczniki As Variant) Dim objOutApp As Object Dim objOutMail As Object Dim r As Integer Const sPROC As String = "WyslijZalaczniki" 'Aktywuj obsługę błędów na starcie 1 On Error GoTo ObslugaBledu 2 PrzyspieszMakro True, sInfoNaPasek(msMODUL, sPROC) 'Utwórz obiekt aplikacji dla Outlooka 3 Set objOutApp = CreateObject("Outlook.Application") 'Utwórz obiekt wysyłanej wiadomości 4 Set objOutMail = objOutApp.CreateItem(0) 'On Error Resume Next 5 With objOutMail 6 .To = sJakiMail 7 .CC = "" 8 .BCC = "" 9 .Subject = Format$(Date, "(ddd), dd-mm-yyyy") & " - pliki" 10 .Body = "" 11 For r = LBound(avZalaczniki) To UBound(avZalaczniki) 12 .Attachments.Add avZalaczniki(r) 13 Next r 14 .Send 15 End With 16 On Error GoTo ObslugaBledu Wyjscie: 17 PrzyspieszMakro False 18 Set objOutMail = Nothing 19 Set objOutApp = Nothing 20 On Error GoTo 0 21 Exit Sub ObslugaBledu: 22 Application.ScreenUpdating = True 23 If gbDEBUG_TRYB Then Stop 24 MsgBox "Wystąpił błąd nr " & Err.Number & " (" & Err.Description & ")." & _ vbCr & vbCr & "Linia kodu nr " & Erl & " w procedurze " & _ "'" & sPROC & "' modułu '" & msMODUL & "'.", vbInformation, "BŁĄD!" 25 Resume Wyjscie End Sub |
Funkcja przyspieszająca
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 |
Private Const msMODUL As String = "MFunkcjeMakraPomocnicze" Option Explicit ' Stale publiczne Public Const gbDEBUG_TRYB As Boolean = False Public Const gsNAZWA_PLIKU As String = "Mailing.xlsm" ' Makro przyspieszające Public Sub PrzyspieszMakro(ByVal bStan As Boolean, _ Optional sInfo As String = vbNullString) ' Funkcja zmienia domyślne ustawienia, które mają na celu przyspieszenie makra ' na starcie pliku, i powrót do standardowych na końcu działania procedury. 1 With Application 2 If bStan = False Then 3 .Calculation = xlCalculationAutomatic ' Przeliczanie automatyczne 4 .Cursor = xlDefault ' Domyślny wygląd kursora 5 .CutCopyMode = False ' Anulowanie trybu kopiowania 6 Else 7 .Calculation = xlCalculationManual ' Przeliczanie ręczne 8 .Cursor = xlWait ' Wygląd kursora (klepsydra) 9 End If 10 .EnableEvents = Not bStan ' Włączenie/wyłączenie zdarzeń 11 .ScreenUpdating = Not bStan ' Włączenie/wyłączenie odświeżania 12 .StatusBar = sInfo ' Informacja na pasku stanu 13 End With End Sub Public Function sInfoNaPasek(sModul As String, sPROC As String) As String 1 sInfoNaPasek = "Plik: " & gsNAZWA_PLIKU & " Moduł: " & sModul & _ " Makro: " & sPROC & " Proszę czekać ..." End Function |
Podsumowanie
Jak widać na poniższych screenach, oba maile wraz z załącznikami zostały dostarczone. Jest to bardzo sprytny sposób dający dużą elastyczność i personalizację.
