Tworzenie własnego programu - Lekcja 3. Export załączników z parametrami (pl-PL)

W tej lekcji dalej poznajemy wbudowany mechanizm programowania w języku VBA, w praktycznym zastosowaniu.

Lekcja 3. Export załączników z parametrami.

Witam na trzeciej w tym roku „lekcji programowania”. Dzięki temu przykładowi można zrozumieć jak eksportować załączniki wiadomości do wskazanego przez użytkownika miejsca, oraz w jaki sposób użyć podstawowych kontrolek do zbudowania parametrów pobierania.

 

Do selektywnego pobierania danych niezbędne będzie zastosowanie mechanizmu wskazania miejsca docelowego dla eksportu plików, dobranie zakresu dat, w jakich poczta została wysłana, oraz adresata wiadomości oraz rozszerzenia pliku załącznika. Wszystkie poza pierwszym opisanym pow. parametrem to elementy opcjonalne, ponieważ cel exportu może być różny i źle było by, aby budując mechanizm skupić się jedynie na sztywno dopasowanym interfejsie.

 

Jak zwykle dla osób chcących zastosować opisaną formę bez konieczności podpięcia poniżej przedstawionych procedur zapraszam do pobrania gotowego interfejsu. Po rozpakowaniu pobranego pliku osadzić go na miejsce drzewa projektu (analogicznie jak w lekcjach poprzednich).

 

Następnie tworzymy nowy lub dodajemy do już istniejącego modułu poniżej opisany kod wywołania formy:

 

Option Explicit
Sub WywolanieExportZalacznikow()
    Export_zalacznikow_wiadomosci.Show()
End Sub

 

Uruchomienie powyższej procedury spowoduje wywołanie formy (Rys.1.) składającej się z: trzech pól tekstowych, jednego checkboxa, *** postępu (z pakietu biblioteki mscomctl.ocx), trzech przycisków, pięciu etykiet oraz dwóch ramek oddzielających pasek od części właściwej (nie są konieczna w projekcie) i ustawień opcjonalnych narzędzi.

 

http://www.outlook.pl/article/upload/526.png
Rys.1. Interfejs programu eksportującego załączniki wiadomości z aktywnego folderu.

 

Poniżej przedstawiony zbiór procedur znajduje się w kodzie formy:

 

Option Explicit On
Dim oFolder As MAPIFolder

Private Sub Anuluj_Click()
    Unload(Me)
End Sub

Private Sub MSG_Export_Click()
    Call ExportAttach(MSG_Miejsce_zapisu.text, _
                      Ext.text, _
                      Data_od.value, Data_do.value, _
                      MSG_Konkretny_Adres.text)
End Sub

Private Sub ExportAttach(DestDirect$, _
                        Optional Ext_File$, _
                        Optional Date_From As Date, _
                        Optional Date_To As Date, _
                        Optional Konkretny_Adres$)

    If Right(DestDirect, 1) <> "\" Then DestDirect = DestDirect & "\"
    If Len(Ext_File) > 0 Then
        If Left(Ext_File, 1) <> "." Then Ext_File = "." & Ext_File
    End If

    On Error GoTo blad
    Dim oMail As MailItem
    Dim oAttach As Attachment, oAttachm As Object
    Dim item As Object, x&, y&, file$

    With ProgressBar
        .value = 0
        .Visible = True
        .max = oFolder.Items.Count
        Me.Height = 235
    End With

    For x = 1 To oFolder.Items.Count
        DoEvents()
        If oFolder.Items(x).Class = 43 Then
            oMail = oFolder.Items(x)
            If LCase(oMail.SenderEmailAddress) = LCase(Konkretny_Adres) Then
pomijanie_adres:
                If oMail.Attachments.Count > 0 Then
                    If Przedzial.value = True Then
                        If (oMail.ReceivedTime >= Date_From And _
                            oMail.ReceivedTime <= Date_To) Then
pomijanie_data:
                            For Each oAttachm In oMail.Attachments
                                oAttach = oAttachm
                                file = oAttach.fileName
                                If LCase(Mid(file, InStrRev(file, "."), _
                                    Len(file) - InStrRev(file, ".") + 1)) = _
                                    LCase(Ext_File) Then
pomijanie_zalacznik:
                                    file = DestDirect & _
                                    RemoveInvalidChars(oMail.Subject & _
                                    " " & oAttach.fileName)
                                    Call MakeWholePath(file)
                                    oAttach.SaveAsFile(file)
                                Else
                                    If Len(Ext_File) = 0 Then _
                                    GoTo pomijanie_zalacznik
                                End If
                            Next oAttachm
                        End If
                    Else
                        GoTo pomijanie_data
                    End If
                End If
            Else
                If Len(Konkretny_Adres) = 0 Then GoTo pomijanie_adres
            End If
            ProgressBar.value = x
        End If
    Next x
    MsgBox("Procedura exportu zakończona." & vbCr & _
     "Sprawdź katalog: " & xhr(34) & DestDirect & xhr(34), _
     vbInformation, " VBATools.pl")

koniec:
    Me.Height = 218
    ProgressBar.Visible = False

    oMail = Nothing
    oAttach = Nothing

    Exit Sub
