Bardzo częstą sytuacją w przypadku tworzenia nietrywialnych aplikacji Excel/VBA jest prośba Klienta o opracowanie makra, które będzie wysyłać raporty do konkretnych ludzi z określoną częstotliwością (np. raz dziennie).
O Potrzebie
Jest to przeważnie końcowy etap prac nad projektem – wszystko działa, pliki zrzucane są do folderów na serwerze firmy. Mogą to być pliki Excela, dokumenty PDF czy też screeny ze zdjęciami.
Ze względu jednak na pewną wygodę i bezpieczeństwo dostępu do danych, konieczne jest napisanie dodatkowego kodu. Jego rolą jest własnie dostarczenie wybranym osobom określonych plików.
Macierz
W tego typu 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 może znajdować się znak, który informuje nas, czy dana kombinacja ma zostać wzięta pod uwagę.
Poniżej wklejam taką bardzo uproszczoną tabelkę, która w pierwszym wierszu zawiera adresy e-mail, natomiast w pierwszej kolumnie lokalizacje plików, które mają zostać wysłane.
Znak x na przecięciu sugeruje, że dany plik ma zostać przesłany na ten e`mail.
Jak widzimy, nie są to raporty Excela lecz pliki graficzne, ale jest to bez znaczenia – najważniejszy jest prawidłowy adres pliku.
Kod Makra
Kod, który realizuje to zadanie wklejam poniżej.
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
I jeszcze makro pomocnicze.
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
Jeszcze funkcja przyspieszająca działanie makra.
Private Const msMODUL As String = "MFunkcjeMakraPomocnicze"
Option Explicit
Public Const gbDEBUG_TRYB As Boolean = False
Public Const gsNAZWA_PLIKU As String = "Mailing.xlsm"
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
Screeny
Jak widać na poniższych screenach, oba maile wraz z załącznikami zostały odebrane.
