|
以下相关功能为以前在 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 BorderWeight As XlBorderWeight = xlThin)
' 先初始化
Ra.Borders(xlDiagonalDown).LineStyle = xlNone
Ra.Borders(xlDiagonalUp).LineStyle = xlNone
' 画外框线
DrawBorder Ra,xlEdgeTop,LineStyle,BorderWeight
DrawBorder Ra,xlEdgeBottom,xlEdgeLeft,xlEdgeRight,BorderWeight
' 画内部线
If Not blnBox Then
' 如为网格线，则需处理此处理，如仅为Box 外框则无需处理
DrawBorder Ra,xlInsideVertical,xlInsideHorizontal,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 = NothingEnd Function （编辑：李大同）
【声明】本站内容均来自网络，其相关言论仅代表作者个人观点，不代表本站立场。若无意侵犯到您的权利，请及时与联系站长删除相关内容!
|
