📄 modexport2html.bas
字号:
Attribute VB_Name = "ModExport2Html"
Option Explicit
'**************************************************************
'*模块名称：ModExport2Html
'*模块功能：输出到Html文件
'*说明：
'*
'*备注：
'*
'*作者：progame
'*日期：2002-05-08 10:51:19
'***************************************************************
Private Const ModalName = "ModExport2Html"
'**************************************************************
'*名称：funExport2Html
'*功能：输出到Html超文本文件
'*传入参数：
'* rpt --报表对象
'* filepath --文件夹位置
'* pFrom --页起始
'* pTo --页终止
'* sRate --缩放比例
'* bMultypage --是否生成多个Html文件
'*返回参数：
'* 是否输出成功
'*作者：progame
'*日期：2002-05-08 15:11:42
'***************************************************************
Public Function funExport2Html(rpt As Report, _
filepath As String, _
pFrom As Integer, pTo As Integer, _
sRate As Single, _
Optional bMultypage As Boolean = False) _
As Boolean
Dim fn As Integer
Dim str As String
fn = FreeFile()
If Dir(filepath) <> "" Then
Kill filepath
End If
Open filepath For Output As #fn
'*输出页面头
str = "<html><head><meta http-equiv='Content-Language' content='zh-cn'>" _
& "<meta http-equiv='Content-Type' content='text/html; charset=gb2312'></head>" _
& "<body topmargin='" & CInt(rpt.TopMargin / UNIT) _
& "' leftmargin='" & CInt(rpt.LeftMargin / UNIT) & "'>"
Print #fn, str
Dim page As Integer
Dim cutpage As Integer
For page = pFrom To pTo
For cutpage = 1 To rpt.cutpages
'*输出页头表头
str = WriteCollection(rpt.Title, Landscape, rpt.pages, rpt.cutpages, page, cutpage, rpt.width)
Print #fn, str
str = WriteCollection(rpt.Header, Landscape, rpt.pages, rpt.cutpages, page, cutpage, rpt.width)
Print #fn, str
'*输出表体的外围表格
str = "<table border=0 width=" & CInt(rpt.width / UNIT * 2) & "><tr>" _
& "<td width='" & rpt.LeftSection.GetWidth & "'>"
Print #fn, str
'*在此输出页左
str = WriteCollection(rpt.LeftSection, Portrait, rpt.pages, rpt.cutpages, page, cutpage)
Print #fn, str
str = "</td><td>"
Print #fn, str
'*在此输出表体
str = WriteReport(rpt, pFrom, 1)
Print #fn, str
str = "</td><td width='" & rpt.RightSection.GetWidth & "'>"
Print #fn, str
'*在此输出页右
str = WriteCollection(rpt.RightSection, Portrait, rpt.pages, rpt.cutpages, page, cutpage)
Print #fn, str
str = "</td></table>"
Print #fn, str
'*输出表尾页尾
str = WriteCollection(rpt.Footer, Landscape, rpt.pages, rpt.cutpages, page, cutpage, rpt.width)
Print #fn, str
str = WriteCollection(rpt.Tail, Landscape, rpt.pages, rpt.cutpages, page, cutpage, rpt.width)
Print #fn, str
Next cutpage
Next page
'*输出页面尾
str = "</body></html>"
Print #fn, str
Close #fn
End Function
'**************************************************************
'*名称：WriteCollection
'*功能：返回一个标签集合转换到html的字符串
'*传入参数：
'* obj --标签集合
'*返回参数：
'* 转换到html的字符串
'*作者：progame
'*日期：2002-05-08 16:04:48
'**************************************************************
Private Function WriteCollection(obj As clsCollection, orient As typeOrient, _
pages As Integer, cutpages As Integer, _
page As Integer, cutpage As Integer, _
Optional width As Single) As String
'*输出表格的头部
On Error GoTo err_proc
If orient = Landscape Then
WriteCollection = "<table border=0 width=" & width / UNIT * 2 & ">"
Else
WriteCollection = "<table border=0><tr>"
End If
'*输出标签集合
Dim cText
Dim leftStr As String
Dim rightStr As String
Dim str As String
Dim tStr As String
Dim i As Integer
For Each cText In obj.texts.Items
With cText
GetTextLR cText, leftStr, rightStr
If orient = Landscape Then
leftStr = "<tr><td>" & leftStr
rightStr = rightStr & "</td></tr>"
Else
leftStr = "<td width=" & CInt(width / UNIT * 2) & ">" & leftStr
rightStr = rightStr & "</td>"
End If
str = rplStr(.stringX, pages, cutpages, page, cutpage)
If orient = Portrait Then '*竖向标签的输出
For i = 1 To Len(str)
tStr = tStr & Mid(str, i, 1) & "<br>"
Next i
str = tStr
End If
WriteCollection = WriteCollection & leftStr & str & rightStr
End With
Next
'*输出表格的尾部
If orient = Portrait Then
WriteCollection = WriteCollection & "</tr>"
End If
WriteCollection = WriteCollection & "</table>"
Exit Function
'*错误处理
err_proc:
WriteCollection = ""
End Function
'**************************************************************
'*名称：WriteReport
'*功能：输出表体
'*传入参数：
'* rpt --报表对象
'* page --当前页
'* cutpage --当前分页
'*返回参数：
'* 转换的Html字符
'*作者：progame
'*日期：2002-05-08 19:43:44
'***************************************************************
Private Function WriteReport(rpt As Report, page As Integer, cutpage As Integer) As String
On Error GoTo err_proc
'*输出列头
Dim cell
Dim i As Integer
Dim str As String
Dim leftStr As String
Dim rightStr As String
Dim minCol As Single
i = 0
str = "<table border=1cellspacing=1 cellpadding=0 style='BORDER-COLLAPSE: collapse'><tr>"
For Each cell In rpt.ColHeader.GetMergeCells.Items
If cell.cutpage = cutpage Then
i = i + 1
With cell
If i = 1 Then
minCol = .colFrom
End If
If .colFrom = minCol And i <> 1 Then '*需要输出新行
str = str & "</tr><tr>"
End If
'*输出此单元格
GetTextLR .Text, leftStr, rightStr
str = str & "<td width=" & CInt(.Text.width / UNIT * 2) & " " _
& "rowspan=" & (.rowTo - .rowFrom + 1) & " " _
& "colspan=" & (.colTo - .colFrom + 1) & ">" _
& leftStr & fmtStr(.Text.GetStr) & rightStr & "</td>"
End With
End If
Next
str = str & "</tr></tr>"
'*输出正文
Dim cellnew
Dim cText As clsText
i = 0
For Each cellnew In rpt.Content.GetMergeCell(page, cutpage).Items
'*先将此页的所有单元格读到二维数组
With cellnew
End With
i = i + 1
With cellnew
Set cText = rpt.Content.GetColText(.colFrom)
If i = 1 Then
minCol = .colFrom
End If
If .colFrom = minCol And i <> 1 Then '*需要输出新行
str = str & "</tr><tr>"
End If
'*输出此单元格
GetTextLR cText, leftStr, rightStr
cText.stringX = .stringX
str = str & "<td width=" & CInt(cText.width / UNIT * 2) & " " _
& "rowspan=" & (.rowTo - .rowFrom + 1) & ">" _
& leftStr & fmtStr(cText.GetStr) & rightStr & "</td>"
End With
Next
str = str & "</tr></table>"
WriteReport = str
Exit Function
'*错误处理
err_proc:
WriteReport = ""
End Function
Private Sub GetTextLR(cText, leftStr As String, rightStr As String)
'*输出字体和颜色
With cText
leftStr = ""
rightStr = ""
Select Case .Align
Case tyLeft
Case tymiddle
leftStr = "<p align='center'>"
Case tyRight
leftStr = "<p align='right'>"
End Select
Dim strName As String
Dim strSize As String
Dim strColor As String
If .FontName <> "宋体" Then
strName = " face=" & .FontName
End If
If .FontSize < 8 Or .FontSize > 9 Then
strSize = " size=" & .FontSize / 4
End If
strColor = " color=#" & Hex(.ForeColor)
If strName <> "" Or strSize <> "" Or strColor <> "" Then
leftStr = leftStr & "<font" & strName & strSize & strColor & ">"
rightStr = "</font>"
End If
If .FontBold Then
leftStr = leftStr & "<b>"
rightStr = "</b>" & rightStr
End If
If .FontItalic Then
.leftStr = leftStr & "<i>"
rightStr = "</i>" & rightStr
End If
If .FontStrikethru Then
leftStr = leftStr & "<strike>"
rightStr = "</strike>" & rightStr
End If
If .FontUnderline Then
leftStr = leftStr & "<u>"
rightStr = "</u>" & rightStr
End If
End With
End Sub
'**************************************************************
'*名称：
'*功能：
'*传入参数：
'*
'*返回参数：
'*
'*作者：progame
'*日期：2002-05-08 23:04:46
'***************************************************************
Private Function fmtStr(mstr As String) As String
'/*将空格替换成 <替换为<,>替换成>,"替换为"&替换为&
Dim str
str = mstr
str = Replace(str, "&", "&")
str = Replace(str, " ", " ")
str = Replace(str, "<", "<")
str = Replace(str, ">", ">")
str = Replace(str, """", """)
str = Replace(str, vbCrLf, "<br>")
'/*将'号换成''
str = Replace(str, "'", "''")
fmtStr = str
End Function
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -