求帮忙补充将表格边框线转换成HTML的代码

antique_star

以下代码是我在网上搜的，能正确将表格区域内容放入到邮件内容中，但是没有表格线，我的要求不高，有边框线就行，没有粗细格式。请帮忙补充一下局部代码：
我实在是年纪大了，学点VB已经够呛了，HTML编码看得一头雾水。拜托了。

1. 
   

复制代码

Public Function RangetoHTML(rng As Range) '建立自定义函数RangetoHTML
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
  .Cells(1).PasteSpecial Paste:=8
  .Cells(1).PasteSpecial Paste:=xlPasteAll
  .Cells(1).Select
  Application.CutCopyMode = False
  On Error Resume Next
  .DrawingObjects.Visible = True
  .DrawingObjects.Delete
  On Error GoTo 0
End With
With TempWB.PublishObjects.Add( _
  SourceType:=xlSourceRange, _
  Filename:=TempFile, _
  Sheet:=TempWB.Sheets(1).Name, _
  Source:=TempWB.Sheets(1).UsedRange.Address, _
  HtmlType:=xlHtmlStatic)
  .Publish (True)
End With
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
   "align=left x:publishsource=")
TempWB.Close savechanges:=False
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function

antique_star

第一回遭遇冷板凳，好失落！
是这个问题有点难？
还是……
居然连路过的都没有！

antique_star

无人问津，就自己来吧。把我自己硬逼上梁山学超级文件的历程写出来吧：

超级文本（Html）的编码规则

所有代码由三类构成：标签符、属性值、元素。

标签符通过<></>这种格式成对出现，无斜杠的叫启始标签，后面有斜杠的叫结束标签。所有被成对标签夹住的内容都可以视为一个对象，这些对象的通用属性值（如边框线、线的宽度、颜色等）代码写在启始标签中，至于哪些是单元属性，哪些是行通用属性，哪些是表格通用属性，则根据用户的喜好和程序的限制来，不是你想象的那样，只能自己去一次次测试。实在不知道的属性就可以去百度搜，懂了超级文本的语法基础，搜起来就容易些，比如我想知道表格底色的属性怎么写？因为有VB的基础，所以我会立马想到Background=各颜色值，但超级文本中是这样的：Background-color: Lightskyblue。那么在搜百度时你可以搜“超级文本表格背景颜色属性”，否则会搜得很辛苦。下面内容请认真读完：

新手训练方法：所有超级文本的代码写在“文本文件”中，写完代码将后缀改成“.html”打开就是网页效果。

表格标签：<table></table>

表格行标签：<tr></tr>

每个最小表格（也可以叫元素）标签：<td></td>

书写规则（下面代码中的单元格内容就是最小的元素）：

<table><tr><td>单元格首行内容1</td><td>单元格首行内容2</td></tr></table>这个表格只有一行，两个单元格

<table><tr><td>单元格首行内容1</td><td>单元格首行内容2</td></tr><tr><td>单元格第二行内容1</td><td>单元格第二行内容2</td></tr></table>这个表格有两行，四个单元格

代码：<table><tr><td>姓名</td><td>性别</td></tr></table>  显示效果如下：

代码：<tableBorder='1'><tr><td>姓名</td><td>性别</td></tr></table>  显示效果如下：

代码：<tableBorder='1'><tr><td>姓名</td><td>性别</td></tr><tr><td>张三</td><td>男</td></tr></table>  显示效果如下：

文本段落标签<p></p>

文本行标签<br></br>

文本书写跟上面表格的书写规则一样，唯一不同的是，单元格内容换成你要输出的文本的全部内容，你唯一要做的是在哪里分段？在哪里换行？分段与换行显示效果不一样，换行行间距紧密一些，分段后段与段之间差不多隔了一行的宽度。

好了，我们不是专业编程，不需要了解太多。有继续想知道的请在网上自学，因为上面是我本人的学习全过程，代码只有测试修改重复测试才能领悟，师傅领进门，修行就各靠各了。对于我们VB做点小工具，上面的基础知识就足够了。

