[EXCEL][VBA][Grid++Report][数字化]usPrint - 封面、目录打印工具

· 首先感谢 锐浪软件 提供免费的报表工具

· 环境：WIN7 + Office2010 + Grid++Report6.8

· 功能：根据excel表数据打印封面、目录，用于简单的数据结构（单表数据）

· 包含文件：

\usPrint\Contens.grf	测试用目录模板（可自行设计制定）
\usPrint\Cover.grf	测试用封面模板（可自行设计制定）
\usPrint\setting.conf	配置文件
\usPrint\usPrint.xlsm	主程序
Grid++Report自行到官网下载 开发者安装包下载 - 锐浪报表工具 (rubylong.cn) 安利下锐浪的这款报表工具 一是可以免费使用； 二是使用简单，注册好dll文件就能用，帮助文件中有详细的开发接口使用介绍； 三是报表设计人性化，比如整页填充空白行，只接设置就行了，不需要像FastReport那样还写代码；还有每页行数设定，只需要设置好数字，系统自动就可以调整行高； ……更多功能期待你的发现，毕竟我不是专门搞报表的，用得也不多

· 介绍及使用示例

一、界面

设置窗口

首次运行和改变数据字段后需要进行设置

配置说明：

索引字段（封面）：一般来说就是封面数据表中的唯一项；

索引字段（目录）：这里不能是目录数据表中的唯一项，应该是唯一项的上一级；

例如：

唯一项为：1111－111－001、1111－111－002 …… 1111－111－010

索引项应为：1111－111 这个字段

显示字段：数据预览中要显示的内容；

显示宽度：每列显示内容的宽度，单位磅，3个数字25磅能完全显示；

排序字段：就是能使唯一项按顺序排序的字段，只填写一个；

设置好后会生成setting.conf文件，下面是测试用配置文件内容：

[Cover]

IndexFields=案卷级档号

[Contens]

IndexFields=案卷级档号

DisplayNum=3

[Display1]

Fields=序号

Width=30

[Display2]

Fields=文件题名

Width=350

[Display3]

Fields=页号

Width=80

[OrderBy]

Fields=页号

使用示例：

根据数据内容选择封面或目录，选择数据文件后，左边列表会加载索引字段的内容，点击左边列表内容，右边列表显示设置的字段内容。

封面设计、目录设计只有通过 Grid++Report 报表设计器 来进行了，EXCEL的窗体加载不了报表设计器组件，不知道是EXCEL版本问题还是什么问题，VB可以，能加载组件只需要两个DLL文件可以不用安装整个Grid++Report，报表设计只能靠自己了，我也不懂，随便搞了两个模板来测试功能；

打印预览界面

打印预览只能预览当前选中项，打印时可以打印全部选中项

· 代码

sheet1

Option Explicit

Dim Report As New gregn6Lib.GridppReport

Sub showIndex()
    On Error GoTo ErrHandler
    
    Dim iCount As Integer
    Dim iOrder As Integer
    Dim strIndex As String  '索引字段的值，用于判断上一条记录和当前记录值是否相同，相同不再显示（目录数据中索引字段一卷中是相同的）
    Dim strSQL As String
    '-------------------------------------------- 打开记录集
    If Sheet1.obCover = True Then
        strSQL = "Select " & coverIndexFields & " From " & DATATABLE & " Order By " & coverIndexFields
    Else
        strSQL = "Select " & contensIndexFields & " From " & DATATABLE & " Order By " & contensIndexFields
    End If
    Set Rst = CreateObject("ADODB.Recordset")
    Rst.Open strSQL, Cnn, 1, 3
    
    If Rst.EOF Or Rst.bof Then
        MsgBox "没有数据！"
        Call clsRST
        Call clsCNN
        Exit Sub
    End If
    Rst.movefirst
    '-------------------------------------------- 输出数据
    Sheet1.lbIndex.ColumnCount = 2
    Sheet1.lbIndex.ColumnWidths = "30"
    
    iOrder = 0
    For iCount = 1 To Rst.RecordCount
        If Not Rst.Fields(0) = strIndex Then
            Sheet1.lbIndex.AddItem
            Sheet1.lbIndex.List(iOrder, 0) = iOrder + 1
            Sheet1.lbIndex.List(iOrder, 1) = Rst.Fields(0)
            iOrder = iOrder + 1
        End If
        strIndex = Rst.Fields(0)
        Rst.movenext
    Next
    Rst.Close
    Sheet1.lbIndex.MultiSelect = fmMultiSelectExtended
    Sheet1.lbIndex.Height = 472.5
