格式化 VBA 中文本字符串的特定部分
Formatting specific part of text string in VBA
我正在创建一个宏,用于保存当前工作簿、创建新的 Outlook 邮件并将文件附加到邮件中。我的宏可以做到这一点,但我无法根据自己的喜好格式化电子邮件正文中的文本。
Dim OutApp As Object
Dim OutMail As Object
Dim sBody, Customer As String
ActiveWorkbook.Save
sBody = "All," & Chr(10) & Chr(10) & "Please Approve attached Request below for " & rType & "." _
& Chr(10) & Chr(10) & "Customer: " & customer & Chr(10)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.to = recip
.CC = CCed
.BCC = ""
.subject = subject
.Body = sBody
.Attachments.Add ActiveWorkbook.FullName
.display
End With
On Error GoTo 0
End Sub
我希望在电子邮件中显示以下消息(带格式)。
All,
Please Approve attached Request below for "rtype".
Customer: Whosebug
所以,"customer"这个词需要加粗。我已经厌倦了多种解决方案,但它们不起作用,因为这是在创建 outlook 邮件对象。
任何帮助将不胜感激。
**
Solution: To make the HTML tags work change the body type to html by
".HTMLBody". and you will be able to use HTML Tags. Kudos to Dick
Kusleika
**
你有几个选择
1) 使用 HTML 就像一些人评论的那样
2) 将该文本放在隐藏的 sheet 上并根据需要对其进行格式化,然后将其作为范围引用到正文中,例如.Body = sheets("hidden_Body").range("A1:B10")
3) 你可以尝试使用类似下面的东西(请注意下面用于将一个 wingding 字符添加到字符串中,需要修改以适合你的目的)
Sub Build_Wingdings(Sh As Worksheet, rng As Range)
Dim cur_L As Integer
cur_L = 1
Sheets("Word_Specifications").Range("BZ9").Copy
Sh.Range(rng.Address).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
With Sheets("Word_Specifications")
.Select
For Each cell In .Range(.Range("Word_Standard_Start").Address, .Range("Word_Standard_Start").End(xlDown).Address)
If cell.value = "" Then
Else
L = Len(cell.value) + 1
With Sh.Range(rng.Address)
With .Characters(start:=cur_L, Length:=L).Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 9
.Bold = False
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
cur_L = cur_L + L
If .value <> "" Then
add_Wingdings cur_L, 1, Sh, rng
cur_L = cur_L + 2
End If
End With
End If
Next
End With
End Sub
Sub add_Wingdings(start As Integer, Length As Integer, Sh As Worksheet, rng As Range)
With Sh.Range(rng.Address).Characters(start:=start, Length:=Length).Font
.Name = "Wingdings 3"
.FontStyle = "Regular"
.Size = 9
.Bold = False
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
End Sub
HTML 标签确实有效。我不知道你为什么说他们没有。
sBody = "All,<br /><br />Please Approve attached request for " & rType & ".<br /><br /><strong>Customer:</strong> " & customer & "<br />"
然后使用 .HTMLBody
而不是 .Body 属性
.HTMLBody = sBody
我正在创建一个宏,用于保存当前工作簿、创建新的 Outlook 邮件并将文件附加到邮件中。我的宏可以做到这一点,但我无法根据自己的喜好格式化电子邮件正文中的文本。
Dim OutApp As Object
Dim OutMail As Object
Dim sBody, Customer As String
ActiveWorkbook.Save
sBody = "All," & Chr(10) & Chr(10) & "Please Approve attached Request below for " & rType & "." _
& Chr(10) & Chr(10) & "Customer: " & customer & Chr(10)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.to = recip
.CC = CCed
.BCC = ""
.subject = subject
.Body = sBody
.Attachments.Add ActiveWorkbook.FullName
.display
End With
On Error GoTo 0
End Sub
我希望在电子邮件中显示以下消息(带格式)。
All,
Please Approve attached Request below for "rtype".
Customer: Whosebug
所以,"customer"这个词需要加粗。我已经厌倦了多种解决方案,但它们不起作用,因为这是在创建 outlook 邮件对象。
任何帮助将不胜感激。
**
Solution: To make the HTML tags work change the body type to html by ".HTMLBody". and you will be able to use HTML Tags. Kudos to Dick Kusleika
**
你有几个选择
1) 使用 HTML 就像一些人评论的那样
2) 将该文本放在隐藏的 sheet 上并根据需要对其进行格式化,然后将其作为范围引用到正文中,例如.Body = sheets("hidden_Body").range("A1:B10")
3) 你可以尝试使用类似下面的东西(请注意下面用于将一个 wingding 字符添加到字符串中,需要修改以适合你的目的)
Sub Build_Wingdings(Sh As Worksheet, rng As Range)
Dim cur_L As Integer
cur_L = 1
Sheets("Word_Specifications").Range("BZ9").Copy
Sh.Range(rng.Address).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
With Sheets("Word_Specifications")
.Select
For Each cell In .Range(.Range("Word_Standard_Start").Address, .Range("Word_Standard_Start").End(xlDown).Address)
If cell.value = "" Then
Else
L = Len(cell.value) + 1
With Sh.Range(rng.Address)
With .Characters(start:=cur_L, Length:=L).Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 9
.Bold = False
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
cur_L = cur_L + L
If .value <> "" Then
add_Wingdings cur_L, 1, Sh, rng
cur_L = cur_L + 2
End If
End With
End If
Next
End With
End Sub
Sub add_Wingdings(start As Integer, Length As Integer, Sh As Worksheet, rng As Range)
With Sh.Range(rng.Address).Characters(start:=start, Length:=Length).Font
.Name = "Wingdings 3"
.FontStyle = "Regular"
.Size = 9
.Bold = False
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
End Sub
HTML 标签确实有效。我不知道你为什么说他们没有。
sBody = "All,<br /><br />Please Approve attached request for " & rType & ".<br /><br /><strong>Customer:</strong> " & customer & "<br />"
然后使用 .HTMLBody
而不是 .Body 属性.HTMLBody = sBody