下面我们回到如何发工资条的问题上来，

网上搜的那些都会通过自定义函数的方式来转化你的表格，首先我们看不懂，再次搬别人的来用，一出问题自己解决不了。而且每个人的需求风格不一样，不能完全照搬，自己掌握了就最好，所以咱们就用最熟悉最笨最原始最有效最简单的方法。

自己直接编译超级文本代码，将代码以string变量传输给.HTMLBody，前提别忘了这句：.BodyFormat= olFormatHTML

别看超级文本的代码又臭又长，很容易把自己搞混，但是如果你有清晰的方法和逻辑一样不会乱。

比如工资条，我们可以让程序一个一个单元格去读取表格的数据，我们有一个标题行在行循环时不动，动的只是每个人的表体行，这个用For可以解决，再次，不论表体行还是标题行，都要进行列循环（根据每家公司工资表的列数定），这个也用For解决，不论我们如何进行行列循环，我们始终要得到一段完整的超级文本代码，这个代码有些代码是动态的，有些代码是静态的，如何解决？我们可以这样，将这个代码分割。

注意：以下代码我写在一行，但并不一定是一行，VBA基础不懂的我就没法教了。还有，VBA是双引号确定文本，所以超级文本的中双引号，全部换成单引号，否则程序如何知道你的文本界定在哪呢？这一点在网上可坑爹了，我是自己运行报错悟出来的，网上没见一个人提醒。

1、开始公用部分（GY）：dim GY as string GY="<TableBorder='1' Bordercolor='#000000' Cellspacing='0' Cellpadding='2' Style='Border-collapse:collapse;'>"

2、结束说明部分（SM）：dim SM as string SM ="</Table><P>温馨提示：如您对工资信息有疑问，项目部请和直接上司核实，其他后勤部门请直接与财务部联系。</P>"

3、工资标题部分（TI）：dim TI as string TI="<TRSpan style='Font-size:12px;Background-color: Lightskyblue;'>"

4、工资表体部分（BT）：dim BT as string BT="<TR Span style='Font-size:12px;'>"

前面两个是不需要参与循环的，只需要在每次发送邮件时用&符号连入就行。后面两个需要参与循环：

1、在进行列循环时，每次读到一个单元格数据都在后面连上一个单元结束标签〈/td〉

表头：TI = TI &"<Td Align='Center'>" & Cells(2, i) &"</TD>"

表体：BT =BT&"<Td Align='Center'>" & Cells(UCSI2, UCEI) &"</TD>"

2、在进行行循环时，每结束一行，都连上一个行结束标签〈/TR〉

表头：TI = TI &"</TR>"

表体：BT =BT&"</TR>"

最后是不是所有单元格读完了要加上一个表格结束标签</Table>呢？当然，不过这个不用循环，我在上面的表格结尾说明的字符里已经有了，不信上去看看。

最后我们就得到了.HTMLBody＝GY & TI & BT & SM成功了！

真的很开心，虽然当时已经是晚上一点多，很开心。开心就想到分享，但当时太困，等有空了一定分享出去。

于是就等到了今天。

闻启学

antique_star 发表于 2015-3-27 17:26
无人问津，就自己来吧。把我自己硬逼上梁山学超级文件的历程写出来吧： 超级文本（Html）的编码规则所有代 ...

恭喜楼主  看看我是来迟了

antique_star

没事。做人始终要知道一个道理：别人帮你是好心，不帮你是正道。
关键是要有一颗无私和充满爱的心，
千万不要自己所遭遇的事情希望下一个也同样遭遇一下，这样来获得心理平衡。
一个具有良好心态的人，是不希望别人重蹈自己的遭遇，就象马路骑车掉了坑，爬起来不是想着自己的伤痛，而是应该想着下一个可能还会掉。
永远感谢一路上支持帮助我的所有人！

wal4585

太谢谢你 找了几个月 终于找到我需要的了