Exit Sub
ErrHandler:
    If Err.Number = "94" Then Err.Description = Err.Description & vbCrLf & "请清除数据表格式后再试。"
    If Err.Number = "-2147217904" Then Err.Description = Err.Description & vbCrLf & "设置错误，请检查。"
    MsgBox Err.Number & vbCrLf & Err.Description
End Sub

Sub showContens()
    On Error GoTo ErrHandler
    Dim strIndex As String
    Dim strSQL As String
    Dim i As Integer
    Dim iCount As Integer
    '-------------------------------------------- 判断单选框
    If Sheet1.obCover = False And Sheet1.obContents = False Then
        MsgBox "请选择“封面”or“目录”。"
        Exit Sub
    ElseIf Sheet1.obCover = True Then
        Sheet1.lbContens.ColumnCount = 3
        Sheet1.lbContens.ColumnWidths = "50, 100"
        strSQL = "Select Top 1 * From " & DATATABLE & " Where " & coverIndexFields & "='" & Sheet1.lbIndex.List(Sheet1.lbIndex.ListIndex, 1) & "'"
        Rst.Open strSQL, Cnn, 1, 3
        If Rst.EOF Or Rst.bof Then
            MsgBox "没有数据！"
            Call clsRST
            Call clsCNN
            Exit Sub
        End If
'        Rst.movefirst
        For i = 0 To Rst.Fields.Count - 1
            Sheet1.lbContens.AddItem
            Sheet1.lbContens.List(i, 0) = i + 1
            Sheet1.lbContens.List(i, 1) = Rst.Fields(i).Name
            If IsNull(Rst.Fields(i)) Then
                Sheet1.lbContens.List(i, 2) = ""
            Else
                Sheet1.lbContens.List(i, 2) = Rst.Fields(i)
            End If
        Next
        
    ElseIf Sheet1.obContents = True Then
        Sheet1.lbContens.ColumnCount = CInt(iDisplayNum)
    '    Sheet1.lbContens.ColumnHeads = False
        strSQL = "Select " & contensIndexFields
        For i = 1 To iDisplayNum
            strSQL = strSQL & ", " & arrfields(i)
        Next
        '--------------------------------------------
        Sheet1.lbContens.ColumnWidths = strWidths
        'Set Rst = CreateObject("ADODB.Recordset")
        strSQL = strSQL & " From " & DATATABLE & " Where " & contensIndexFields & "='" & Sheet1.lbIndex.List(Sheet1.lbIndex.ListIndex, 1) & "' Order By " & contensIndexFields & ", " & strOrder & " asc"
        'If Cnn.State <> 1 Then Call cnnDB
        Rst.Open strSQL, Cnn, 1, 3
        If Rst.EOF Or Rst.bof Then
            MsgBox "没有数据！"
            Call clsRST
            Call clsCNN
            Exit Sub
        End If
        Rst.movefirst
        '-------------------------------------------- 输出数据
        For iCount = 0 To Rst.RecordCount - 1
            Sheet1.lbContens.AddItem
            For i = 1 To iDisplayNum
                Sheet1.lbContens.List(iCount, i - 1) = Rst.Fields(i)
            Next
            Rst.movenext
        Next
    End If
    If Rst.State = 1 Then Rst.Close
    Sheet1.lbContens.MultiSelect = fmMultiSelectExtended
    Sheet1.lbContens.Height = 472.5
