我试图编写一个Outlook VBA宏，它接收用户选择的所有电子邮件，然后将它们保存为文本文件，文本文件的名称作为主题行的一部分，然后移动该电子邮件在outlook中的另一个文件夹。
我设法完成了所有工作，但我也希望代码在主题行（仅作为Trip＃XXXXXXXXX）中留下两个旅行号码，而不是移动它，而是移动到下一个选定的电子邮件。但是我似乎无法让它工作，Exit Sub只是一个很难停下来，我想循环选择其余部分。接下来oMail是我最后只允许其中一个和需要的东西，GoTo跳过其余代码的位置似乎没有帮助。
我应该使用For Each oMail In Application.ActiveExplorer.Selection以外的其他内容吗？
任何帮助将不胜感激。谢谢！
此刻此刻有点混乱，因为我已经找到回来的路，而不是接触这个东西大约十年了。目前，整个事情如下：
Sub SaveSentEmailAsParsedSubjectAndMove()
Dim oMail As Outlook.MailItem
'Folder path and file name
Dim strDesktop As String, strFileName As String, strFolderPath As String
'Four letters at the start of a trip/PAPS/PARS and the number itself
Dim strSCAC As String, strTripNumber As String
'Trip number counter
Dim strSubject As String, strSubject2 As String
Dim intTrips As Integer, intTrips1 As Integer, intTrips2 As Integer
'Duplicate checker
'Dim strTestStr As String, strTestPath As String
Dim strVersion As String, strVersionCheck As String
'File saved counter
Dim intFilesSaved As Integer
intFilesSaved = 0
'X carries the value for the file name, trying to save one higher in the event of a duplicate
Dim x As Integer
'Creates a text file on the desktop that will have all saved trip numbers written into it for the day.
Dim objFSO As Object
'Dim objFSO As New FileSystemObject
Dim objDailyLog As Object
'Dim objDailyLog As TextStream
Dim strTextFilePath As String
Dim strTextFilePathTest As String
'Constants for reading/writing to the daily log file - Appending adds data to the end.
'For Reading = 1
'For Writing = 2
'For Appending = 8
'Variables for the timers
'Daily log save time timer
Dim sngStart As Single, sngEnd As Single, sngElapsed As Single
Dim sngStart2 As Single, sngEnd2 As Single, sngElapsed2 As Single
If ActiveExplorer.Selection.Count = 0 Then
MsgBox "No files selected"
Exit Sub
End If
'Start timer
sngStart = Timer
sngStart2 = Timer
1
x = 1
'Set folder path - This will have to change to the J daily fax for release - J:\Fax Confirmations Daily
strDesktop = Environ("userprofile")
strFolderPath = strDesktop & "\Desktop\Test Folder\"
If Len(Dir(strFolderPath)) = 0 Then
MkDir strFolderPath
Else
End If
'strFolderPath = "J:\Fax Confirmations Daily\"
'Sets the path to create the record keeping text file in.
strTextFilePath = strDesktop & "\Desktop\" & Month(Date) & " " & Day(Date) & " Saved Faxes.txt"
Set objFSO = CreateObject("Scripting.FileSystemObject")
If Len(Dir(strTextFilePath)) = 0 Then
'MsgBox "File does NOT exist"
Set objDailyLog = objFSO.CreateTextFile(strTextFilePath)
objDailyLog.Close
Else
'MsgBox "File already exists"
End If
'This will save all emails selected
For Each oMail In Application.ActiveExplorer.Selection
'Gets the subject line of the mail item
strSubject = oMail.Subject
'Gets the SCAC code from the subject line, the first four characters counting from left
strSCAC = strSubject
strSCAC = Left(strSCAC, 4)
'Counter. Stops process and returns error if there is more than one trip number detected.
strSubject2 = oMail.Subject
strSubject2 = Replace(strSubject2, "#", "")
intTrips1 = Len(strSubject)
intTrips2 = Len(strSubject2)
intTrips = intTrips1 - intTrips2
If intTrips > 1 Then
MsgBox "You have selected an email with more than one trip number in the subject. Please only select messages with a single trip number. Thanks.", 0, "Multiple Trip Numbers Detected"
GoTo 3
'Exit Sub
Else
'Gets the trip number, hereby defined as everything to the RIGHT of the # in the subject line
strTripNumber = strSubject
strTripNumber = Mid(strSubject, InStr(strSubject, "#") + 1)
'Set the File name
strVersion = ""
strFileName = strSCAC & strTripNumber & strVersion
2
'Test if file name exists. If yes, increase version number by 1 and try again.
'If no, save and continue processing.
If Len(Dir(strFolderPath & strFileName & " Sent" & strVersion & ".txt")) = 0 Then
'Save the text file with the completed file name to the previously defined folder
oMail.SaveAs strFolderPath & strFileName & " Sent" & strVersion & ".txt", olTXT
intFilesSaved = intFilesSaved + 1
'Open daily log file for addending (do not overwrite current data, merely add new lines to bottom)
Set objDailyLog = objFSO.OpenTextFile(strTextFilePath, 8, True)
objDailyLog.WriteLine (strFileName & " " & strVersion)
'Close the daily log text file
objDailyLog.Close
Else
'If the file already exists, increase the version counter by 1 and try again.
x = x + 1
strVersion = " " & x
GoTo 2
End If
End If
x = 1
'MoveToBackup
3
Next oMail
If intTrips > 1 Then
Set objDailyLog = objFSO.OpenTextFile(strTextFilePath, 8, True)
objDailyLog.WriteLine (Time)
objDailyLog.WriteLine "Saved in " & sngElapsed & " seconds"
objDailyLog.WriteLine "Error detected: Multiple trip numbers in subject line!"
objDailyLog.WriteBlankLines (1)
objDailyLog.Close
sngEnd2 = Timer
sngElapsed2 = Format(sngEnd2 - sngStart2, "Fixed")
MsgBox intFilesSaved & " file(s) saved successfully" & " in " & sngElapsed2 & " seconds", 0, "Files Saved"
intTrips = 0
Else
MoveToBackup
sngEnd = Timer
sngElapsed = Format(sngEnd - sngStart, "Fixed")
Set objDailyLog = objFSO.OpenTextFile(strTextFilePath, 8, True)
objDailyLog.WriteLine (Time)
objDailyLog.WriteLine "Saved in " & sngElapsed & " seconds"
objDailyLog.WriteBlankLines (1)
objDailyLog.Close
sngEnd2 = Timer
sngElapsed2 = Format(sngEnd2 - sngStart2, "Fixed")
MsgBox intFilesSaved & " file(s) saved successfully" & " in " & sngElapsed2 & " seconds", 0, "Files Saved"
End If
End Sub
'Outlook VB Macro to move selected mail item(s) to a target folder
Sub MoveToBackup()
On Error Resume Next
Dim ns As Outlook.NameSpace
Dim moveToFolder As Outlook.MAPIFolder
Dim objItem As Outlook.MailItem
Set ns = Application.GetNamespace("MAPI")
'Define path to the target folder - this was the original code,
Set moveToFolder = ns.GetDefaultFolder(olFolderSentMail).Folders("Backup")
If Application.ActiveExplorer.Selection.Count = 0 Then
MsgBox ("No item selected")
Exit Sub
End If
If moveToFolder Is Nothing Then
MsgBox "Target folder not found!", vbOKOnly + vbExclamation, "Move Macro Error"
End If
For Each objItem In Application.ActiveExplorer.Selection
If moveToFolder.DefaultItemType = olMailItem Then
If objItem.Class = olMail Then
objItem.Move moveToFolder
End If
End If
Next
Set objItem = Nothing
Set moveToFolder = Nothing
Set ns = Nothing
End Sub
答案 0 :(得分：0)
您可以使用like
If oMail.Subject like "*TRIP*TRIP*" Then
答案 1 :(得分：0)
您已经使用
从选区中删除项目If intTrips > 1 Then
但稍后您将移动所有邮件。
您可以立即移动经过验证的邮件。
Sub MoveValidatedMail()
Dim oMail As mailItem
'Four letters at the start of a trip/PAPS/PARS and the number itself
Dim strSCAC As String, strTripNumber As String
'Trip number counter
Dim strSubject As String, strSubject2 As String
Dim intTrips As Integer, intTrips1 As Integer, intTrips2 As Integer
'Move vaidated mail one at a time,
' within this code, rather than bulk move all mail
Dim ns As namespace
Dim moveToFolder As Folder
Dim objItem As Object
Set ns = GetNamespace("MAPI")
'Define path to the target folder
' If there is a typo or missing folder there would be an error.
' Bypass this one error only.
On Error Resume Next
Set moveToFolder = ns.GetDefaultFolder(olFolderSentMail).folders("Backup")
On Error GoTo 0
If moveToFolder Is Nothing Then
' Handle the bypassed error, if any
MsgBox "Target folder not found!", vbOKOnly + vbExclamation, "Move Macro Error"
Exit Sub
End If
If moveToFolder.DefaultItemType <> olMailItem Then
MsgBox "DefaultItemType <> olMailItem!", vbOKOnly + vbExclamation, "Move Macro Error"
Exit Sub
End If
If ActiveExplorer.Selection.count = 0 Then
MsgBox "No files selected"
Exit Sub
End If
For Each objItem In ActiveExplorer.Selection
If objItem.Class = olMail Then
Set oMail = objItem
'Gets the subject line of the mail item
strSubject = oMail.subject
'Gets the SCAC code from the subject line,
' the first four characters counting from left
strSCAC = strSubject
strSCAC = Left(strSCAC, 4)
'Counter. Stops process and returns error
' if there is more than one trip number detected.
strSubject2 = oMail.subject
strSubject2 = Replace(strSubject2, "#", "")
intTrips1 = Len(strSubject)
intTrips2 = Len(strSubject2)
intTrips = intTrips1 - intTrips2
If intTrips > 1 Then
MsgBox "Mail not moved " & oMail.subject
Else
' Move validated mail
objItem.move moveToFolder
MsgBox oMail.subject & " moved to " & moveToFolder
End If
End If
Set oMail = Nothing
Next objItem
Set oMail = Nothing
Set objItem = Nothing
Set moveToFolder = Nothing
Set ns = Nothing
End Sub