32004726

antique_star 发表于 2015-3-27 17:26
无人问津，就自己来吧。把我自己硬逼上梁山学超级文件的历程写出来吧： 超级文本（Html）的编码规则所有 ...

有没有完整的代码，供学习一下，谢谢！

cowbear123

楼主  几年前了  你还在不在，我和你遇到的问题简直一模一样，就是发送的邮件没有表格，看着很不安逸

antique_star

时间过去多年，
当初的那点研究激情已踪影全无。
找回当时开发的小工具，
由于涉及公司机密，
所以只贴出部分代码，
供同行研究：

1. Private Sub CommandButton1_Click()
   
2. On Error Resume Next
   
3. Dim OUT1 As Outlook.Application
   
4. Dim OUTItem As Outlook.MailItem
   
5. Dim ZT As String
   
6. Dim RowT As Long
   
7. RowT = [D10000].End(xlUp).Row '获取D列最后一个非空行
   
8. 
   
9. If OptionButton1 = False And OptionButton2 = False Then
   
10.   MsgBox "请选择要发送的工资表再点确定！", vbInformation, "乐天工作室：温馨提示！"
    
11. 
    
12. ElseIf OptionButton1 = True Then
    
13.   Unload Me
    
14.   Dim UCr As Long
    
15.   UCr = Sheets("物业工资表").UsedRange.Find("合计").Row - 1
    
16.   Dim UCI1 As Long
    
17.   Dim Show2 As String
    
18.   Show2 = "第二步：工资名单是否都有E-mail检查。以下人员找不到邮箱：" & Chr(13) & Chr(13)
    
19.   For UCI1 = 3 To UCr
    
20.     Dim UCI2 As Long
    
21.     For UCI2 = 3 To RowT
    
22.       If Sheets("物业工资表").Cells(UCI1, 3) = Cells(UCI2, 4) Then Exit For
    
23.     Next
    
24.     If UCI2 = RowT + 1 Then
    
25.       Show2 = Show2 & Sheets("物业工资表").Cells(UCI1, 3) & Chr(13)
    
26.     End If
    
27.   Next
    
28.   If Show2 <> "第二步：工资名单是否都有E-mail检查。以下人员找不到邮箱：" & Chr(13) & Chr(13) Then
    
29.     MsgBox Show2 & Chr(13) & Chr(13) _
    
30.            & "请将上述邮箱补齐后，重新点击发送！" & Chr(13) _
    
31.            , vbCritical, "乐天工作室温馨提示："
    
32.     Exit Sub
    
33.   Else
    
34.     MsgBox "第二步：工资名单是否都有E-mail检查顺利通过！" & Chr(13) & Chr(13) & _
    
35.            "〖点击确定后正式开始发送……〗", vbInformation, "乐天工作室温馨提示："
    
36.   
    
37.    '===<开始发送工资表>===
    
38.     Application.ScreenUpdating = False
    
39.     Sheets("物业工资表").Activate
    
40.     ZT = Cells(3, 1) & "年" & Cells(3, 2) & "工资条【改进版】"
    
41.     Dim GYtable, Biaotou, Biaoti, Shuomi As String
    
42.     GYtable = "<Table Border='1' Bordercolor='#000000' Cellspacing='0' Cellpadding='2' Style='Border-collapse:collapse;'>"
    
43.     Shuomi = "</Table><P>温馨提示：如您对工资信息有疑问，项目部请和直接上司核实，其他后勤部门请直接与财务部李仲明联系。</P>" & _
    
44.              "<P>亲们，本邮件由电脑自动发送！如若不能直接看到最后一列请参阅如下指引：<BR>" & _
    
45.              "由于工资条较宽，QQ邮箱没有横向的滑动条，所以工资条后面的内容无法直接查看，为了解决这个问题，给你提供三个解决方法：</P>" & _
    
46.              "1、按住Ctrl键，同时滚动鼠标滑轮来控制邮箱页面的字体大小，直到全部看到最后一列“公司支付社保成本”；<BR>" & _
    
