W tej lekcji dalej poznajemy wbudowany mechanizm programowania w języku VBA, w praktycznym zastosowaniu.
Lekcja 3. Export załączników z parametrami.
Option Explicit Sub WywolanieExportZalacznikow() Export_zalacznikow_wiadomosci.Show() End Sub
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
Shon Oskar – www.VBATools.pl