|
Public Function RsFillFlex(strcaption As String, _
grd As MSFlexGrid, _
rs As adodb.Recordset, _
Optional alignFlag As Integer = 0, _
Optional showZeroFlag As Integer = 0, _
Optional Rows_Fixed As Integer = 1, _
Optional TableHead As Integer = 1) As Boolean
'本函数特别要求，对于含的小数点的数值型数据，要根据数据表中的结构显示小数点个数
'功能：将记录添充到表格中
'参数一：表头格式
'参数二：表格控件名称
'参数三：记录集
'参数四：表示是否指定"列对齐方式"，为1根据记录集的字段类型来设置，为0根据表格的formatstring设置
'参数五：是否显示数字0,为0不显示，为1要显示
'参数六：固定行数，默认为1
'参数七：表头所占的行数，默认为1 (该参数有何意义？)
'好象记录集必须是客户端游标才行，服务器端游标记录数不好取 Dim i As Long, j As Long, strField As String 'strField用于存放字段内容
Dim vnttmp As Variant '临时存放每个单元格内容[要能存放各种类型数据，故为variant型]
Dim rsCols As Long '记录集的字段数
Dim grdCols As Long '表格的列数 On Error GoTo errhandler
'记录集未打开，则返回错误
If rs.State <> adStateOpen Then
MsgBox "没有可供显示的记录集！", 32, "提示"
RsFillFlex = False
Exit Function
End If
'首先判断记录集是否有内容[如果无内容要清除表格原有内容],因为记录集正常打开的情况下，也可能一条记录都没有
If rs.BOF = True And rs.EOF = True Then
grd.Rows = grd.FixedRows '清除除表头的所有内容
grd.Rows = Rows_Fixed + 1 '无记录时，显示一个空白行
RsFillFlex = True
Exit Function
End If '注意：不能设置固定行，否则会报错[设置固定行时，除非固定行比行数小一，否则报错] '以下代码运行的前提是：已有记录
With grd
.Rows = .FixedRows '将行数设置成固定行的行数
.Clear '清除原有内容[重要]
.FormatString = strcaption '格式化表头，确定列数
grdCols = .Cols '取表格列数
rsCols = rs.Fields.Count '记录集字段数
'判断传来的表头与记录集的字段数是否一致
.Cols = rsCols + 1
.Redraw = False '不重绘，目的是提高速度 '确定表格总行数[因为存在表头，故表数行数应等于记录条数加一]
.Rows = rs.RecordCount + TableHead '该设定决定表格有多少行显示数据，很重要 '根据参数决定是否设置各列对齐方式,为1时不按formatstring设置，按记录集字段类型设置
If alignFlag = 1 Then
For j = 1 To rs.Fields.Count
Select Case rs.Fields(j - 1).Type
Case adDecimal, adDouble, adSingle, adNumeric, adBigInt, adInteger, adTinyInt, adSmallInt
'设定为右对齐
.ColAlignment(j) = 7
Case Else
'设定为左对齐
.ColAlignment(j) = 1
End Select
Next
End If rs.MoveFirst
For i = 1 To rs.RecordCount '循环显示记录,有多少条记录则循环多少次
.TextMatrix(i, 0) = i '第0列显示序号
For j = 1 To rs.Fields.Count '循环处理各个列
'取单元格的值
vnttmp = Trim(rs.Fields(j - 1).Value & "")
'根据不同的类型，设置不同的格式显示
Select Case rs.Fields(j - 1).Type
Case adDecimal, adDouble, adSingle, adNumeric
If Val(vnttmp) = 0 Then
If showZeroFlag = 0 Then
strField = ""
Else
'根据数据库中的字段小数位数的定义设置格式[注意：要对小数位数为0进行处理]
Select Case rs.Fields(j - 1).NumericScale
Case 0
strField = Format(vnttmp, "#")
Case 1
strField = Format(vnttmp, "#0.0")
Case 2
strField = Format(vnttmp, "#0.00")
Case 3
strField = Format(vnttmp, "#0.000")
Case Else
strField = Format(vnttmp, "#0.000#")
End Select
End If
Else
'根据数据库中的字段小数位数的定义设置格式[注意：要对小数位数为0进行处理]
Select Case rs.Fields(j - 1).NumericScale
Case 0
strField = Format(vnttmp, "#")
Case 1
strField = Format(vnttmp, "#0.0")
Case 2
strField = Format(vnttmp, "#0.00")
Case 3
strField = Format(vnttmp, "#0.000")
Case 255
strField = vnttmp
Case Else
strField = Format(vnttmp, "#0.000#")
End Select
End If
Case adBigInt, adInteger, adTinyInt, adSmallInt
If Val(vnttmp) = 0 Then
If showZeroFlag = 0 Then
strField = ""
Else
strField = vnttmp
End If
Else
strField = vnttmp
End If ' Case adBoolean
' '布尔值
' strField = IIf(vnttmp = True, "是", "否")
' Case adDBTimeStamp
' '日期时间值
' strField = Left(Format(vnttmp, "yyyy/mm/dd"), 10)
Case Else
strField = vnttmp
End Select
.TextMatrix(i, j) = strField
Next
rs.MoveNext '显示下一条记录
Next '设定第几行显示在最前面(用toprow属性)
.TopRow = Rows_Fixed ' '使表头各列居中
' .Row = 0
' For j = 0 To .Cols - 1
' '.FixedAlignment(j) = 4
' .Col = j
' .CellAlignment = 4
' Next
.Redraw = True '填完数据后，充许重绘
RsFillFlex = True '返回true
End With Exit Function
errhandler:
grd.Clear
grd.Rows = grd.FixedRows '清除除表头的所有内容
grd.Rows = Rows_Fixed + 1 '无记录时，显示一个空白行
grd.Redraw = True '出错后如果不设置成充许重绘，则会花屏
RsFillFlex = False
MsgBox "发生错误：" & Err.Description
End Function
Public Function OutputToExcel(Optional Rs_Data As adodb.Recordset, Optional Cn As adodb.Connection, Optional strSQL As String)
'记录集必须是客户端游标才行
Dim Irowcount As Integer
Dim Icolcount As Integer
Dim xlApp As New Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlQuery As Excel.QueryTable
If Rs_Data Is Nothing Then
If Cn Is Nothing Or strSQL = "" Then
Exit Function
End If
Set Rs_Data = New adodb.Recordset
With Rs_Data
If .State = adStateOpen Then
.Close
End If
.ActiveConnection = Cn
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockReadOnly
.Source = strSQL
.Open
End With
End If
With Rs_Data
If .RecordCount < 1 Then
'MsgBox ("没有记录!")
Exit Function
End If
'记录总数
Irowcount = .RecordCount
'字段总数
Icolcount = .Fields.Count
End With
Set xlApp = CreateObject("Excel.Application")
Set xlBook = Nothing
Set xlSheet = Nothing
Set xlBook = xlApp.Workbooks().Add
Set xlSheet = xlBook.Worksheets("sheet1")
xlApp.Visible = True
'添加查询语句，导入EXCEL数据
Set xlQuery = xlSheet.QueryTables.Add(Rs_Data, xlSheet.Range("a1"))
With xlQuery
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = True
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
End With xlQuery.FieldNames = True '显示字段名
xlQuery.Refresh xlApp.Application.Visible = True
Set xlApp = Nothing '"交还控制给Excel
Set xlBook = Nothing
Set xlSheet = Nothing
End Function '//自动调整Grid各列列宽为最合适的宽度
Public Sub AdjustColWidth(frmCur As Form, gridCur As Object, Optional bNullRow As Boolean = True, Optional dblIncWidth As Double = 0)
'--------------------------------------------------------------------
'功能:
' 自动调整Grid各列列宽为最合适的宽度
'参数:
' [frmCur].........................................当前工作窗体
' [gridCur]........................................当前要调整的Grid
'--------------------------------------------------------------------
Dim i, j As Integer
Dim dblWidth As Double With gridCur
For i = 0 To .Cols - 1
dblWidth = 0
If .ColWidth(i) <> 0 Then
For j = 0 To .Rows - 1
If frmCur.TextWidth(.TextMatrix(j, i)) > dblWidth Then
dblWidth = frmCur.TextWidth(.TextMatrix(j, i))
End If
Next
.ColWidth(i) = dblWidth + dblIncWidth + 100
End If
Next
End With
End Sub
|
