VBA Makro in Outlook 2016 sehr langsam (VBA)

DieSpeedy, Montag, 16.03.2020, 21:25 (vor 19 Tagen)

Hallo zusammen,

ich habe mir ein Makro zusammengestellt, um (eigentlich) E-Mails schneller ablegen zu können. Leider bringt mich die Performance zum Verzweifeln. Habt Ihr eine Idee, wie ich das optimieren kann? (Vorsicht: bin ziemlicher Anfänger ;-) - Aber für Unterstützung sehr dankbar.)

Hier das Makro:
Sub SaveCustomerMail()

Dim strPath As String

strPath = BrowseForFolder("C:\Pfad\")

SaveMail (strPath)

End Sub

Function BrowseForFolder(Optional sFolder As String) As String

Dim exApp As Object
Dim strPath As String: strPath = ""
Dim fldr As FileDialog
Dim bStarted As Boolean
On Error Resume Next
Set exApp = GetObject(, "Excel.Application")
On Error GoTo 0
If exApp Is Nothing Then
Set exApp = CreateObject("Excel.Application")
bStarted = True
End If
Set fldr = exApp.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.InitialFileName = sFolder
.AllowMultiSelect = False
If .Show <> -1 Then GoTo lbl_Exit
strPath = .SelectedItems(1) & Chr(92)
End With
lbl_Exit:
BrowseForFolder = strPath
If bStarted = True Then exApp.Quit 'Optional
Set exApp = Nothing
Exit Function
End Function

Function SaveMail(strPath As String)

Dim strText As String
Dim strDate As String

If strPath = "" Then
strPath = "C:\Pfad2\"
End If

'MsgBox (strPath)

i = 1
For Each msg In Application.ActiveExplorer.Selection

'MsgBox (msg)

If TypeOf Application.ActiveWindow Is Outlook.Explorer Then
Set obj = Application.ActiveWindow
Set obj = obj.Selection(i)
i = i + 1

Else

Set objInspector = ActiveInspector
objInspector.Activate

If objInspector.IsWordMail Then
'Set obj = Application.ActiveInspector.CurrentItem
Set obj = Application.ActiveInspector.Selection
End If

End If

With obj
strText = Replace(obj.Subject, "/", "_")
strText = Replace(strText, "!", "")
strText = Replace(strText, ".", "_")
strText = Replace(strText, "\", "_")
strText = Replace(strText, ":", "_")
strText = Replace(strText, "(", "")
strText = Replace(strText, ")", "")
strText = Replace(strText, """", "")

'MsgBox (strText)

strDate = Format(obj.ReceivedTime, "YYYYMMDD_hh-mm")

.SaveAs strPath & strDate & "_" & "von" & "_" & obj.SenderName & "_" & strText & ".msg"

End With

Next msg

End Function

VG
DieSpeedy


gesamter Thread:

 RSS-Feed dieser Diskussion

powered by my little forum