VB6 中，输出 Excel 功能合集

以下相关功能为以前在 VB 中写的一个通用的 Model ，以方便调用Excel 功能，并进行输出和格式处理。

 

 

 

Public xlsApp As New excel.Application
Public xlsBook As New excel.Workbook
Public xlsSheet As New excel.Worksheet

 

'--------------------------------
' 画一Excel 选择范围的边框
'--------------------------------
Public Sub DrawBorder(ByRef Ra As excel.Range, BordersIndex As XlBordersIndex, Optional LineStyle As XlLineStyle = xlContinuous, Optional BorderWeight As XlBorderWeight = xlThin)
        With Ra.Borders(BordersIndex)
            .LineStyle = LineStyle
            If LineStyle = xlNone Then Exit Sub
            .Weight = BorderWeight
            .ColorIndex = xlAutomatic
        End With
End Sub

 

'--------------------------------
' 为一个范围的格子画线－网格或仅为外框线
'--------------------------------
Public Sub DrawGrid(ByRef Ra As excel.Range, Optional ByVal blnBox As Boolean = False, Optional LineStyle As XlLineStyle = xlContinuous, Optional BorderWeight As XlBorderWeight = xlThin)
        ' 先初始化
        Ra.Borders(xlDiagonalDown).LineStyle = xlNone
        Ra.Borders(xlDiagonalUp).LineStyle = xlNone
       
        ' 画外框线
        DrawBorder Ra, xlEdgeTop, LineStyle, BorderWeight
        DrawBorder Ra, xlEdgeBottom, LineStyle, BorderWeight
        DrawBorder Ra, xlEdgeLeft, LineStyle, BorderWeight
        DrawBorder Ra, xlEdgeRight, LineStyle, BorderWeight
   
        ' 画内部线
        If Not blnBox Then
            ' 如为网格线，则需处理此处理，如仅为Box 外框则无需处理
            DrawBorder Ra, xlInsideVertical, LineStyle, BorderWeight
            DrawBorder Ra, xlInsideHorizontal, LineStyle, BorderWeight
        End If
End Sub

'--------------------------------
' 对格子的文字格式进行处理,使其中的文字可进行换行
'--------------------------------
Public Sub WrapText(ByRef Ra As excel.Range)
        Ra.Select
        With xlsApp.Selection
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlBottom
            .WrapText = True
            .Orientation = 0
            .AddIndent = False
            .ShrinkToFit = False
            .MergeCells = False
        End With
End Sub

'--------------------------------
' 对格子的文字格式进行处理,使其中的文字可进行换行
'--------------------------------
Public Sub FormatCells(ByRef Ra As excel.Range, Optional HAlign As excel.Constants = xlCenter, _
                            Optional VAlign As excel.Constants = xlCenter, Optional bWrapText As Boolean = False, _
                            Optional nOrient As Long = 0, Optional bMerge As Boolean = False)
        Ra.Select
        With xlsApp.Selection
            .HorizontalAlignment = HAlign
            .VerticalAlignment = VAlign
            .WrapText = bWrapText
            .Orientation = nOrient
            .AddIndent = False
            .ShrinkToFit = False
            .MergeCells = bMerge
        End With
End Sub

'--------------------------------
' 对一个格加入注释
'--------------------------------
Public Sub AddComment(ByRef objRange As excel.Range, ByVal sText As String, Optional ByVal bVisible As Boolean = False)
    With objRange
        .Select
        .AddComment
        .Comment.Visible = bVisible
        .Comment.Text Text:="" & Chr(10) & sText & Chr(10) & ""
    End With
End Sub

'--------------------------------
' 以一个格为基础，将其算式同样用于其它格
'--------------------------------
Public Sub AutoFill(ByRef objSouRange As excel.Range, ByRef objDesRagne As excel.Range, ByVal sFormulaR1C1 As String, ByVal nFillType As excel.XlAutoFillType)
    With objSouRange
    'ActiveCell.FormulaR1C1 = sFormulaR1C1
        .Value = sFormulaR1C1
        .Select
    End With
    xlsApp.Selection.AutoFill Destination:=objDesRagne, Type:=nFillType
End Sub

'--------------------------------
' 将Rst 中的资料直接输出至Excel文件中
'--------------------------------
Public Function RsToExcel(ByRef oRs As ADODB.Recordset, ByRef oXls As excel.Application, Optional ByVal lRow As Long = 1, Optional ByVal lCol As Long = 1, Optional ByVal bListCaption As Boolean = True) As Long
   
    If oRs Is Nothing Then Exit Function
    If oRs.State = adStateClosed Then Exit Function
   
    If bListCaption Then
        Dim i As Long
        For i = lCol To oRs.Fields.Count + lCol - 1
            oXls.Cells(lRow, i) = "'" & oRs(i - 1).Name
        Next i
    Else
        lRow = lRow - 1
    End If
   
    If oRs.EOF Then
        Exit Function
    End If
   
    On Error GoTo RsToExcel_Error
   
    oXls.Range(getExcelCol(lCol, False) & lRow + 1).CopyFromRecordset oRs
   
    Exit Function
   