47.              "2、在打开邮件的页面直接点击“回复”，在回复邮件状态QQ邮箱是有横向滑动条的，此时可以查看正文下面的全部内容了；<BR>" & _
    
48.              "3、安装一个Foxmail邮箱客户端，可设置任何邮箱账号收发。有默认横向滑动条查看超宽页面，并且显示效果也最保真。</P></BODY>"
    
49.     Dim UCSI1, UCSI2 As Long
    
50.     Dim MANA As String
    
51.     For UCSI2 = 3 To UCr
    
52.       For UCSI1 = 3 To RowT
    
53.         If Sheets("通讯录").Cells(UCSI1, 4) = Cells(UCSI2, 3) Then
    
54.           MANA = Sheets("通讯录").Cells(UCSI1, 5)
    
55.           Exit For
    
56.         End If
    
57.       Next
    
58.       Biaotou = "<TR Span style='Font-size:12px;Background-color: Lightskyblue;'>"
    
59.       Biaoti = "<TR Span style='Font-size:12px;'>"
    
60.       Dim UCEI As Long
    
61.       For UCEI = 1 To 33
    
62.         Biaotou = Biaotou & "<Td Align='Center'>" & Cells(2, UCEI) & "</TD>"
    
63.         Biaoti = Biaoti & "<Td Align='Center'>" & Cells(UCSI2, UCEI) & "</TD>"
    
64.       Next
    
65.       Biaotou = Biaotou & "</TR>"
    
66.       Biaoti = Biaoti & "</TR>"
    
67.       Set OUT1 = New Outlook.Application
    
68.       Set OUTItem = OUT1.CreateItem(olMailItem)
    
69.       With OUTItem
    
70.           .To = MANA
    
71.           .Subject = ZT
    
72.           .BodyFormat = olFormatHTML
    
73.           .HTMLBody = GYtable & Biaotou & Biaoti & Shuomi
    
74.           .Send
    
75.       End With
    
76.       Set OUTItem = Nothing
    
77.       Set OUT1 = Nothing
    
78.       Biaotou = ""
    
79.       Biaoti = ""
    
80.     Next
    
81.   End If
    
82.   Sheets("通讯录").Activate
    
83.   MsgBox "物业工资条Excel已全部向Outlook发送了【自动发送】指令，是否发送完毕请查看Outlook的“已发送邮件”文件夹！", _
    
84.          vbInformation, "乐天工作室温馨提示："
    
85.   Application.ScreenUpdating = True
    
86. ElseIf OptionButton1 = False Then
    
87.   Unload Me
    
88.   Dim LGr As Long
    
89.   LGr = Sheets("优乐购工资表").UsedRange.Find("合计").Row - 1
    
90.   Dim LGI1 As Long
    
91.   Dim Show3 As String
    
92.   Show3 = "第二步：工资名单是否都有E-mail检查。以下人员找不到邮箱：" & Chr(13) & Chr(13)
    
93.   For LGI1 = 3 To LGr
    
94.     Dim LGI2 As Long
    
95.     For LGI2 = 3 To RowT
    
96.       If Sheets("优乐购工资表").Cells(LGI1, 3) = Cells(LGI2, 4) Then Exit For
    
97.     Next
    
98.     If LGI2 = RowT + 1 Then
    
99.       Show3 = Show3 & Sheets("优乐购工资表").Cells(LGI1, 3) & Chr(13)
    
100.     End If
     
101.   Next
     
102.   If Show3 <> "第二步：工资名单是否都有E-mail检查。以下人员找不到邮箱：" & Chr(13) & Chr(13) Then
     
103.     MsgBox Show3 & Chr(13) & Chr(13) _
     
104.            & "请将上述邮箱补齐后，重新启动程序！" & Chr(13) _
     
105.            , vbCritical, "乐天工作室温馨提示："
     
106.     Exit Sub
     
