如何用VB发邮件的内容保持原来的格式 - VB6论坛

已结贴√ 问题点数：20 回复次数：3

如何用VB发邮件的内容保持原来的格式

就是我用OUTLOOK里面的Visul Basic编程，想要群发邮件，邮件的内容有加粗了，变红等格式。如何群发邮件的时候，保持原格式不变呢？
我用了.HTMLBody = strBody ，发现在原来的格式还是没有了。
还有怎么在邮件的内容里面加上一个变量，随着我每封邮件收件人的不同而变化。

大概就是这样一个格式：主题：xxx通知
                      内容：你好，据系统查询你是（变量）的管理员，请在下周四之前回复！

我原来没有学过VB的，只接触过C语言，还请各位大侠解说的仔细一点，谢谢啦~

我搜到了一份源代码跟我要求很相近了，但是我不会改
Public Function SendMail(strFrom As String, strTo As String, _
                                                strCC As String, _
                                                strBCC As String, _
                                                  strSubject As String, _
                                                  strBody As String, _
                                                  strFilename As String _
                                                  ) As Boolean
          Dim oOutlookApp     As New Outlook.Application
          Dim oItemMail     As Outlook.MailItem
          Set oItemMail = oOutlookApp.CreateItem(olMailItem)

          On Error GoTo errHandle
          If Len(Trim(strFilename)) = 0 Then
            With oItemMail
                    '.Recipients
                    .SentOnBehalfOfName = strFrom
                    .To = strTo
                    .CC = strCC
                    .BCC = strBCC
                    .Subject = strSubject
                    .Body = strBody
                    '.Attachments.Add (strFilename)
                    .Importance = olImportanceHigh
                    .Sensitivity = olPersonal
                    .Send
            End With
          Else
            With oItemMail
                  '.Recipients
                  .SentOnBehalfOfName = strFrom
                  .To = strTo
                  .CC = strCC
                  .BCC = strBCC
                  .Subject = strSubject
                  .Body = strBody
                  .Attachments.Add (strFilename)
                  .Importance = olImportanceHigh
                  .Sensitivity = olPersonal0
                  .Send
          End With
          End If

          SendMail = True
          Exit Function
errHandle:
          SendMail = False
  End Function


  Public Function CheckMail(strFrom As String, strTo As String, _
                                                strCC As String, _
                                                strBCC As String, _
                                                  strSubject As String, _
                                                  strBody As String, _
                                                  strFilename As String _
                                                  ) As Boolean
          Dim oOutlookApp     As New Outlook.Application
          Dim oItemMail     As Outlook.MailItem
          Set oItemMail = oOutlookApp.CreateItem(olMailItem)

          On Error GoTo errHandle
          If Len(Trim(strFilename)) = 0 Then
            With oItemMail
                    '.Recipients
                    .SentOnBehalfOfName = strFrom
                    .To = strTo
                    .CC = strCC
                    .BCC = strBCC
                    .Subject = strSubject
                    .HTMLBody = strBody
                    '.Attachments.Add (strFilename)
                    .Importance = olImportanceHigh
                    .Sensitivity = olPersonal
                    .Display
            End With
          Else
            With oItemMail
                  '.Recipients
                  .SentOnBehalfOfName = strFrom
                  .To = strTo
                  .CC = strCC
                  .BCC = strBCC
                  .Subject = strSubject
                  .HTMLBody = strBody
                  .Attachments.Add (strFilename)
                  .Importance = olImportanceHigh
                  .Sensitivity = olPersonal
                  .Display
          End With
          End If

          CheckMail = True
          Exit Function
errHandle:
          CheckMail = False
  End Function

  Sub SendMailNow()

    Dim ExcelSheet As Object
    Dim rowCount As Integer
    Dim i As Integer

    Set ExcelSheet = CreateObject("c:\email.xls")
    rowCount = ExcelSheet.sheets(1).UsedRange.Rows.Count

    For i = 2 To rowCount
        SendMail strFrom:=ExcelSheet.sheets(1).cells(i, 1), strTo:=ExcelSheet.sheets(1).cells(i, 2), _
                  strCC:=ExcelSheet.sheets(1).cells(i, 3), strBCC:=ExcelSheet.sheets(1).cells(i, 4), _
                  strSubject:=ExcelSheet.sheets(1).cells(i, 5), strBody:=ExcelSheet.sheets(1).cells(i, 6), _
                  strFilename:=ExcelSheet.sheets(1).cells(i, 7)
    Next i
    ExcelSheet.Close False
    Set ExcelSheet = Nothing

