Private m_getVersion As String
        Private m_ConnectionString As String
        Private m_In_FilePath As String
        Private m_In_FileName As String
        Private m_Out_FilePath As String
        Private m_Out_FileName As String
        Private m_QuerySql As String
        Private m_FileType As String
                
     Private Sub Class_Initialize()
        m_getVersion = "OfficeToHtml V1.0 By 老三"
     End Sub
     Private Sub Class_Terminate()
        rs.Close
       Set rs = Nothing
     End Sub
     '版本
     Public Property Get getVersion() As String
       getVersion = m_getVersion
     End Property
    '数据库连接字串
     Public Property Let ConnectionString(ByVal NewValue As String)
       m_ConnectionString = NewValue
     End Property
     '传入文件路径
     Public Property Let In_FilePath(ByVal NewValue As String)
       m_In_FilePath = NewValue
     End Property
     '传入文件名
     Public Property Let In_FileName(NewValue As String)
       m_In_FileName = NewValue
     End Property
     '写入文件路径
     Public Property Let Out_FilePath(NewValue As String)
       m_Out_FilePath = NewValue
     End Property
     '写入文件名
      Public Property Let Out_FileName(NewValue As String)
       m_Out_FileName = NewValue
     End Property
     '查询数据库的sql语句
     Public Property Let QuerySql(NewValue As String)
       m_QuerySql = NewValue
     End Property
     '处理文件的类型
      Public Property Let FileType(NewValue As String)
       m_FileType = NewValue
     End Property
     

    '打开数据库
    Private Function OpenDb(DbConnetionStr As String, sql As String) As Recordset
       Dim conn As ADODB.Connection
       Dim rs As ADODB.Recordset
       Set conn = New ADODB.Connection
       conn.Open DbConnetionStr
       Set rs = New ADODB.Recordset
       rs.Open sql, conn, adOpenKeyset, adLockOptimistic
      Set OpenDb = rs
    End Function
    
'///////////////////////////////////////////////////////////////////////////////////////////////////
'主要处理函数，根据文件类型属性来获得文件的类型，如果此属性为空根据传入文件名来获得文件类型
'此时只能是上传文件的形式，因为数据库中无法得到文件的类型。目前只支持word和excel
'根据传入文件名In_FileName是否为空来判断数据来源是文件还是数据库
'如果是数据库，则根据传来的sql语句和数据连接等得到word和excel等文件内容，并且生成文件于写入文件路径中
'如果有写入文件名，则写入文件名采用此文件，否则自动生成文件名
'如果成功则返回写入的文件名，如果返回0表示某些必须属性没有填写，返回1表示中间出现错误
'///////////////////////////////////////////////////////////////////////////////////////////////////
Public Function SaveToHtml() As String
    Dim intoFilename As String
    Dim fileExt As String
    Dim savefilename As String
    'Dim MyOfficeToHtml As OfficeToHtml
    Dim s As String
    'Set MyOfficeToHtml = New OfficeToHtml
    
    '根据传来文件名确定文件后缀
            
     If (m_In_FileName <> "") Then fileExt = fnGetFileExt(m_In_FileName, 1)
      '根据文件类型确定文件后缀
      '如果有文件类型属性，则后缀以此为最终确定
    If (m_FileType <> "") Then fileExt = fnGetFileExt(m_FileType, 0)
    
    '传入的文件名In_FileName
    If (m_In_FileName = "") Then
        '调用数据库来获得文件
        If (m_ConnectionString = "") Then
            SaveToHtml = "0"
        Else
            '根据数据库中数据生成相应的文件
            savefilename = fnSaveDbToFile(m_Out_FilePath, fileExt)
            '根据生成的文件名和路径生成html文档
            If (m_Out_FileName = "" And savefilename <> "") Then
                m_Out_FileName = savefilename
            End If
            If (fileExt = "xls") Then
                 s = fnChangeExcelToHtml(savefilename)
            Else
                 s = fnChangeWordToHtml(savefilename)
            End If
        End If
    Else
    '根据传入的文件名生成html文档
        If (fileExt = "xls") Then
            s = fnChangeExcelToHtml(m_In_FileName)
        Else
            s = fnChangeWordToHtml(m_In_FileName)
        End If
        's = fileExt
    End If
    SaveToHtml = s
End Function

'转换word文档为HTML文档
Private Function fnChangeWordToHtml(ByVal s_file As String) As String
        Dim s_filepath As String
        Dim o_filepath As String
        Dim o_filename As String
          '如果没有设置输出路径则与输入路径相同
        If (m_Out_FilePath = "") Then
            m_Out_FilePath = m_In_FilePath
        End If
        m_In_FilePath = fnRegInFilePath(m_In_FilePath)
        m_Out_FilePath = fnRegInFilePath(m_Out_FilePath)
        
        o_filename = fnRanFileName() & ".html"
        s_filepath = m_Out_FilePath & "\" & s_file
        o_filepath = m_Out_FilePath & "\" & o_filename
        
        '如果指定目录没有此文件则，不用转换文档，返回1
        If (fnCheckExistFile(s_filepath) = True) Then
             Dim MyWord As New Word.Application
             Dim Mydoc As Word.Document
             MyWord.Visible = False
             MyWord.DisplayAlerts = wdAlertsNone
             Set Mydoc = MyWord.Documents.Open(s_filepath)
             Mydoc.SaveAs o_filepath, 8
             MyWord.Quit
             Set MyWord = Nothing
            fnChangeWordToHtml = o_filename
        Else
           fnChangeWordToHtml = "1"
        End If
End Function