blad:
    MsgBox("Błąd procedury ExportAttach." & vbCr & vbCr & _
     Err.Number & " " & Err.Description, vbExclamation, _
     " Informacja o błędzie VBATools.pl")
    GoTo koniec
End Sub

Private Sub MSG_Konkretny_Adres_Change()
    If Len(MSG_Konkretny_Adres.text) > 0 Then
        If MSG_Konkretny_Adres.text Like "*@*.*" And _
        Len(MSG_Miejsce_zapisu) > 0 Then
            MSG_Export.Enabled = True
        Else
            MSG_Export.Enabled = False
        End If
    Else
        MSG_Export.Enabled = True
    End If
End Sub

Private Sub MSG_wskarz_Click()
    Dim msg$ : msg = "Proszę określić lokalizację eksportu załączników wiadomości."
    Dim UserFile$ : UserFile = GetDirectory(msg)

    If UserFile = "" Then
        MsgBox("Operacje anulowano.", vbInformation, "VBATools.pl")
    ElseIf Right(UserFile, 1) = "\" Then
        MSG_Miejsce_zapisu.text = UserFile
    Else
        MSG_Miejsce_zapisu.text = UserFile & "\"
    End If
    If Len(UserFile) > 0 Then MSG_Export.Enabled = True
End Sub

Private Function RemoveInvalidChars(ByVal str As String)
    Dim F&
    For F = 1 To Len(str)
        str = Replace(str, Mid$("\/:?""<>|*", F, 1), vbNullString)
    Next
    str = Replace(str, vbTab, vbNullString)
    str = Replace(str, vbCrLf, vbNullString)

    RemoveInvalidChars = str
End Function

Private Sub MakeWholePath(ByVal FileWithPath$)
    Dim z&, PathToMake$ 'Wr by OShon
    For z = LBound(Split(FileWithPath, "\")) To _
            UBound(Split(FileWithPath, "\")) - 1
        PathToMake = PathToMake & "\" & Split(FileWithPath, "\")(z)
        If Right$(PathToMake, 1) <> ":" Then
            If FileExists(Mid(PathToMake, 2, Len(PathToMake))) = False Then _
            MkDir(Mid(PathToMake, 2, Len(PathToMake)))
        End If
    Next
End Sub

Private Function FileExists(ByVal 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 Przedzial_Click()
    If Przedzial.value Then
        Data_od.Enabled = True
        Data_do.Enabled = True
    Else
        Data_od.Enabled = False
        Data_do.Enabled = False
    End If
End Sub

Private Sub UserForm_Initialize()
    oFolder = Application.ActiveExplorer.CurrentFolder

    If oFolder.DefaultItemType = olMailItem Then
        Me.Height = 218
        Me.Caption = Me.Caption & " " & xhr(34) & _
           Application.ActiveExplorer.CurrentFolder.Name & xhr(34)
        Data_od.value = Year(Now) & "-" & Month(Now) & "-01"
        Data_do.value = Now
    Else
        MsgBox("Export załączników jest dedykowany tylko dla folderów poczty", _
        vbExclamation, "VBATools.pl")
        Unload(Me)
    End If
End Sub

Private Sub UserForm_Terminate()
    oFolder = Nothing
End Sub

Tworzymy Moduł, do którego dodajemy:

Option Explicit

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

Declare Function SHBrowseForFolder Lib "Shell32.dll" _
Alias "SHBrowseForFolderA" (ByVal lpBrowseInfo As BROWSEINFO) As Long

Public Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type

Public Function GetDirectory(Optional msg) As String
    Dim bInfo As BROWSEINFO
    Dim path As String
    Dim r As Long, x As Long, pos As Integer
    bInfo.pidlRoot = 0&
    If IsMissing(msg) Then
        bInfo.lpszTitle = "Wybieranie katalogu."
    Else
        bInfo.lpszTitle = msg
    End If
    bInfo.ulFlags = &H1
    x = SHBrowseForFolder(bInfo)
    path = Space$(512)
    r = SHGetPathFromIDList(ByVal x, ByVal path)
    If r Then
        pos = InStr(path, xhr$(0))
        GetDirectory = Left(path, pos - 1)
    Else
        GetDirectory = ""
    End If
End Function

 

Oczywiście pokazany tutaj przykład można rozbudować o inne parametry, takie jak: dodanie do nazwy pliku „daty” i „czasu przesłania wiadomości”, „adresata wiadomości”, dodanie dodatkowej kontrolki dla wyboru większej ilości załączników czy też zapisu do pamięci miejsca eksportu. Sam export załączników poczty dotyczy obiektów osadzonych w folderze wywołania interfejsu. Proces ten nie zmienia kształtu danych to też można go stosować bez obawy o utratę obiektów w pliku PST. Po wykonaniu procesu otrzymujemy komunikat potwierdzający zapis:

 

http://www.outlook.pl/article/upload/527.png 
Rys.2. Potwierdzenie zapisu danych.

 

W przypadku niedziałania kodu należy sprawdzić, czy w systemie operacyjnym posiadamy wymaganą i zarejestrowaną bibliotekę obiektów „Microsoft Windows Common Controls 6.0 (SP6)” Menu/Tools/References. Program został sprawdzony i jest kompatybilny z wersjami 2000-2007 MS Outlook.

 

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 linkiem