Exit Sub
ErrHandler:
    Sheet1.lbContens.Height = 472.5
    If Err.Number = "94" Then Err.Description = Err.Description & vbCrLf & "请清除数据表格式后再试。"
    If Err.Number = "-2147217904" Then Err.Description = Err.Description & vbCrLf & "设置错误，请检查。"
    MsgBox Err.Number & vbCrLf & Err.Description

End Sub

Private Sub cbChooseFile_Click()
    Dim fd As FileDialog
    
    '-------------------------------------------- 初始化
    Sheet1.lFilePath = ""
    Call initListBox(Sheet1.lbIndex)
    Call initListBox(Sheet1.lbContens)
    
    '-------------------------------------------- 选择文件窗口
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    fd.Filters.Add "excel文件", "*.xls;*.xlsx", 1
    fd.InitialFileName = ThisWorkbook.Path                      '默认打开目录
    If fd.Show = -1 Then
        Sheet1.lFilePath = fd.SelectedItems(1)
    Else
        Exit Sub
    End If
    Set fd = Nothing
    '-------------------------------------------- 调用数据连接、数据显示
    Call cnnDB
    Call showIndex

End Sub

Private Sub cbConfig_Click()
    ufSetting.Show
End Sub

Private Sub cbPrint_Click()
    Dim i As Integer
    Dim strSQL As String
    For i = 0 To Sheet1.lbIndex.ListCount - 1
        If Sheet1.lbIndex.Selected(i) = True Then
            If Sheet1.obCover = True Then
                Report.LoadFromFile (ThisWorkbook.Path & "\Cover.grf")
                Report.DetailGrid.Recordset.ConnectionString = GetDatabaseConnectionString()
                strSQL = "Select * From " & DATATABLE & " Where " & coverIndexFields & "='" & Sheet1.lbIndex.List(i, 1) & "'"
                Report.DetailGrid.Recordset.QuerySQL = strSQL
            Else
                Report.LoadFromFile (ThisWorkbook.Path & "\Contens.grf")
                Report.DetailGrid.Recordset.ConnectionString = GetDatabaseConnectionString()
                strSQL = "Select * From " & DATATABLE & " Where " & contensIndexFields & "='" & Sheet1.lbIndex.List(i, 1) & "'"
                Report.DetailGrid.Recordset.QuerySQL = strSQL & " Order By " & contensIndexFields & ", " & strOrder & " asc"
            End If
            Report.PrintEx grpgsAll, False
            Sheet1.lbContens.Height = 472.5
        End If
    Next
End Sub

Private Sub cbPrintPreview_Click()
    Dim strSQL As String
    If Sheet1.lbIndex.ListIndex < 0 Then MsgBox "请选择数据！": Exit Sub
    
    If Sheet1.obCover = False And Sheet1.obContents = False Then MsgBox "请选择 封面 或 目录。": Exit Sub
    If Sheet1.obCover = True Then
        Report.LoadFromFile (ThisWorkbook.Path & "\Cover.grf")
        Report.DetailGrid.Recordset.ConnectionString = GetDatabaseConnectionString()
        strSQL = "Select * From " & DATATABLE & " Where " & coverIndexFields & "='" & Sheet1.lbIndex.List(Sheet1.lbIndex.ListIndex, 1) & "'"
        Report.DetailGrid.Recordset.QuerySQL = strSQL
    Else
        Report.LoadFromFile (ThisWorkbook.Path & "\Contens.grf")
        Report.DetailGrid.Recordset.ConnectionString = GetDatabaseConnectionString()
        strSQL = "Select * From " & DATATABLE & " Where " & contensIndexFields & "='" & Sheet1.lbIndex.List(Sheet1.lbIndex.ListIndex, 1) & "'"
        Report.DetailGrid.Recordset.QuerySQL = strSQL & " Order By " & contensIndexFields & ", " & strOrder & " asc"
    End If
    
    Report.PrintPreview (False)
    Sheet1.lbContens.Height = 472.5
    