End Sub

  Sub CheckMailNow()

    Dim ExcelSheet As Object
    Dim rowCount As Integer
    Dim i As Integer

    Set ExcelSheet = CreateObject("c:\email.xls")
    rowCount = ExcelSheet.sheets(1).UsedRange.Rows.Count

    For i = 2 To rowCount
        CheckMail strFrom:=ExcelSheet.sheets(1).cells(i, 1), strTo:=ExcelSheet.sheets(1).cells(i, 2), _
                  strCC:=ExcelSheet.sheets(1).cells(i, 3), strBCC:=ExcelSheet.sheets(1).cells(i, 4), _
                  strSubject:=ExcelSheet.sheets(1).cells(i, 5), strBody:=ExcelSheet.sheets(1).cells(i, 6), _
                  strFilename:=ExcelSheet.sheets(1).cells(i, 7)
    Next i
    ExcelSheet.Close False
    Set ExcelSheet = Nothing

End Sub




[ 本帖最后由 haiyanzi2005 于 2012-9-17 10:54 编辑 ]

第 2 楼

得分:0

回复楼主 haiyanzi2005

我试过word的邮件合并，主要是它不能识别多个收件人，而且没有记录，我都不能知道哪些发送成功了，我用的是OUTlook2010版本的

第 3 楼

得分:0

回复 2楼风吹过b

我试过word的邮件合并，主要是它不能识别多个收件人，而且没有记录，我都不能知道哪些发送成功了，我用的是OUTlook2010版本的

第 4 楼

得分:0

我自己琢磨了几天，最终改成了下面这个样子，大家可以自己做一个excel表格，然后把下面的程序拷到Outlook里vb中，就可以实现群发邮件，并且文字保留原来的格式。就是有一个小Bug,由于本人不知道怎么在HTML里面加入已经定义的变量strName，所以用&联结了两个HTMLBody,结果它就会自动转行，运行出来的结果变成了：
您好！
根据要求，系统组将进行每年一次的清理工作，为了确保邮件系统资源的高效应用，请大家配合以下工作：
1，根据系统记录，您是变量（这里会换行）
的管理员，在下周四前（2012.9.20前）回复该邮件，确认该邮件列表是否还在使用；

有没有好心人帮帮忙告诉我怎么改呢？

Public Function SendMail(strFrom As String, strTo As String, _
 strCC As String, _
 strBCC As String, _
 strSubject As String, _
 strBody As String, _
 strFilename As String, _
 strName As String _
 ) As Boolean
 Dim oOutlookApp As New Outlook.Application
 Dim oItemMail As Outlook.MailItem
 Set oItemMail = oOutlookApp.CreateItem(olMailItem)

 On Error GoTo errHandle
 If Len(Trim(strFilename)) = 0 Then
 With oItemMail
 '.Recipients
 .SentOnBehalfOfName = strFrom
 .To = strTo
 .CC = strCC
 .BCC = strBCC
 .Subject = strSubject
 .HTMLBody = "<HTML><BODY>您好！ 根据要求，系统组将进行每年一次的清理工作，为了确保邮件系统资源的高效应用，请大家配合以下工作： </BODY></HTML>" & "1，根据系统记录，您是" & strName & "<HTML><BODY>的管理员，在下周四前（2012.9.20前）回复该邮件，确认该邮件列表是否还在使用； 2，若您已经不再是该邮件列表的管理员请反馈列表的新管理员信息(email地址)。 3，如果在下周四下班前我们未收到回复确认邮件，则视该邮件列表(群邮箱)不再使用，系统组将在2012.9.28后取消该邮件列表。 </BODY></HTML>"
 '.Attachments.Add (strFilename)
 .Importance = olImportanceHigh
 .Sensitivity = olPersonal
 .Send
 End With
 Else
 With oItemMail
 '.Recipients
 .SentOnBehalfOfName = strFrom
 .To = strTo
 .CC = strCC
 .BCC = strBCC
 .Subject = strSubject
 .HTMLBody ="<HTML><BODY>您好！ 根据要求，系统组将进行每年一次的清理工作，为了确保邮件系统资源的高效应用，请大家配合以下工作： </BODY></HTML>" & "1，根据系统记录，您是" & strName & "<HTML><BODY>的管理员，在下周四前（2012.9.20前）回复该邮件，确认该邮件列表是否还在使用； 2，若您已经不再是该邮件列表的管理员请反馈列表的新管理员信息(email地址)。 3，如果在下周四下班前我们未收到回复确认邮件，则视该邮件列表(群邮箱)不再使用，系统组将在2012.9.28后取消该邮件列表。 </BODY></HTML>"
 .Attachments.Add (strFilename)
 .Importance = olImportanceHigh
 .Sensitivity = olPersonal0
 .Send
 End With
 End If

 SendMail = True
 Exit Function
