excelprint.bas

杭州舟远信息技术连锁有限公司的棋牌管理系统源代码

Attribute VB_Name = "ExcelPrint"
Option Explicit
 




'Private objConn As ADODB.Connection

'************************************************************
'<函数名>
'   OutPut_ExcelFile()
'<功能>
'   输出数据库结果集到文件
'<参数>
'   astrOrderNo: 订货单编号
'<返回值>
'   OutPut_ExcelFile: 输出文件的下载路径
'   -1:未找到该数据库中对应订货单编号的记录
'   -2:查询ORDER_RECIEVEDATA表SUFIX字段时数据库操作错误
'<备注>
'   Created on Aug.13th.2004 by 王霄南
'************************************************************
Public Function OutPut_ExcelFile(ByRef t_fields, ByVal strsql As String, ByVal strContent As String) As String
On Error Resume Next

    Dim ADORS  As ADODB.Recordset
    Dim xlApp As Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    
    Dim lngRowCount As Long             '总记录数
    Dim intColCount As Integer          '总字段数
    Dim lngRow As Long                  '记录数循环计数器
    Dim intCol As Integer               '字段数循环计数器
    Dim aryFieldLen()                   '字段长数组
    Dim intFieldLen As Integer          '字段长
    Dim intCount As Integer
'    Dim oPrInfo

'    Set oPrInfo = CreateObject("MyFunc.ProfileInfo")
    
    Dim strSaveLocation As String
    Dim strSaveDes As String                '生成的Excel文件的保存路径
    '从INI文件中得到保存Excel文件的路径
    strSaveLocation = "C:\ExcelFiles\" 'oPrInfo.Get_ProfileInfo("ConstDefine.ini", "[EXCELFILEOUT]", "FILESAVE_LOCATION")
    strSaveDes = strSaveLocation & strContent & "_" & Format(Now, "YYYYMMDD_HHMMSS") & ".xls"
    
    '从INI文件中得到数据库连接字符串
    '打开数据库
'    Set objConn = CreateObject("ADODB.Connection")
'    objConn.Open oPrInfo.Get_ProfileInfo("ConnectDB.ini", strDBSource, "StrConnection")
'    objConn.CommandTimeout = 300
    
'    Set oPrInfo = Nothing
    
    Set xlApp = CreateObject("Excel.Application")
    'Set xlBook = xlApp.cre
    Set xlBook = xlApp.Workbooks.Add
    Set xlSheet = xlBook.Worksheets(1)
    xlApp.Visible = True                               '不显示表格
    
'    Set adoRS = New ADODB.Recordset
'    adoRS.Open strSQL, objConn,adOpenDynamic
    'Set adoRS = PUB_data.OpenRecordset(strSQL, 2, 0, 2)
     Set ADORS = New ADODB.Recordset
             ADORS.Source = strsql
             Set ADORS.ActiveConnection = objConn
             ADORS.CursorType = adOpenDynamic
             ADORS.LockType = adLockOptimistic
             ADORS.Open

    If objConn.Errors.count = 0 Then
        intCount = 0
        ADORS.MoveFirst
        While Not ADORS.EOF
            intCount = intCount + 1
            ADORS.MoveNext
        Wend
        
        lngRowCount = intCount
        intColCount = UBound(t_fields) + 1
        
        For intCol = 1 To intColCount
            xlSheet.Cells(1, intCol).Value = t_fields(intCol - 1)
        Next
        ADORS.MoveFirst
        If Not ADORS.EOF Then
            For lngRow = 2 To lngRowCount + 1
                For intCol = 1 To intColCount
                    xlSheet.Cells(lngRow, intCol).Value = CStr(ADORS.Fields(intCol - 1))
                    xlSheet.Columns(intCol).ColumnWidth = 12
                Next
                ADORS.MoveNext
            Next
        xlSheet.Columns(1).ColumnWidth = 15
        End If
        OutPut_ExcelFile = strSaveDes
    Else
        OutPut_ExcelFile = "DB Error: " & Err.Description
    End If
    ADORS.Close
    
                        
'    xlBook.SaveAs strSaveDes   '保存
'    Workbooks.Close
    If Err.Number <> 0 Then
        OutPut_ExcelFile = "Excel Error: " & Err.Description
    End If
    
'    Application.Quit
    'xlApp.Quit
    Set xlApp = Nothing
    Set ADORS = Nothing
'   Set objConn = Nothing
    
End Function