Question

问题：

我们的产品名称有一定的品牌格式，但在公司的每封电子邮件中手动更改颜色和字体样式非常耗时。

解决方案：

我正在尝试构建一个宏VBA代码，以便立即找到这些单词并更改格式。

代码需要找到一个以字符串“abc”开头的单词，然后将整个单词重新格式化为粗体，然后将“abc”字符串的颜色更改为与完整单词后面的字母对应的正确品牌颜色/产品。一旦加粗，我不想再次单击该按钮来增加字体大小，因此需要“if boldded”“

e.g。任何带有“abctelephone”的单词都需要加粗，并且abc更改为相应品牌的颜色。（ abctelephone ，abc为蓝色）

我有这个场景在Word 2013中运行，我在下面有一个示例代码集，我试图通过在Visual Basic参考工具中引用Microsoft Word 15.0对象库从现有版本修改此功能在Outlook电子邮件中

任何指针？

Sub Branding()
Dim insp As Outlook.Inspector
Dim myObject As Object
Dim msg As Outlook.MailItem
Dim myDoc As Word.Document
Dim mySelection As Word.Selection
Dim strItem As String
Dim strGreeting As String  
Dim StrTxt As String, Rng As Range
Dim tempFont As String
Dim tempColour As String
Dim tempBold As String
StrTxt = "abc"         
Set insp = Application.ActiveInspector
Set myObject = insp.CurrentItem     
'The active inspector is displaying a mail item.
If myObject.MessageClass = "IPM.Note" And _
    insp.IsWordMail = True Then
    Set msg = insp.CurrentItem
    'Grab the body of the message using a Word Document object.
    Set myDoc = insp.WordEditor
    Set mySelection = myDoc.Application.Selection
    Set hed = msg.GetInspector.WordEditor
    Set appWord = hed.Application
    Set appRng = appWord.Selection
    With mySelection.Range
        With mySelection.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .Text = "<" & StrTxt & "*>"
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindStop
            .Format = False
            .MatchWildcards = True
            .MatchCase = False
            .Execute
        End With
        Do While .Find.Found
        If .Font.Name <> "Arial" Then
            tempFont = .Duplicate.Font.Name
            tempColour = .Duplicate.Font.Color
            tempBold = .Duplicate.Font.Bold
            With .Duplicate
                .Font.Size = .Font.Size + 2
                .Font.Name = "Zrnic"
                .Font.Bold = True
                If .Text <> "" Then
                    Select Case Split(.Text, StrTxt)(1)
                    Case "telephone"
                        .End = .Start + Len(StrTxt)
                        .Font.Color = RGB(0, 122, 135)
                    Case "handset"
                        .End = .Start + Len(StrTxt)
                        .Font.Color = RGB(0, 122, 135)
                    Case "speaker"
                        .End = .Start + Len(StrTxt)
                        .Font.Color = RGB(0, 122, 135)

                    End Select
                End If    
            End With
        End If
        mySelection.Find.Execute

        Loop
    End With
End If

End Sub

Answer 1

我想我会在这里发布我的最终代码，以便在Outlook草稿电子邮件中动态更新更改。

这可以针对您自己的用例进行修改。

粘贴到您的ThisOutlookSession

您需要添加Word参考库。

Function GetCurrentItem() As MailItem
    Dim objApp As Outlook.Application

    Set objApp = Application

    On Error Resume Next
    Select Case TypeName(objApp.ActiveWindow)
        Case "Explorer"
          Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1)
        Case "Inspector"
          Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
    End Select

    Set objeApp = Nothing

End Function


Sub test()
    Dim doc As Document
    Dim myInspactor As Outlook.Inspector
    Dim CurrMsg As Outlook.MailItem
    Set CurrMsg = GetCurrentItem()
    Set myInspector = CurrMsg.GetInspector
    Set doc = myInspector.WordEditor
    ABCBranding doc
End Sub

Sub ABCBranding(doc As Document)
    Dim StrTxt As String, Rng As Range
    Dim tempFont As String
    Dim tempColour As String
    Dim tempBold As String

    StrTxt = "abc"

    With doc.Range
        With .Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .Text = "<" & StrTxt & "*>"
            .Replacement.Text = ""
            .forward = True
            .Wrap = wdFindStop
            .Format = False
            .MatchWildcards = True
            .MatchCase = False
            .Execute
        End With

        Do While .Find.Found
            If .Font.Name <> "Verdana" Then
                tempFont = .Duplicate.Font.Name
                tempColour = .Duplicate.Font.Color
                tempBold = .Duplicate.Font.Bold

                With .Duplicate
                  .Font.Name = "Arial"
                  .Font.Bold = True

                      Select Case Split(.Text, StrTxt)(1)
                          Case "telephone"
                          .End = .Start + Len(StrTxt)
                          .Font.Color = RGB(0, 222, 111)
                          Case "handset"
                          .End = .Start + Len(StrTxt)
                          .Font.Color = RGB(50, 200, 100)
                          Case "speaker"
                          .End = .Start + Len(StrTxt)
                          .Font.Color = RGB(43, 101, 412)
                    End Select

                End With

            End If
            .Collapse wdCollapseEnd
            .Find.Execute
        Loop
    End With
End Sub

自动格式化Outlook电子邮件正文中的某些单词

1 个答案: