从outlook导出附件的VBS小程序,详细文章来自下面:
w w w . e x p e r t s - e xchange.com/Software/Office_Productivity/Groupware/Outlook/A_3562-Export-or-Strip-Email-Attachments-in-Outlook。html
---------------------------- Option ExplicitPublic Sub ExportAttachments() Dim objOL As Outlook.Application Dim objMsg As Object Dim objAttachments As Outlook.Attachments Dim objSelection As Outlook.Selection Dim i As Long, lngCount As Long Dim filesRemoved As String, fName As String, strFolder As String, saveFolder As String, savePath As String Dim alterEmails As Boolean, overwrite As Boolean Dim result saveFolder = BrowseForFolder("Select the folder to save p_w_uploads to.") If saveFolder = vbNullString Then Exit Sub result = MsgBox("Do you want to remove p_w_uploads from selected file(s)? " & vbNewLine & _ "(Clicking no will export p_w_uploads but leave the emails alone)", vbYesNo + vbQuestion) alterEmails = (result = vbYes) Set objOL = CreateObject("Outlook.Application") Set objSelection = objOL.ActiveExplorer.Selection For Each objMsg In objSelection If objMsg.Class = olMail Then Set objAttachments = objMsg.Attachments lngCount = objAttachments.Count If lngCount > 0 Then filesRemoved = "" For i = lngCount To 1 Step -1 fName = objAttachments.Item(i).FileName savePath = saveFolder & "\" & fName overwrite = False While Dir(savePath) <> vbNullString And Not overwrite Dim newFName As String newFName = InputBox("The file '" & fName & _ "' already exists. Please enter a new file name, or just hit OK overwrite.", _ "Confirm File Name", fName) If newFName = vbNullString Then GoTo skipfile If newFName = fName Then overwrite = True Else fName = newFName savePath = saveFolder & "\" & fName Wend objAttachments.Item(i).SaveAsFile savePath If alterEmails Then filesRemoved = filesRemoved & "<br>""" & objAttachments.Item(i).FileName & """ (" & _ formatSize(objAttachments.Item(i).size) & ") " & _ "<a href=""" & savePath & """>[Location Saved]</a>" objAttachments.Item(i).Delete End Ifskipfile: Next i If alterEmails Then filesRemoved = "<b>Attachments removed</b>: " & filesRemoved & "<br><br>" Dim objDoc As Object Dim objInsp As Outlook.Inspector Set objInsp = objMsg.GetInspector Set objDoc = objInsp.WordEditor objMsg.HTMLBody = filesRemoved + objMsg.HTMLBody objMsg.Save End If End If End If NextExitSub: Set objAttachments = Nothing Set objMsg = Nothing Set objSelection = Nothing Set objOL = NothingEnd SubFunction formatSize(size As Long) As String Dim val As Double, newVal As Double Dim unit As String val = size unit = "bytes" newVal = Round(val / 1024, 1) If newVal > 0 Then val = newVal unit = "KB" End If newVal = Round(val / 1024, 1) If newVal > 0 Then val = newVal unit = "MB" End If newVal = Round(val / 1024, 1) If newVal > 0 Then val = newVal unit = "GB" End If formatSize = val & " " & unitEnd Function'Function purpose: To Browser for a user selected folder.'If the "OpenAt" path is provided, open the browser at that directory'NOTE: If invalid, it will open at the Desktop levelFunction BrowseForFolder(Optional Prompt As String, Optional OpenAt As Variant) As String Dim ShellApp As Object Set ShellApp = CreateObject("Shell.Application").BrowseForFolder(0, Prompt, 0, OpenAt) On Error Resume Next BrowseForFolder = ShellApp.self.Path On Error GoTo 0 Set ShellApp = Nothing 'Check for invalid or non-entries and send to the Invalid error handler if found 'Valid selections can begin L: (where L is a letter) or \\ (as in \\servername\sharename. All others are invalid Select Case Mid(BrowseForFolder, 2, 1) Case Is = ":": If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid Case Is = "\": If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid Case Else: GoTo Invalid End Select Exit FunctionInvalid: 'If it was determined that the selection was invalid, set to False BrowseForFolder = vbNullStringEnd FunctionFunction BrowseForFile(Optional Prompt As String, Optional OpenAt As Variant) As String Dim ShellApp As Object Set ShellApp = CreateObject("Shell.Application").BrowseForFolder(0, Prompt, 16 + 16384, OpenAt) On Error Resume Next BrowseForFile = ShellApp.self.Path On Error GoTo 0 Set ShellApp = Nothing 'Check for invalid or non-entries and send to the Invalid error handler if found 'Valid selections can begin L: (where L is a letter) or \\ (as in \\servername\sharename. All others are invalid Select Case Mid(BrowseForFolder, 2, 1) Case Is = ":": If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid Case Is = "\": If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid Case Else: GoTo Invalid End Select Exit FunctionInvalid: 'If it was determined that the selection was invalid, set to False BrowseForFile = vbNullStringEnd Function ------------------------------w w w。experts-exchang e.com/Software/Office_Productivity/Groupware/Outlook/A_3562-Export-or-Strip-Email-Attachments-in-Outlook.html