Access快速开发平台辅助导出函数

时　间:2019-04-06 20:32:21
作　者:丘苏洲   ID：66601  城市：普宁
摘　要:快速开发平台辅助导出函数
正　文:

      这几天用到平台的导出函数，功能比较强大，但是对于组合框导出的结果不是很理想。希望导出的是显示的列而不是绑定列数据，是/否字段是否=-1有时也会显示为#####错误。

时间已在论坛找到方法：格式设置为“H：NN”用平台导出函数不会出错。

组合框没有合适的方法，所以写了一个自定义函数来导出组合框第二列内容并把是/否改为“T”/“F”文本型数值。

*平台导出函数是直接新建一个EXCEL进程， Set EXLapp = GetObject(, "excel.application")只能获取第一个打开的EXCEL进行所有工作簿记。

*每次使用辅助格式化函数，必需关闭所有已打开的EXCEL，辅助格式化函数才可以正常运行。

以也为导出后效果：

自定义函数需要引用EXCEL

时间字段格式改为“H：NN”

自定义函数通过标签来判断需要格式化字段，“”是组合框，“”为是/否字段

平台自动生成的“导出”代码改为以下

Public Sub btnExport_Click()
    Dim ExportName As String
    If Not Me.sfrList.Form.CurrentRecord > 0 Then Exit Sub
    Set gsfrList = Me.sfrList
    ExportName = ExportToExcel(DataForm:=Me.sfrList)
    If ExportName <> "" Then formatExport ExportName
End Sub

以下为自定义格式化源码：

Function formatExport(ExportName As String)
 On Error GoTo ErrorHandler
    Dim i As Long
    Dim J As Integer
    Dim Namej(50, 6)
    Dim ctl As Control
    Dim rowi As Long
    Dim EXLapp As Excel.Application
    Dim EXLwork As Excel.Workbook
    Dim EXLSheet As Excel.Worksheet
    Set EXLapp = GetObject(, "excel.application")
    Set EXLwork = EXLapp.Workbooks(ExportName)
    Set EXLSheet = EXLwork.Worksheets("Sheet1")
    EXLapp.Visible = False
    '历遍所有控件,找到带有格式化标签的字段内容保存到数组.
    '是组合框需要用第二列更新,是/否字段更新为"T"/"F".
    
    J = 0
    For Each ctl In gsfrList.Form.Controls
        If ctl.Tag = "" or ctl.Tag = "" Then
            Namej(J, 0) = ctl.Name
            Namej(J, 1) = ctl.Tag
            Namej(J, 2) = J
            Namej(J, 3) = ctl.Controls(0).Caption
            Namej(J, 4) = 0
            Namej(J, 5) = "F"
            J = J + 1
        End If
    Next


    '历遍EXCEL第一行,和数组标题内容对比保存需格式化字段在EXCEL的对应列.
    J = 1
    With EXLSheet
    Do While Not (.Cells(1, J) = "")
        For i = 0 To 49
            If .Cells(1, J) = Namej(i, 3) Then Namej(i, 4) = J: Exit For
        Next i
        J = J + 1
    Loop
        '定义进度条
    Dim clsPB As PopupProgressBar
    Set clsPB = CreateInstance("PopupProgressBar")
    clsPB.StatusText = LoadString("Format Excel...")
    clsPB.PercentFormat = "0%"
    clsPB.Max = gsfrList.Form.Recordset.RecordCount
    '历遍列表窗数据,更新EXCEL需要格式化数据.
    rowi = 0
    gsfrList.Form.Recordset.MoveFirst
    For i = 1 To gsfrList.Form.Recordset.RecordCount
    rowi = rowi + 1
    clsPB.Value = rowi
        For J = 0 To 49
            If Namej(J, 0) = "" Then Exit For
            If Namej(J, 4) <> 0 Then
                Select Case Namej(J, 1)
                Case ""  '用组合框第二列更新EXCEL
                    .Cells(i + 1, Namej(J, 4)) = Nz(gsfrList.Form.Controls(Namej(J, 0)).Column(1), "")
                    If Namej(J, 5) = "F" Then
                    .Columns(Namej(J, 4)).EntireColumn.AutoFit
                    Namej(J, 5) = "T"
                    End If
                Case ""  '是/否字段 用"T"/"F"更新EXCEL ACCESS  true导出是-1在EXCEL有时显示不正确.
                    If gsfrList.Form.Controls(Namej(J, 0)) <> 0 Then
                        .Cells(i + 1, Namej(J, 4)) = "T"
                    Else
                        .Cells(i + 1, Namej(J, 4)) = "F"
                    End If
            End Select
                End If
            
        Next J
        
        gsfrList.Form.Recordset.MoveNext
    Next i
    End With
ExitHere:
    Set clsPB = Nothing
    EXLapp.Visible = True
    Set EXLapp = Nothing
    Set EXLwork = Nothing
    Set EXLSheet = Nothing
    Exit Function


ErrorHandler:
    RDPErrorHandler LoadString("Close Excel and rerun Export Excel.")
    Resume ExitHere
End Function