| 网站首页 | 业界新闻 | 小组 | 威客 | 人才 | 下载频道 | 博客 | 代码贴 | 在线编程 | 编程论坛
欢迎加入我们,一同切磋技术
用户名:   
 
密 码:  
共有 3005 人关注过本帖
标题:如何用VB发邮件的内容保持原来的格式
只看楼主 加入收藏
haiyanzi2005
Rank: 1
等 级:新手上路
帖 子:7
专家分:0
注 册:2012-9-17
结帖率:66.67%
收藏
已结贴  问题点数:20 回复次数:5 
如何用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 编辑 ]
搜索更多相关主题的帖子: 收件人 管理员 源代码 邮件 
2012-09-17 10:51
风吹过b
Rank: 20Rank: 20Rank: 20Rank: 20Rank: 20
等 级:贵宾
威 望:364
帖 子:4947
专家分:30084
注 册:2008-10-15
收藏
得分:14 
你可以试试 WORD 的邮件合并功能。

授人于鱼,不如授人于渔
早已停用QQ了
2012-09-17 17:26
haiyanzi2005
Rank: 1
等 级:新手上路
帖 子:7
专家分:0
注 册:2012-9-17
收藏
得分:0 
回复 楼主 haiyanzi2005
我试过word的邮件合并,主要是它不能识别多个收件人,而且没有记录,我都不能知道哪些发送成功了,我用的是OUTlook2010版本的
2012-09-18 09:25
haiyanzi2005
Rank: 1
等 级:新手上路
帖 子:7
专家分:0
注 册:2012-9-17
收藏
得分:0 
回复 2楼 风吹过b
我试过word的邮件合并,主要是它不能识别多个收件人,而且没有记录,我都不能知道哪些发送成功了,我用的是OUTlook2010版本的
2012-09-18 09:25
haiyanzi2005
Rank: 1
等 级:新手上路
帖 子:7
专家分:0
注 册:2012-9-17
收藏
得分: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>您好!<br /> 根据要求,系统组将进行每年一次的清理工作,为了确保邮件系统资源的高效应用,请大家配合以下工作: </BODY></HTML>" & "1, 根据系统记录,您是" & strName & "<HTML><BODY>的管理员,在<font color=red>下周四前(2012.9.20前)</font>回复该邮件,确认该邮件列表是否还在使用;<br />2, 若您已经不再是该邮件列表的管理员请反馈列表的新管理员信息(email地址)。<br />3, 如果在下周四下班前我们未收到回复确认邮件,则视该 邮件列表(群邮箱)不再使用,系统组将在2012.9.28后取消该邮件列表。<br /><br /></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>您好!<br /> 根据要求,系统组将进行每年一次的清理工作,为了确保邮件系统资源的高效应用,请大家配合以下工作: </BODY></HTML>" & "1, 根据系统记录,您是" & strName & "<HTML><BODY>的管理员,在<font color=red>下周四前(2012.9.20前)</font>回复该邮件,确认该邮件列表是否还在使用;<br />2, 若您已经不再是该邮件列表的管理员请反馈列表的新管理员信息(email地址)。<br />3, 如果在下周四下班前我们未收到回复确认邮件,则视该 邮件列表(群邮箱)不再使用,系统组将在2012.9.28后取消该邮件列表。<br /><br /></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>您好!<br /> 根据要求,系统组将进行每年一次的清理工作,为了确保邮件系统资源的高效应用,请大家配合以下工作: </BODY></HTML>" & "1, 根据系统记录,您是" & strName & "<HTML><BODY>的管理员,在<font color=red>下周四前(2012.9.20前)</font>回复该邮件,确认该邮件列表是否还在使用;<br />2, 若您已经不再是该邮件列表的管理员请反馈列表的新管理员信息(email地址)。<br />3, 如果在下周四下班前我们未收到回复确认邮件,则视该 邮件列表(群邮箱)不再使用,系统组将在2012.9.28后取消该邮件列表。<br /><br /></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>您好!<br /> 根据要求,系统组将进行每年一次的清理工作,为了确保邮件系统资源的高效应用,请大家配合以下工作: </BODY></HTML>" & "1, 根据系统记录,您是" & strName & "<HTML><BODY>的管理员,在<font color=red>下周四前(2012.9.20前)</font>回复该邮件,确认该邮件列表是否还在使用;<br />2, 若您已经不再是该邮件列表的管理员请反馈列表的新管理员信息(email地址)。<br />3, 如果在下周四下班前我们未收到回复确认邮件,则视该 邮件列表(群邮箱)不再使用,系统组将在2012.9.28后取消该邮件列表。<br /><br /></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
  
  
  







2012-09-20 17:18
玉面狂龙
Rank: 3Rank: 3
等 级:论坛游侠
帖 子:82
专家分:156
注 册:2012-2-23
收藏
得分:0 
高手啊
2012-09-21 22:38
快速回复:如何用VB发邮件的内容保持原来的格式
数据加载中...
 
   



关于我们 | 广告合作 | 编程中国 | 清除Cookies | TOP | 手机版

编程中国 版权所有,并保留所有权利。
Powered by Discuz, Processed in 0.020491 second(s), 9 queries.
Copyright©2004-2024, BCCN.NET, All Rights Reserved