此脚本会自动打印附件。
我还想根据文件名的第一个字符将附件保存到文件夹中。
我收到 .docx 格式的电子邮件工单，始终以四位数字开头 （例如 1200-john_doe-job1）.
这四位工单编号后面有一些字符，例如客户名称和职位描述。
文件夹分为以下几个部分：
根文件夹不变，“C:\work order”
在此文件夹内，工单按工单 1200-1299、1300-1399、1400-1499 等分为大文件夹。
该脚本需要获取 .docx 文件的前两个字符，并导航到适当的大文件夹，然后进入其特定的子文件夹。
我想要达到的结果：
以 1256 开头的工作订单 .docx 文件将导航到 1200-1299 文件夹 (C:\工作订单P0-1299)，然后保存到文件夹 1256-randomtext (C:\工作订单P0-1299U6-randomtext)。
Public Declare Function GetProfileString Lib "kernel32" Alias "GetProfileStringA" _
(ByVal lpAppName As String, ByVal lpKeyName As String, _
ByVal lpDefault As String, ByVal lpReturnedString As String, _
ByVal nSize As Long) As Long
Private Declare Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, _
ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Sub MessageAndAttachmentProcessor(Item As Outlook.MailItem, _
Optional bolPrintMsg As Boolean, _
Optional bolSaveMsg As Boolean, _
Optional bolPrintAtt As Boolean, _
Optional bolSaveAtt As Boolean, _
Optional bolInsertLink As Boolean, _
Optional strAttFileTypes As String, _
Optional strFolderPath As String, _
Optional varMsgFormat As OlSaveAsType, _
Optional strPrinter As String)
Dim olkAttachment As Outlook.Attachment, _
objFSO As FileSystemObject, _
strMyPath As String, _
strExtension As String, _
strFileName As String, _
strOriginalPrinter As String, _
strLinkText As String, _
strRootFolder As String, _
strTempFolder As String, _
varFileType As Variant, _
intCount As Integer, _
intIndex As Integer, _
arrFileTypes As Variant
Set objFSO = CreateObject("Scripting.FileSystemObject")
strTempFolder = Environ("TEMP") & "\"
If strAttFileTypes = "" Then
arrFileTypes = Array("*")
Else
arrFileTypes = Split(strAttFileTypes, ",")
End If
If bolPrintMsg Or bolPrintAtt Then
If strPrinter <> "" Then
strOriginalPrinter = GetDefaultPrinter()
SetDefaultPrinter strPrinter
End If
End If
If bolSaveMsg Or bolSaveAtt Then
If strFolderPath = "" Then
strRootFolder = Environ("USERPROFILE") & "\My Documents\"
Else
strRootFolder = strFolderPath & IIf(Right(strFolderPath, 1) = "\", "", "\")
End If
End If
If bolSaveMsg Then
Select Case varMsgFormat
Case olHTML
strExtension = ".html"
Case olMSG
strExtension = ".msg"
Case olRTF
strExtension = ".rtf"
Case olDoc
strExtension = ".doc"
Case olTXT
strExtension = ".txt"
Case Else
strExtension = ".msg"
End Select
Item.SaveAs strRootFolder & RemoveIllegalCharacters(Item.Subject) & strExtension, varMsgFormat
End If
For intIndex = Item.Attachments.Count To 1 Step -1
Set olkAttachment = Item.Attachments.Item(intIndex)
'Print the attachments if requested'
If bolPrintAtt Then
If olkAttachment.Type <> olEmbeddeditem Then
For Each strFileType In arrFileTypes
If (strFileType = "*") Or (LCase(objFSO.GetExtensionName(olkAttachment.FileName)) = LCase(strFileType)) Then
olkAttachment.SaveAsFile strTempFolder & olkAttachment.FileName
ShellExecute 0&, "print", strTempFolder & olkAttachment.FileName, 0&, 0&, 0&
End If
Next
End If
End If
'Save the attachments if requested'
If bolSaveAtt Then
strFileName = olkAttachment.FileName
intCount = 0
Do While True
strMyPath = strRootFolder & strFileName
If objFSO.FileExists(strMyPath) Then
intCount = intCount + 1
strFileName = "Copy (" & intCount & ") of " & olkAttachment.FileName
Else
Exit Do
End If
Loop
olkAttachment.SaveAsFile strMyPath
If bolInsertLink Then
If Item.BodyFormat = olFormatHTML Then
strLinkText = strLinkText & "<a href=""file://" & strMyPath & """>" & olkAttachment.FileName & "</a><br>"
Else
strLinkText = strLinkText & strMyPath & vbCrLf
End If
olkAttachment.Delete
End If
End If
Next
If bolPrintMsg Then
Item.PrintOut
End If
If bolPrintMsg Or bolPrintAtt Then
If strOriginalPrinter <> "" Then
SetDefaultPrinter strOriginalPrinter
End If
End If
If bolInsertLink Then
If Item.BodyFormat = olFormatHTML Then
Item.HTMLBody = Item.HTMLBody & "<br><br>Removed Attachments<br><br>" & strLinkText
Else
Item.Body = Item.Body & vbCrLf & vbCrLf & "Removed Attachments" & vbCrLf & vbCrLf & strLinkText
End If
Item.Save
End If
Set objFSO = Nothing
Set olkAttachment = Nothing
End Sub
Function GetDefaultPrinter() As String
Dim strPrinter As String, _
intReturn As Integer
strPrinter = Space(255)
intReturn = GetProfileString("Windows", ByVal "device", "", strPrinter, Len(strPrinter))
If intReturn Then
strPrinter = UCase(Left(strPrinter, InStr(strPrinter, ",") - 1))
End If
GetDefaultPrinter = strPrinter
End Function
Function RemoveIllegalCharacters(strValue As String) As String
' Purpose: Remove characters that cannot be in a filename from a string.'
RemoveIllegalCharacters = strValue
RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "<", "")
RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, ">", "")
RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, ":", "")
RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, Chr(34), "'")
RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "/", "")
RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "\", "")
RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "|", "")
RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "?", "")
RemoveIllegalCharacters = Replace(RemoveIllegalCharacters, "*", "")
End Function
Sub SetDefaultPrinter(strPrinterName As String)
Dim objNet As Object
Set objNet = CreateObject("Wscript.Network")
objNet.SetDefaultPrinter strPrinterName
Set objNet = Nothing
End Sub
Sub Autoprint(Item As Outlook.MailItem)
MessageAndAttachmentProcessor Item, False, False, True, False, False, "doc,docx"
End Sub
这就是我所得到的，但它在尝试实现它时不断返回错误...谷歌对我的行 attName = oAttachment.DisplayName 的错误没有任何帮助。
Public Sub SaveAttachmentsToDisk(MItem As Outlook.MailItem)
Dim oAttachment As Outlook.Attachment
Dim sSaveFolder As String
Dim attName As String
attName = oAttachment.DisplayName
sSaveFolder = GetSaveLocation(attName)
oAttachment.SaveAsFile sSaveFolder & oAttachment.DisplayName
End Sub
'Return folder path for filenames of format [four digits]+[optional other text]
' create any missing folders as needed
Function GetSaveLocation(attName As String) As String
Const ROOT_FOLDER As String = "C:\work orders\" 'must already exist
Dim dd As String, pth As String, fldrGrp As String, f
If attName Like "####*" Then 'begins with 4 digits?
dd = Left(attName, 2)
fldrGrp = dd & "00-" & dd & "99\"
pth = ROOT_FOLDER & fldrGrp
If Len(Dir(pth, vbDirectory)) = 0 Then MkDir pth 'create group folder if needed
'any matching
f = Dir(pth & Left(attName, 4) & "*", vbDirectory)
If Len(f) > 0 Then
GetSaveLocation = pth & f & "\" 'existing folder
Else
GetSaveLocation = pth & Left(attName, 4) & "\"
MkDir GetSaveLocation 'create final folder
End If
End If
End Function
编辑 - 添加了使用该功能保存附件的示例。
我将创建一个单独的函数来返回文件夹路径，并根据需要创建任何丢失的文件夹。
例如：
Sub TestAttachmentSave()
Dim selItems As Selection
Dim objItem As Object, att As Attachment
Dim savepath As String, attName As String
Set selItems = ActiveExplorer.Selection 'all selected mails
For Each objItem In selItems
If TypeOf objItem Is MailItem Then 'is mail object?
For Each att In objItem.Attachments 'check any attachments
attName = att.FileName
If LCase(attName) Like "####*.doc*" Then 'candidate for saving?
savepath = GetSaveLocation(attName)
If Len(savepath) > 0 Then 'got a path to save to?
att.SaveAsFile savepath & attName
Debug.Print "Saved", savepath & attName
End If
End If
Next att
End If
Next objItem
End Sub
'Return folder path for filenames of format [four digits]+[optional other text]
' create any missing folders as needed
Function GetSaveLocation(attName As String) As String
Const ROOT_FOLDER As String = "C:\Temp\work orders\" 'must already exist
Dim dd As String, pth As String, fldrGrp As String, f
If attName Like "####*" Then 'begins with 4 digits?
dd = Left(attName, 2)
fldrGrp = dd & "00-" & dd & "99\"
pth = ROOT_FOLDER & fldrGrp
If Len(Dir(pth, vbDirectory)) = 0 Then MkDir pth 'create group folder if needed
'any matching
f = Dir(pth & Left(attName, 4) & "*", vbDirectory)
If Len(f) > 0 Then
GetSaveLocation = pth & f & "\" 'existing folder
Else
GetSaveLocation = pth & Left(attName, 4) & "\"
MkDir GetSaveLocation 'create final folder
End If
End If
End Function