107.   Else
     
108.     MsgBox "第二步：工资名单是否都有E-mail检查顺利通过！" & Chr(13) & Chr(13) & _
     
109.            "〖点击确定后正式开始发送……〗", vbInformation, "乐天工作室温馨提示："
     
110.   
     
111.    '===<开始发送工资表>===
     
112.     Application.ScreenUpdating = False
     
113.     Sheets("优乐购工资表").Activate
     
114.     ZT = Cells(3, 1) & "年" & Cells(3, 2) & "工资条【改进版】"
     
115.     GYtable = "<Table Border='1' Bordercolor='#000000' Cellspacing='0' Cellpadding='2' Style='Border-collapse:collapse;'>"
     
116.     Shuomi = "</Table><P>温馨提示：如您对工资信息有疑问，项目部请和直接上司核实，其他后勤部门请直接与财务部李仲明联系。</P>" & _
     
117.              "<P>亲们，本邮件由电脑自动发送！如若不能直接看到最后一列请参阅如下指引：<BR>" & _
     
118.              "由于工资条较宽，QQ邮箱没有横向的滑动条，所以工资条后面的内容无法直接查看，为了解决这个问题，给你提供三个解决方法：</P>" & _
     
119.              "1、按住Ctrl键，同时滚动鼠标滑轮来控制邮箱页面的字体大小，直到全部看到最后一列“公司支付社保成本”；<BR>" & _
     
120.              "2、在打开邮件的页面直接点击“回复”，在回复邮件状态QQ邮箱是有横向滑动条的，此时可以查看正文下面的全部内容了；<BR>" & _
     
121.              "3、安装一个Foxmail邮箱客户端，可设置任何邮箱账号收发。有默认横向滑动条查看超宽页面，并且显示效果也最保真。</P></BODY>"
     
122.     Dim LGSI1, LGSI2 As Long
     
123.     For LGSI2 = 3 To LGr
     
124.       For LGSI1 = 3 To RowT
     
125.         If Sheets("通讯录").Cells(LGSI1, 4) = Cells(LGSI2, 3) Then
     
126.           MANA = Sheets("通讯录").Cells(LGSI1, 5)
     
127.           Exit For
     
128.         End If
     
129.       Next
     
130.       Biaotou = "<TR Span style='Font-size:12px;Background-color: Lightskyblue;'>"
     
131.       Biaoti = "<TR Span style='Font-size:12px;'>"
     
132.       Dim LGEI As Long
     
133.       For LGEI = 1 To 26
     
134.         Biaotou = Biaotou & "<Td Align='Center'>" & Cells(2, LGEI) & "</TD>"
     
135.         Biaoti = Biaoti & "<Td Align='Center'>" & Cells(LGSI2, LGEI) & "</TD>"
     
136.       Next
     
137.       Biaotou = Biaotou & "</TR>"
     
138.       Biaoti = Biaoti & "</TR>"
     
139.       Set OUT1 = New Outlook.Application
     
140.       Set OUTItem = OUT1.CreateItem(olMailItem)
     
141.       With OUTItem
     
142.           .To = MANA
     
143.           .Subject = ZT
     
144.           .BodyFormat = olFormatHTML
     
145.           .HTMLBody = GYtable & Biaotou & Biaoti & Shuomi
     
146.           .Send
     
147.       End With
     
148.       Set OUTItem = Nothing
     
149.       Set OUT1 = Nothing
     
150.       Biaotou = ""
     
151.       Biaoti = ""
     
152.     Next
     
153.   End If
     
154.   Sheets("通讯录").Activate
     
155.   MsgBox "物业工资条Excel已全部向Outlook发送了【自动发送】指令，是否发送完毕请查看Outlook的“已发送邮件”文件夹！", _
     
156.          vbInformation, "乐天工作室温馨提示："
     
157.   Application.ScreenUpdating = True
     
158. End If
     
159. End Sub

复制代码

rinto

樓主，感謝你的無私分享，學習了