RsToExcel_Error:
       
End Function

'---------------------------------
'取得对应栏的下标名称，用到此
'   pBaseonChar - 是否基于字母的基础，不是则表示直接基于坐标数字值
'---------------------------------
Public Function getExcelCol(ByVal plCol As Long, Optional pBaseonChar As Boolean = True) As String
    Dim nCol As Long
   
    If pBaseonChar Then
        nCol = plCol Mod 64
    Else
        nCol = plCol
    End If
   
    If nCol < 27 Then
        getExcelCol = Chr(nCol + 64)
    Else
        'getExcelCol = Chr(nCol / 26 + 64) & Chr(nCol Mod 26 + 64)
        getExcelCol = Chr((nCol - 1) / 26 + 64) & Chr(IIf(nCol Mod 26 = 0, 26, nCol Mod 26) + 64)
    End If

End Function

'--------------------------------
' 产生标准的报表表头
' add C/E Convertion function (Parameter : bUseChinese)
'--------------------------------
Public Sub ExportRptHeader(Sheet As excel.Worksheet, ByVal nRow As Long, ByVal sCol_Left As String, _
                            sCol_Right As String, ByVal sRptID As String, ByVal sUserID As String, _
                            ByVal sCompanyName As String, ByVal sSystemName As String, ByVal sReportName As String, _
                            Optional ByVal sCaptionFontSize As Integer = 14, Optional ByVal bUseChinese As Boolean = True)
        On Error GoTo errRptHeader
        ' ABC , 分别代表左边的指定开始列的前三列
        ' XYZ , 分别代表右边的指定列的连续三列，指定列为Y
        Dim sColA As String
        Dim sColB As String
        Dim sColC As String
        Dim sColX As String
        Dim sColY As String
        Dim sColZ As String
       
        sColA = sCol_Left
        sColB = Chr(Asc(sColA) + 1)
        sColC = Chr(Asc(sColA) + 2)
       
        sColY = sCol_Right
        sColX = Chr(Asc(sColY) - 1)
        sColZ = Chr(Asc(sColY) + 1)
       
        With Sheet
            .Range(sColA & nRow).Value = IIf(bUseChinese, "报表ID ：", "Report ID :")
            .Range(sColA & nRow + 1).Value = IIf(bUseChinese, "用户ID ：", "User ID :")
            ' value
            .Range(sColB & nRow).Value = sRptID
            .Range(sColB & nRow + 1).Value = sUserID
           
            .Range(sColY & nRow).Value = IIf(bUseChinese, "日期 ：", "Date :")
            .Range(sColY & nRow + 1).Value = IIf(bUseChinese, "时间 ：", "Time :")
            ' value
            .Range(sColZ & nRow).Value = Format(Date, "dd Mmm yyyy")
            .Range(sColZ & nRow).NumberFormat = "dd Mmm yyyy"
            .Range(sColZ & nRow + 1).Value = Format(Time, "HH:MM")
                       
            ' Factory Name / System / Report Name
            .Range(sColC & nRow).Value = UCase(Trim(sCompanyName))
            .Range(sColC & nRow + 1).Value = UCase(Trim(sSystemName))
            .Range(sColC & nRow + 2).Value = UCase(Trim(sReportName))
            'Merge Cells
            .Range(sColC & nRow & ":" & sColX & nRow).MergeCells = True
            .Range(sColC & nRow & ":" & sColX & nRow).HorizontalAlignment = xlCenter
            .Range(sColC & nRow + 1 & ":" & sColX & nRow + 1).MergeCells = True
            .Range(sColC & nRow + 1 & ":" & sColX & nRow + 1).HorizontalAlignment = xlCenter
            .Range(sColC & nRow + 2 & ":" & sColX & nRow + 2).MergeCells = True
            .Range(sColC & nRow + 2 & ":" & sColX & nRow + 2).HorizontalAlignment = xlCenter
            'Font
            .Range(sColC & nRow & ":" & sColX & nRow + 2).Font.Size = 14
            .Range(sColC & nRow & ":" & sColX & nRow + 2).Font.Bold = True
        End With
       
errRptHeader:
        If Err.Number <> 0 Then
            MsgBox Err.Description, vbOKOnly + vbExclamation, "Prompt ( ExportRptHeader ):"
        End If
End Sub

 

'-----------------------------------------------------------------------------------------
' 取得一个临时文件名，包括完整的路径名及名件名
'-----------------------------------------------------------------------------------------
Public Function getTempFileFullName(Optional ByVal psExtName As String = "") As String
    getTempFileFullName = ""
   
    Dim fso, tempfile
    Set fso = CreateObject("Scripting.FileSystemObject")
   
    Dim tfolder, tname
    Const TemporaryFolder = 2
    Set tfolder = fso.GetSpecialFolder(TemporaryFolder)
    tname = fso.GetTempName

    getTempFileFullName = sfTrim(tfolder & "/" & tname) & psExtName
   
    Set fso = Nothing
End Function