End Sub

Private Sub cbRest_Click()
    ThisWorkbook.Workbook_Open
End Sub

Private Sub lbIndex_Change()
    Call initListBox(Sheet1.lbContens)
    Call showContens
End Sub

Private Sub obContents_Click()
    Call obChange
    With Sheet1
        .cbDesignCover.Enabled = False
        .cbDesignContens.Enabled = True
    End With
End Sub

Private Sub obCover_Click()
    Call obChange
    With Sheet1
        .cbDesignCover.Enabled = True
        .cbDesignContens.Enabled = False
    End With
End Sub

模块1

'================================================ API声明
#If VBA7 And Win64 Then
    Public Declare PtrSafe Function GetPrivateProfileString _
        Lib "kernel32" Alias "GetPrivateProfileStringA" ( _
            ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, _
            ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
    Public Declare PtrSafe Function WritePrivateProfileString _
        Lib "kernel32" Alias "WritePrivateProfileStringA" ( _
            ByVal lpApplicationName As String, ByVal lpKeyName As Any, _
            ByVal lpString As Any, ByVal lpFileName As String) As Long
    Public Declare PtrSafe Function WritePrivateProfileSection _
        Lib "kernel32" Alias "WritePrivateProfileSectionA" ( _
            ByVal lpAppName As String, _
            ByVal lpString As String, _
            ByVal lpFileName As String) As Long
#Else
    Public Declare Function GetPrivateProfileString _
        Lib "kernel32" Alias "GetPrivateProfileStringA" ( _
            ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, _
            ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFilename As String) As Long
    Public Declare Function WritePrivateProfileString _
        Lib "kernel32" Alias "WritePrivateProfileStringA" ( _
            ByVal lpApplicationName As String, ByVal lpKeyName As Any, _
            ByVal lpString As Any, ByVal lpFilename As String) As Long
    Public Declare Function WritePrivateProfileSection _
        Lib "kernel32" Alias "WritePrivateProfileSectionA" ( _
            ByVal lpAppName As String, _
            ByVal lpString As String, _
            ByVal lpFileName As String) As Long
#End If

'================================================ 全局变量
Public Cnn As Object
Public Rst As Object
Public coverIndexFields As String
Public contensIndexFields As String
Public strOrder As String
Public iDisplayNum As Integer
Public strColumnWidths As String
Public strWidths As String
Public arrfields() As String


'================================================ 全局常量
Public Const CONFILE = "\setting.conf"
Public Const DATATABLE = "[Sheet1$]"





'================================================ 函数&过程

'================================================ sub cnnDB()
'过程名：cnnDB
'参数：无
'作用：连接EXCEL作为数据源
'------------------------------------------------
Sub cnnDB()
    On Error Resume Next
    
    Dim dataSource, strCnn As String
    Set Cnn = CreateObject("ADODB.Connection")
    
    dataSource = Sheet1.lFilePath
    If Val(Application.Version) < 12 Then
        strCnn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=YES;IMEX=1';Data Source='" & dataSource & "'"
    Else
        strCnn = "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=YES;IMEX=1';Data Source='" & dataSource & "'"
    End If
    Cnn.Open strCnn
    
    If Cnn.State <> 1 Then MsgBox "数据连接失败！": Call clsCNN

End Sub

'================================================ sub clsCNN()
'过程名：clsCNN
'参数：无
'作用：关闭数据库并释放对象cnn
'------------------------------------------------
Sub clsCNN()
    If Cnn.State = 1 Then Cnn.Close
    Set Cnn = Nothing
End Sub

'================================================ sub clsRST()
'过程名：clsRST
'参数：无
'作用：关闭记录集并释放对象rst
'------------------------------------------------
Sub clsRST()
    If Rst.State = 1 Then Rst.Close
    Set Rst = Nothing
End Sub

'================================================ fun existTable()
'函数名：existTable
'参数：tableName
'作用：判断数据库中表是否存在
'返回值：True/False
'------------------------------------------------
Function existTable(tableName As String) As Boolean
    Call cnnDB
    Set Rst = Cnn.openschema(20)    '------------ 参见ADO Connection对象OpenSchema方法，SchemaEnum 值：adSchemaTables
    While Not Rst.EOF
        If Rst!table_name = tableName Then existTable = True: Exit Function
        Rst.movenext
    Wend
End Function

'================================================ fun readConfig()
'函数名：readConfig
'参数：lpSection,lpKey
'作用：读取配置文件
'返回值：返回键值
'------------------------------------------------
Function readConfig(lpSection As String, lpKey As String) As String
    Dim NC As Long
    Dim lpREC As String
    lpREC = String(255, Chr(0))
    lpFileName = ThisWorkbook.Path & CONFILE
    NC = GetPrivateProfileString(lpSection, lpKey, "", lpREC, 255, lpFileName)
    readConfig = Left(lpREC, InStr(lpREC, Chr(0)) - 1)
End Function

'================================================ sub writeConfig
'过程名：writeConfig
'参数：lpSection,lpKey,lpValue,lpFileName
'作用：写入配置文件
'------------------------------------------------
Sub writeConfig(lpSection As String, lpKey As String, lpValue As String)
    Dim NC As Long
    lpFileName = ThisWorkbook.Path & CONFILE
    NC = WritePrivateProfileString(lpSection, lpKey, lpValue, lpFileName)
End Sub

'================================================ fun isExistsFile()
'函数名：isExistsFile
'参数：iFile
'作用：判断文件是否存在
'返回值：True/False
'------------------------------------------------
Function isExistsFile(iFile As String) As Boolean
    Set Fs = CreateObject("Scripting.FileSystemObject")
    If Fs.FileExists(iFile) Then isExistsFile = True
End Function

'================================================ sub initListBox()
'过程名：initListBox
'参数：objListBox：ListBox名
'作用：初始化ListBox

Sub initListBox(objListBox As Object)
'    Dim iCount As Integer
'    With objListBox
'        For iCount = 1 To .ListCount
'            .RemoveItem 0
'        Next
'
'        .Height = 472.5
'    End With
    objListBox.Clear
    objListBox.Height = 472.5
End Sub

Public Function GetDatabaseConnectionString() As String
    GetDatabaseConnectionString = "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=YES;IMEX=1';Data Source=" _
    + Sheet1.lFilePath + ";"
End Function

Public Sub obChange()
    '-------------------------------------------- 判断单选框
    If Sheet1.obCover = False And Sheet1.obContents = False Then
        MsgBox "请选择“封面”or“目录”。"
        Exit Sub
    ElseIf Sheet1.obCover = True Then
        coverIndexFields = readConfig("Cover", "IndexFields")
    ElseIf Sheet1.obContents = True Then
        contensIndexFields = readConfig("Contens", "IndexFields")
        iDisplayNum = CInt(readConfig("Contens", "DisplayNum"))
        strOrder = readConfig("OrderBy", "Fields")
        ReDim arrfields(iDisplayNum)
        For i = 1 To iDisplayNum
            If Len(strWidths) = 0 Then
                strWidths = readConfig("Display" & i, "Width")
            Else
                strWidths = strWidths & "," & readConfig("Display" & i, "Width")
            End If
            arrfields(i) = readConfig("Display" & i, "Fields")
        Next
    End If
End Sub

· 下载地址：usPrint_20230318.rar

https://url19.ctfile.com/f/37661619-825962137-f013d7?p=9521 (访问密码: 9521)

· 最后，再次感谢 锐浪软件 提供免费的报表工具