W kolejnej lekcji dalej zapoznawać będziemy się z metodami oraz możliwościami, jakie daje nam wbudowany mechanizm programowania w języku VBA. Możliwości te zastosujemy w praktyce.

Lekcja 2. Export wiadomości na dysk.

Druga lekcja ma pokazać jak wykorzystać możliwość exportu wiadomości do wskazanego przez użytkownika katalogu. Jak zbudować własny interfejs w oparciu o ogólnie dostępne kontrolki, oraz jak swobodnie deklarować zmienne i dzięki prostym zabiegom kształtować wynik zapisu eksportowanego obiektu.

Dla osób, które chciałyby sprawdzić działanie przygotowanych procedur bez rysowania formatki interfejsu zapraszam do pobrania gotowej formy. Po rozpakowaniu pliku należy osadzić go w miejscu drzewa projektu (analogicznie jak w lekcji pierwszej)  przesuwając myszą plik o rozszerzeniu frm.
 
Następnie tworzymy nowy lub dodajemy do już istniejącego modułu poniżej opisany kod wywołania formy:
 
Option Explicit
Sub WywolanieExportMSG()
    Export_wiadomosci_MSG.Show()
End Sub
 
Uruchomienie powyższej procedury, spowoduje wywołanie formy (Rys.1.) składającej się z: dwóch pól tekstowych, trzech checkboxów, *** postępu (z pakietu biblioteki mscomctl.ocx), dwóch przycisków oraz dwóch etykiet opisujących elementy w ekranie interfejsu aplikacji. Dodatkowo użyta została ramka oddzielająca pasek od części właściwej (nie jest konieczna w projekcie).
 
Interfejs programu
Rys.1. Interfejs programu eksportującego obiekty Outlooka na dysk.
 
Poniżej przedstawiony zbiór procedur znajduje się w kodzie formy:
 
Option Explicit On

Private Sub Anuluj_Click()
    Unload(Me)
End Sub

Private Sub MSG_Export_Click()
    Call MSG_Export_by_email(MSG_Miejsce_zapisu.Text, MSG_Konkretny_Adres.Text)
End Sub

Private Sub MSG_Export_by_email(strDestFolder$, Optional adres_str$)
    If Len(MSG_Miejsce_zapisu.Text) = 0 Then GoTo blad
    Dim strFileName$, strSubject$, strDate$, strSender$
    Dim item, x& : x = 0
    Dim ile& : ile = 0
    Dim oFolder As MAPIFolder
    oFolder = Application.ActiveExplorer.CurrentFolder
    If MSG_Folder.value = True Then strDestFolder = strDestFolder & oFolder.Name & "\"

    Me.Height = 225
    With ProgressBar1
        .Visible = True
        .value = 0
        .max = oFolder.Items.Count
    End With

    For Each item In oFolder.Items
        DoEvents()
        strSubject = RemoveInvalidChars(Left(item.Subject, 250))

        If item.Class = 43 Then
            If Len(Trim(adres_str)) > 0 Then
                If LCase(item.SenderEmailAddress) <> LCase(adres_str) Then GoTo nastepny
            End If
            strDate = RemoveInvalidChars(Replace(item.SentOn, ":", "_"))
            strSender = RemoveInvalidChars(item.Recipients(1).Address)
            If MSG_Data.value = True And MSG_Adres.value = True Then
                strFileName = strDate & " " & strSender & " " & strSubject & ".msg"
            ElseIf MSG_Adres.value = True And MSG_Data.value = False Then
                strFileName = strSender & " " & strSubject & ".msg"
            ElseIf MSG_Adres.value = False And MSG_Data.value = True Then
                strFileName = strDate & " " & strSubject & ".msg"
            Else
                strFileName = strSubject & ".msg"
            End If
        Else
            strFileName = strSubject & ".msg"
        End If

        Call MakeWholePath(strDestFolder & strFileName)
        item.SaveAs(strDestFolder & strFileName, olMSG)
        ile = ile + 1
nastepny:
        x = x + 1
        ProgressBar1.value = x
    Next
    Me.Height = 205
    MsgBox("Proces exportu wiadomości do plików MSG zakończono." & vbCr & _
        "Wykonano export: " & ile & " z " & x & " wiadomości do: " & xhr(34) & _
        strDestFolder & xhr(34), vbInformation, "Informacja dodatkowa VBATools.pl")
koniec:
    oFolder = Nothing
    MSG_Miejsce_zapisu.SetFocus()
    Exit Sub

blad:
    MsgBox("Błąd exportu plików MSG" & vbCr & vbCr & _
        "Sprawdź scieżkę katalogu docelowego i uprawnienia zapisu." & vbCr & _
        Err.Number & " " & Err.Description, vbCritical, "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 "*@*.*" 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 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 FileExists(UserFile) = True 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 UserForm_Initialize()
    Me.Height = 205
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
 
Export wiadomości dotyczy obiektów osadzonych w folderze wywołania interfejsu. Sam proces nie zmienia kształtu danych, dlatego też można go stosować bez obawy utraty obiektów w pliku PST. Po wykonaniu procesu otrzymujemy komunikat potwierdzający zapis:
 
Okno potwierdzenia
Rys.2. Potwierdzenie zapisu danych do wskazanej wcześniej lokalizacji.
 
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 adresem