使用VBA宏提高Outlook的效率和生产力(持续更新中)

• 将当前邮件中的图片设定为指定尺寸:

Sub ResizeAllImages()
    Dim objItem As Object
    Dim objInsp As Outlook.Inspector
    Dim objDoc As Word.Document
    Dim objSelection As Word.Selection
    Dim objShape As Word.InlineShape
    
    '获取当前编辑中的邮件对象
    Set objItem = Application.ActiveInspector.CurrentItem
    
    If Not objItem Is Nothing Then
        If objItem.Class = olMail Then
            '获取邮件的Word文档对象
            Set objInsp = objItem.GetInspector
            Set objDoc = objInsp.WordEditor
            Set objSelection = objDoc.Windows(1).Selection
            
            '遍历文档中所有的InlineShape对象
            For Each objShape In objDoc.InlineShapes
                '判断是否是图片
                If objShape.Type = wdInlineShapePicture Then
                    '设置图片尺寸为14x14
                    objShape.ScaleHeight = 14
                    objShape.ScaleWidth = 14
                End If
            Next objShape
        End If
    End If
End Sub

• 刷新当前邮件的正文字体:

Sub RefreshBodyFont()   ' 刷新当前邮件的正文字体
    Dim objInsp As Inspector
    Dim objDoc As Word.Document
    Set objInsp = Application.ActiveInspector
    Set objDoc = objInsp.WordEditor
    objDoc.Range.Font.Name = "Calibri"
    objDoc.Range.Font.Size = 12
End Sub

•  选中多个邮件作为附件插入到新邮件

Sub 多个邮件附件插入到新邮件()  ' 选中多个邮件作为附件插入到新邮件
    Dim objOutlook As Outlook.Application
    Dim objSelection As Selection
    Dim objItem As Object
    Dim objMail As MailItem
    Dim objAttachment As Attachment
    Dim strFile As String
    
    ' 创建 Outlook 应用程序对象
    Set objOutlook = Outlook.Application
    ' 获取当前选择的邮件
    Set objSelection = objOutlook.ActiveExplorer.Selection
    
    ' 创建新邮件
    Set objMail = objOutlook.CreateItem(olMailItem)
    
    ' 遍历选中的每封邮件
    For Each objItem In objSelection
        ' 确保当前对象是邮件
        If objItem.Class = olMail Then
            ' 将邮件保存到本地磁盘
            strOutput = Replace(objItem.Subject, "/", "")
            strOutput = Replace(strOutput, ":", "")
            strOutput = Replace(strOutput, "*", "")
            strOutput = Replace(strOutput, "?", "")
            strOutput = Replace(strOutput, """", "")
            strOutput = Replace(strOutput, "<", "")
            strOutput = Replace(strOutput, ">", "")
            strOutput = Replace(strOutput, "|", "")
            strFile = "D:\Temp\" & strOutput & ".msg"
            objItem.SaveAs strFile, olMSG
            ' 将保存的邮件添加为附件
            Set objAttachment = objMail.Attachments.Add(strFile)
        End If
    Next
    
    ' 显示新邮件
    objMail.Display
End Sub

• 将当前邮件带附件并指定相关收件人,抄送人,主题,进行转发

Sub WithAttachmentForward()
    
    Dim myinspector As Outlook.Inspector
    Dim myItem As Outlook.MailItem
    Dim myattachments As Outlook.Attachments
    Set myinspector = Application.ActiveInspector
    If Not TypeName(myinspector) = "Nothing" Then
        Set myItem = myinspector.CurrentItem.Forward
        Set myattachments = myItem.Attachments
        ' While myattachments.count > 1
        ' myattachments.Remove 2
        ' Wend
        myItem.Display
        '        myItem.Recipients.Add "xxxxx@gmail.com; xxxxx@gmail.com;"
        myItem.To = "xxxxx@gmail.com;xxxxx@gmail.com"
        myItem.CC = "xxxxx@gmail.com;xxxxx@gmail.com"
        ' myItem.Body = "" & myItem.Body
        myItem.HTMLBody = "<font face=""calibri"" style=""font-size:12pt;"">Hi Ariel,Zhangyaru: " & "<br><br>" & "" & " Could you please confirm the details of the cables and poles " & _
        "that are affected and reach out to the owner ASAP to arrange for relocation?" & _
         "<br><br>" & "Thank you for your assistance in addressing this matter." & _
            "<br><br>" & _
            "请核实我们这里的受影响的段落，并尽快联系业主反馈处理,谢谢!" & _
            myItem.HTMLBody & "</font>"   ' Adds default signature
        myItem.BodyFormat = olFormatHTML
        ' myItem.Send
    Else
        MsgBox "There is no active inspector."
    End If
    
End Sub

• 将邮件信息到处到Excel表中:

Sub List_to_Excel()   
    Dim myItem As Outlook.MailItem
    Dim nms As Outlook.NameSpace
    Dim fld As Outlook.MAPIFolder
    Dim itm As Object
    Dim myattachments As Outlook.Attachments
    Dim myOlApp As Outlook.Application
    
    Dim xlApp As Excel.Application
    Dim xlWB As Excel.Workbook
    Dim i As Long ' Row tracker
    Dim arrHeader As Variant
    
   
    Set myOlApp = CreateObject("Outlook.Application")
    Set nms = myOlApp.GetNamespace("MAPI")
    'Select export folder
    Set fld = nms.PickFolder
    'Handle potential errors with Select Folder dialog box.
    If fld Is Nothing Then
        MsgBox "There are no mail messages to export", vbOKOnly, "Error"
        Exit Sub
    ElseIf fld.DefaultItemType <> olMailItem Then
        MsgBox "There are no mail messages to export", vbOKOnly, "Error"
        Exit Sub
    ElseIf fld.Items.count = 1 Then
        MsgBox "There are no mail messages to export", vbOKOnly, "Error"
        Exit Sub
    End If
    
    
    arrHeader = Array("Received Time", "Subject", "Sender's Name", "Size", "To", "CC")
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = True
    Set xlWB = xlApp.Workbooks.Add
    
    i = 3
    On Error Resume Next
    xlWB.Worksheets(2).Range("A1").Resize(1, UBound(arrHeader) + 1).Value = arrHeader
    For Each itm In fld.Items
        Set myItem = itm
        xlWB.Worksheets(2).Cells(i, "A").Value = myItem.ReceivedTime
        xlWB.Worksheets(2).Cells(i, "B").Value = myItem.Subject
        xlWB.Worksheets(2).Cells(i, "C").Value = myItem.SenderName
        xlWB.Worksheets(2).Cells(i, "D").Value = Format(myItem.Size / 1048576, "0.00") & "M"
        xlWB.Worksheets(2).Cells(i, "E").Value = myItem.To
        xlWB.Worksheets(2).Cells(i, "F").Value = myItem.CC
        '        xlWB.Worksheets(2).Cells(i, "G").Value = myItem.SentOn
        i = i + 2
        
    Next itm
  
    
    Set xlWB = Nothing
    Set xlApp = Nothing
    Set myItem = Nothing
    Set fld = Nothing
    
End Sub