mdlexcel.bas

这是个很好比较齐全的合同管理系统大家可以下载有很多用途

Attribute VB_Name = "mdlExcel"

'////============================================================
'////============================================================
'////    功能：用于将MSHFlexGrid或者MSFlexGrid控件上的数据导出到MS EXCEL文件中
'////    参数：objExcel    是MSHFlexGrid或者MSFlexGrid对象的名称
'////          ExcelTitle   导出的EXCEL表格标题
'////          ExcelFileName导出的EXCEL文件名
'////          ExcelPathName导出的EXCEL路径名
'////    使用：subExcel MSHFlexGrid1, "EXCEL测试", "测试", "C:\我的EXCEL文档\"
'////
'////============================================================
'////============================================================
Sub subExcel(objExcel As Object, ExcelTitle As String, ExcelFileName As String, Optional ExcelPathName As String)
    On Error GoTo error
    '判断文件状态
    If ExcelPathName <> "" Then
        If Not FindDriveFolderFile(ExcelPathName, ExcelFileName & ".xls") Then Exit Sub
    Else
        If Not FindDriveFolderFile("c:\my documents\", ExcelFileName & ".xls") Then Exit Sub
    End If
    'Dim recExcel As New Excel.Application
    Set recExcel = CreateObject("excel.application")
    Dim recEwbook As Object
    Dim recEwsheet As Object
    Dim intIndex As Integer
    Dim intIndexY As Integer
    Dim strTitle As String
    Screen.MousePointer = 11
    Set recEwbook = recExcel.Workbooks().Add
    Set recEwsheet = recEwbook.Worksheets("sheet1")
    For intIndex = 0 To objExcel.Rows
        'INTINDEX =0时导出EXCEL表格标题
        '导出的列范围为: A-ZZ
        If intIndex = 0 Then
            recExcel.Range("A1").Value = ExcelTitle
        Else
            For intIndexY = 0 To objExcel.Cols - 1
                If intIndexY < 26 Then
                    strTitle = Chr(intIndexY + 65)
                ElseIf intIndexY < 702 Then
                    strTitle = Chr(Int((intIndexY) / 26) + 64) & Chr((intIndexY + 2) Mod (Int((intIndexY) / 26) * 26 + 1) + 64)
                Else
                    MsgBox "EXCEL越界！", vbInformation, Infor
                    Screen.MousePointer = 0
                    Exit Sub
                End If
                recExcel.Range(strTitle & intIndex + 1).Value = objExcel.TextMatrix(intIndex - 1, intIndexY)
            Next
        End If
    Next
    If ExcelPathName <> "" Then
        recEwbook.SaveAs ExcelPathName & ExcelFileName & ".xls"
    Else
        recEwbook.SaveAs "c:\my documents\" & ExcelFileName & ".xls"
    End If
    recExcel.Quit
    Set recExcel = Nothing
    MsgBox "导出成功！", , Infor
    Screen.MousePointer = 0
    Exit Sub
error:
    MsgBox "导出失败！", vbCritical, Infor
    recExcel.Quit
    Set recExcel = Nothing
    Screen.MousePointer = 0
End Sub

'====================================================================
'********************************************************************
'
'在创建文件时，用于查找驱动器、路径和文件是否存在，从而方便文件的建立
'函数返回TRUE时表示查找的文件已经存在，并允许覆盖或者表示允许在合法路径上建立文件。
'CreateObject("Scripting.FileSystemObject")是通过建立对象来使用 FSO,也可以通过引用“Microsoft Scripting Runtime"来使用 FSO
'
'   参数：strDriveFolder    文件路径
'        strFileName        文件名
'
'********************************************************************
'====================================================================
Function FindDriveFolderFile(strDriveFolder As String, Optional strFileName As String) As Boolean
    On Error GoTo error
    'Dim fsoFolderFile As New FileSystemObject
    Set fsoFolderFile = CreateObject("Scripting.FileSystemObject")
    '查找驱动器是否存在
    If fsoFolderFile.DriveExists(Left(strDriveFolder, 1)) Then
        '查找文件夹是否存在
        If fsoFolderFile.FolderExists(strDriveFolder) Then
            '查找文件是否存在
            If strFileName <> "" Then
                If fsoFolderFile.FileExists(strDriveFolder & strFileName) Then
                    If MsgBox("文件(" & UCase(strFileName) & ")已经存在！是否要覆盖?", vbExclamation + vbYesNo, "确定") = vbYes Then
                        Kill strDriveFolder & strFileName
                        FindDriveFolderFile = True
                    Else
                        FindDriveFolderFile = False
                    End If
                Else
                    FindDriveFolderFile = True
                End If
            End If
        Else
            If MsgBox("文件夹(" & UCase(strDriveFolder) & ")不存在！是否要新建?", vbQuestion + vbYesNo) = vbYes Then
                fsoFolderFile.CreateFolder strDriveFolder
                FindDriveFolderFile = True
            Else
                FindDriveFolderFile = False
            End If
        End If
    Else
        MsgBox "驱动器(" & UCase(Left(strDriveFolder, 1)) & ":)不存在或无效！"
        FindDriveFolderFile = False
    End If
    Exit Function
error:
    MsgBox "未知错误！", vbExclamation, "提示"
End Function