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, paska 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).
Rys.1. Interfejs programu eksportującego obiekty Outlooka na dysk.
Poniżej przedstawiony zbiór procedur znajduje się w kodzie formy:
Option Explicit
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:
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:
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.
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.