Excel生成网页文件

seeyoutime

Excel生成网页文件
Sub CommandButton1_Click()
    Call FileYN
    Call WFileTop
    n = 4
    For i = 0 To 100000
        Sheets(1).Cells(1, 1) = n    '位置变量
        '写分类标签
        If Sheets(1).Cells(n, 2) <> "" And Sheets(1).Cells(n, 3) <> "" Then
            If Sheets(1).Cells(n, 2) = "分类名" Then Call WType
            n = n + 1
            Sheets(1).Cells(1, 1) = n    '位置变量
        End If
        '写网址名
        If Sheets(1).Cells(n, 3) <> "" And Sheets(1).Cells(n, 2) = "" Then
            Call WFile
        End If
        n = Sheets(1).Cells(1, 1)    '位置变量
        If Sheets(1).Cells(n, 3) = "" And Sheets(1).Cells(n, 2) = "" Then GoTo 10
    Next
10  Call WFilefoot
    MsgBox "ok"
    Sheets(1).Cells(1, 1) = ""
End Sub
Sub WType()    '写入网址分类,单独一行
    Dim fso, MyFile
    Filename = ThisWorkbook.Path & "\" & "index.html"
    n = Sheets(1).Cells(1, 1)
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set MyFile = fso.OpenTextFile(Filename, 8)
    MyFile.Writeline ("  <TR align=left bgColor=#ffffff>")
    MyFile.Writeline ("     <TD class=tbl_head colSpan=4 height=18><A><IMG height=6 src=""网址导航.files/dot3.gif"" width=3>&nbsp;<SPAN  class=f_l>")
    MyFile.Writeline Sheets(1).Cells(n, 3)
    MyFile.Writeline (" </SPAN></A></TD></TR>")
    MyFile.Close
    Set fso = Nothing
    Set MyFile = Nothing
End Sub
Private Sub WFile()    '写入网址连接一行4个
    Dim fso, MyFile
    Filename = ThisWorkbook.Path & "\" & "index.html"
    n = Sheets(1).Cells(1, 1)    '位置变量
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set MyFile = fso.OpenTextFile(Filename, 8)
    '  写入数据
    MyFile.Writeline (" <TR class=tbl_body align=left> ")
    LineI = 0
    For LineI = 0 To 3
        '    写入一个网址
        If Sheets(1).Cells(n, 2) = "" Then MyFile.Writeline (" <TD width=""25%""><A href=""") + Sheets(1).Cells(n, 5) + ("""")    '写入网址连接
        If Sheets(1).Cells(n, 4) <> "" Then MyFile.Writeline (" Title = """) + Sheets(1).Cells(n, 4) + ("""")   '写入网址提示Title = ""
        If Sheets(1).Cells(n, 2) = "" Then MyFile.Writeline (" > ") + Sheets(1).Cells(n, 3) + (" </A></TD> ")      '写入网址名称
        If Sheets(1).Cells(n, 2) <> "" And LineI > 0 And LineI < 4 Then  '单个分类网址写完
            LineII = 1
            For LineII = 1 To 4 - LineI
                MyFile.Writeline (" <td width=""25%"">&nbsp;</td>")
            Next
            GoTo 20
        End If
        n = n + 1
    Next
20  Sheets(1).Cells(1, 1) = n    '位置变量
    MyFile.Writeline ("</TR> ")    '
    MyFile.Close
    Set fso = Nothing
    Set MyFile = Nothing
End Sub
Private Sub WFileTop()    '写入top
    Filename1 = ThisWorkbook.Path & "\" & "网址导航.files/top.txt"
    Filename2 = ThisWorkbook.Path & "\" & "index.html"
    Dim temp1 As Byte
    Open Filename2 For Binary As #2
    Open Filename1 For Binary As #1
    Dim i As Long
    ReDim a(1 To FileLen(Filename1))
    Do While Not EOF(1)
        Get #1, , temp1
        Put #2, , temp1
    Loop
    Close 1
    Close 2
End Sub
Public Sub WFilefoot()
    Dim fso, MyFile
    Filename = ThisWorkbook.Path & "\" & "index.html"
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set MyFile = fso.OpenTextFile(Filename, 8)
    MyFile.Writeline ("  <TBODY></TBODY></TABLE>")
    MyFile.Writeline ("<SCRIPT src=""网址导航.files/foot.js""></SCRIPT>")
    MyFile.Writeline ("</BODY></HTML>")
    MyFile.Close
    Set fso = Nothing
    Set MyFile = Nothing
End Sub
Sub FileYN()    '判断AAA文件是否存在
    Set FS = Application.FileSearch
    With FS
        .LookIn = ThisWorkbook.Path            '确定路径
        .Filename = "index.html"    '查找的文件名
        If .Execute() > 0 Then   '判断查找的结果
            'MsgBox "index.html文件存在"
            Filename = ThisWorkbook.Path & "\" & "index.html"
            Kill (Filename)
            'Else
            ' MsgBox "AAA文件不存在"
        End If
    End With
End Sub

roc.jame

这是干什么呢？

seeyoutime

excel 表格内容生成 一个网页