vba导出excel为单个网页文件

注意：仅适用于office版本，wps不支持

Sub 导出()
scuser = LCase(Application.UserName)
Dim DateStr As Byte
DateStr = Day(DateSerial(Year(Date), Month(Date) + 1, 0))
day0 = Day(Date)
year0 = Year(Date) & "\"
If MsgBox("是否导出mht网页文件？整个导出过程大约1分钟！", vbYesNo + vbQuestion, "是否导出mht网页文件？") = vbYes Then
    sj = Now
    Sheet1.Cells(3, "d").Value = sj
    Sheet2.Cells(3, "d").Value = sj
    Sheet3.Cells(3, "d").Value = sj
    Sheet4.Cells(3, "d").Value = sj
    'Sheet5.Cells(1, "b").Value = sj
    Sheet1.Range("D3").Comment.Text Text:="上传工号:" & Chr(10) & scuser
    Sheet1.Range("A:A").Font.ColorIndex = 2 '字体白色
    ActiveWorkbook.Save
    If day0 = DateStr Then
    ActiveWorkbook.SaveCopyAs "备份路径\" & year0 & Format(Date$, "yyyymmdd") & "_F7.xls"
    Workbooks.Open Filename:="备份路径\" & year0 & Format(Date$, "yyyymmdd") & "_F7.xls", UpdateLinks:=0, ReadOnly:=True
    Else
    ActiveWorkbook.SaveCopyAs "备份路径\" & Format(Date$, "yyyymmdd") & "_F7.xls"
    Workbooks.Open Filename:="备份路径\" & Format(Date$, "yyyymmdd") & "_F7.xls", UpdateLinks:=0, ReadOnly:=True
    End If

    Dim MyFile As Object
    Set MyFile = CreateObject("Scripting.FileSystemObject")
    If MyFile.FileExists("判断mht文件是否存在") = True Then
        Kill "删除mht文件"
    Else:
    End If
    ActiveWorkbook.SaveAs "导出mht路径", FileFormat:=xlWebArchive
    ActiveWorkbook.Close
    MsgBox "" & sj & " 恭喜您，上传成功！"
    Sheet1.Range("A:A").Font.ColorIndex = 15    '字体颜色为灰色
    'Else: MsgBox "你已取消"
End If

End Sub