errHandle:
 SendMail = False
 End Function


 Public Function CheckMail(strFrom As String, strTo As String, _
 strCC As String, _
 strBCC As String, _
 strSubject As String, _
 strBody As String, _
 strFilename As String, _
 strName As String _
 ) As Boolean
 Dim oOutlookApp As New Outlook.Application
 Dim oItemMail As Outlook.MailItem
 Set oItemMail = oOutlookApp.CreateItem(olMailItem)

 On Error GoTo errHandle
 If Len(Trim(strFilename)) = 0 Then
 With oItemMail
 '.Recipients
 .SentOnBehalfOfName = strFrom
 .To = strTo
 .CC = strCC
 .BCC = strBCC
 .Subject = strSubject
 .HTMLBody = "<HTML><BODY>您好！ 根据要求，系统组将进行每年一次的清理工作，为了确保邮件系统资源的高效应用，请大家配合以下工作： </BODY></HTML>" & "1，根据系统记录，您是" & strName & "<HTML><BODY>的管理员，在下周四前（2012.9.20前）回复该邮件，确认该邮件列表是否还在使用； 2，若您已经不再是该邮件列表的管理员请反馈列表的新管理员信息(email地址)。 3，如果在下周四下班前我们未收到回复确认邮件，则视该邮件列表(群邮箱)不再使用，系统组将在2012.9.28后取消该邮件列表。 </BODY></HTML>"
 '.Attachments.Add (strFilename)
 .Importance = olImportanceHigh
 .Sensitivity = olPersonal
 .Display
 End With
 Else
 With oItemMail
 '.Recipients
 .SentOnBehalfOfName = strFrom
 .To = strTo
 .CC = strCC
 .BCC = strBCC
 .Subject = strSubject
 .HTMLBody = "<HTML><BODY>您好！ 根据要求，系统组将进行每年一次的清理工作，为了确保邮件系统资源的高效应用，请大家配合以下工作： </BODY></HTML>" & "1，根据系统记录，您是" & strName & "<HTML><BODY>的管理员，在下周四前（2012.9.20前）回复该邮件，确认该邮件列表是否还在使用； 2，若您已经不再是该邮件列表的管理员请反馈列表的新管理员信息(email地址)。 3，如果在下周四下班前我们未收到回复确认邮件，则视该邮件列表(群邮箱)不再使用，系统组将在2012.9.28后取消该邮件列表。 </BODY></HTML>"
 .Attachments.Add (strFilename)
 .Importance = olImportanceHigh
 .Sensitivity = olPersonal
 .Display
 End With
 End If

 CheckMail = True
 Exit Function
errHandle:
 CheckMail = False
 End Function

 Sub SendMailNow()

 Dim ExcelSheet As Object
 Dim rowCount As Integer
 Dim i As Integer

 Set ExcelSheet = CreateObject("c:\email.xls")
 rowCount = ExcelSheet.sheets(1).UsedRange.Rows.Count

 For i = 2 To rowCount
 SendMail strFrom:=ExcelSheet.sheets(1).cells(i, 1), strTo:=ExcelSheet.sheets(1).cells(i, 2), _
 strCC:=ExcelSheet.sheets(1).cells(i, 3), strBCC:=ExcelSheet.sheets(1).cells(i, 4), _
 strSubject:=ExcelSheet.sheets(1).cells(i, 5), strBody:=ExcelSheet.sheets(1).cells(i, 6), _
 strFilename:=ExcelSheet.sheets(1).cells(i, 7), strName:=ExcelSheet.sheets(1).cells(i, 8)
 Next i
 ExcelSheet.Close False
 Set ExcelSheet = Nothing

End Sub

 Sub CheckMailNow()

 Dim ExcelSheet As Object
 Dim rowCount As Integer
 Dim i As Integer

 Set ExcelSheet = CreateObject("c:\email.xls")
 rowCount = ExcelSheet.sheets(1).UsedRange.Rows.Count

 For i = 2 To rowCount
 CheckMail strFrom:=ExcelSheet.sheets(1).cells(i, 1), strTo:=ExcelSheet.sheets(1).cells(i, 2), _
 strCC:=ExcelSheet.sheets(1).cells(i, 3), strBCC:=ExcelSheet.sheets(1).cells(i, 4), _
 strSubject:=ExcelSheet.sheets(1).cells(i, 5), strBody:=ExcelSheet.sheets(1).cells(i, 6), _
 strFilename:=ExcelSheet.sheets(1).cells(i, 7), strName:=ExcelSheet.sheets(1).cells(i, 8)


 Next i
 ExcelSheet.Close False
 Set ExcelSheet = Nothing

End Sub