'转换excel文档为HTML文档
Private Function fnChangeExcelToHtml(ByVal s_file As String) As String
        Dim s_filepath As String
        Dim o_filepath As String
        Dim t As String
        Dim o_filename As String
          '如果没有设置输出路径则与输入路径相同
        If (m_Out_FilePath = "") Then
            m_Out_FilePath = m_In_FilePath
        End If
        m_In_FilePath = fnRegInFilePath(m_In_FilePath)
        m_Out_FilePath = fnRegInFilePath(m_Out_FilePath)
        
        o_filename = fnRanFileName() & ".html"
        s_filepath = m_Out_FilePath & "\" & s_file
        o_filepath = m_Out_FilePath & "\" & o_filename
        
        '如果指定目录没有此文件则，不用转换文档，返回1
        If (fnCheckExistFile(s_filepath) = True) Then
                
             On Error Resume Next
             
             Dim MyExcel As New Excel.Application
             Dim Myxls As Excel.Workbook
             '不显示excel
            MyExcel.Visible = False
             '取除警告
             MyExcel.DisplayAlerts = False
             Set MyExcel = CreateObject("Excel.Application")

             Set Myxls = MyExcel.Workbooks.Open(s_filepath)
             'Set Myxls = MyExcel.Workbooks.Open(s_filepath, 0, False, 3, False, False, True, xlWindows, False, False, False, False, False)
             'ewb.SaveAs(saveFileName,Excel.XlFileFormat.xlHtml,false,false,false,false,Excel.XlSaveAsAccessMode.xlNoChange,Excel.XlSaveConflictResolution.xlLocalSessionChanges,false,false,false);

             Myxls.SaveAs o_filepath, Excel.XlFileFormat.xlHtml, False, False, False, False, Excel.XlSaveAsAccessMode.xlNoChange, XlSaveConflictResolution.xlLocalSessionChanges, False, False, False
             Myxls.Close
             MyExcel.Application.Quit
             MyExcel.Quit
             Set MyExcel = Nothing
             t = o_filename
        Else
             t = "1"
        End If
        fnChangeExcelToHtml = o_filename
End Function



'从数据库中读取数据并且写到指定目录中
Private Function fnSaveDbToFile(ByVal s_filename As String, ByVal s_fileExt As String) As String
    Dim rs As ADODB.Recordset
    Dim savefilename As String
    Dim conn As ADODB.Connection
    Dim mfile As String
    mfile = fnRanFileName()
    '如果没有设置输出路径则与输入路径相同
    If (m_Out_FilePath = "") Then m_Out_FilePath = m_In_FilePath
    savefilename = mfile & "." & s_fileExt
    'Set rs = OpenDb(m_ConnectionString, m_QuerySql)
     Set conn = New ADODB.Connection
     conn.Open m_ConnectionString
     Set rs = New ADODB.Recordset
    rs.Open m_QuerySql, conn, adOpenKeyset, adLockOptimistic

    '如果没有数据，则不用保存，返回1
    If (Not rs.EOF) Then
    '保存到文件

    Set iStm = New ADODB.Stream
    
    With iStm

       .Mode = adModeReadWrite
    
       .Type = adTypeBinary
        
       .Open
        
       .Write rs(0)
        
        '这里注意了,如果当前目录下存在文件,会报一个文件写入失败的错误.

      .SaveToFile m_Out_FilePath & savefilename
    End With
         iStm.Close
         Set iStm = Nothing
    Else
        savefilename = "1"
    End If
    rs.Close
    Set rs = Nothing

    '返回生成的文件名
    fnSaveDbToFile = savefilename
End Function
'检查文件是否存在
Private Function fnCheckExistFile(ByVal f_file As String) As Boolean
    If Dir(f_file) <> "" Then
        fnCheckExistFile = True
    Else
        fnCheckExistFile = False
    End If
End Function




'生成一不重复的文件名
Private Function fnRanFileName() As String
    Dim sRnd As Integer
    Randomize Timer
    sRnd = Int(9000 * Rnd(9000) + 1000)
    fnRanFileName = Year(Now) & Month(Now) & Day(Now) & Hour(Now) & Minute(Now) & Second(Now) & CStr(sRnd)
End Function


'根据文件类型或者是文件名得到文件的后缀
'tflag为0时表示检查文件类型，为1时表示检查文件名
Private Function fnGetFileExt(ByVal s As String, ByVal tflag As Integer) As String
    Dim fileExt As String
    Dim pos As Integer
    '检查文件名
    If (tflag = 1) Then
        pos = InStrRev(s, ".", -1, vbTextCompare)
        If (pos > 0) Then
            fileExt = Mid(s, pos + 1, Len(s) - pos)
        Else
            '默认是word
            fileExt = "doc"
        End If
    End If
    '检查文件类型
    If (tflag = 0) Then
        Select Case s
        Case "word"
            fileExt = "doc"
        Case "excel"
            fileExt = "xls"
        Case Else
            fileExt = "doc"
        End Select
    End If
    fnGetFileExt = LCase(fileExt)
End Function

'检查传入文件路径最后是否有'|'，如果有，则去除掉
Private Function fnRegInFilePath(ByVal o_infilepath) As String
    Dim pos As Integer
    Dim pos1 As Integer
    
    Dim s As String
    pos = InStrRev(o_infilepath, "\", -1, vbTextCompare)
    If (pos = Len(o_infilepath)) Then
        s = Mid(o_infilepath, 1, pos - 1)
        pos1 = InStrRev(s, "\", -1, vbTextCompare)
        If (pos1 = Len(s)) Then
            s = fnRegInFilePath(s)
        End If
    Else
       s = o_infilepath
    End If
    fnRegInFilePath = s
End Function