校运会自动报表系统

djk1020

校运会自动报表系统(exe版).rar (347.06 KB, 下载次数: 19)

2016-4-20 21:30 上传

点击文件名下载附件

djk1020

更新：
1、修改了原错误处理程序，增加了几处错误处理程序；
2、更正了一处小Bug：由于系统短日期格式设置的不同，原算法在打开已存在的文件时可能提示找不到。
校运会自动报表系统.rar (350.79 KB, 下载次数: 34)

2016-4-27 09:13 上传

点击文件名下载附件
exe版

djk1020

后记：
　　编此工具最初是为了方便自己，因而当时功能设计相对简单，对操作者也有一定的要求。为了分享给大家，后断断续续进行了相关功能的完善及增设，由最初的VBA宏模块到DLL再到现在的EXE版，易用性逐步得到提高。编程知识还是快二十年前在大学时自学的，毕业后由于各种原因公共课程就没继续考了，过去学过Pascal、Foxpro、C/C++等语言，VB从未接触过，VB启蒙还是从本论坛开始的(看过“别怕，Excel VBA其实很简单”)，在完成这个编程的过程中我也是一边构想一边查说明完成的。
　　在由DLL版升级到EXE版时速度明显变慢了，本来在逻辑上没有问题的程序在实际运行时却出现了错误，仔细分析原来是程序中大量用到了选择操作，由于运行时间过长，在此期间当你点了窗口中的其它工作表时就出现错误了，为提高速度及防止出错，我的不是经验的经验是：
　　1 、能不用select方法的尽量不用；
　　2、少用activesheet/activeworkbook等对象，应及时用变量引用这类对象。

djk1020

部分代码：
1、程序入口
Sub Main()
    If Dir(App.Path & "\号码对照表及分组分道编排.xlt") = "" Then
        MsgBox "文件缺失，请联系作者!"
    Else
        Dim RemoveX As New RemoveControlBoxClass
        '屏蔽Excel的控制菜单
        RemoveX.RemoveX (Xlapp.hWnd)
        '屏蔽Excel的任务栏窗口右键菜单???????
        
        With Xlapp
            '屏蔽Excel的文件菜单
            .CommandBars(1).Controls("文件(&F)").Enabled = False
            '屏蔽Excel的保护子菜单
            .CommandBars(1).Controls("工具(&T)").Controls("保护(&P)").Enabled = False
            '屏蔽Excel的关闭快捷键
            .OnKey "^{F4}", "" '关闭文件
            .OnKey "%{F4}", "" '关闭Excel
            
            SetWindowPos MainMenu.hWnd, -1, 602, 0, 360, 185, 0
            MainMenu.Show 1 '模式窗口，直到窗体被隐藏或卸载才执行后面的语句
            
            '恢复Excel的文件菜单
            .CommandBars(1).Controls("文件(&F)").Enabled = True
            '恢复Excel的保护子菜单
            .CommandBars(1).Controls("工具(&T)").Controls("保护(&P)").Enabled = True
            '恢复Excel的关闭快捷键
            .OnKey "^{F4}"
            .OnKey "%{F4}"
        End With
    End If
    Set Xlapp = Nothing
End Sub

djk1020

2、主界面菜单控件代码(一)
Option Explicit
Dim ClickTimes As Integer
Dim DefaultPath$, File_Name$
Sub ResetForm()
    '重置菜单项状态
    With Me
        If Val(Left(RegTestBackVal, 1)) = 0 Then
            '合法用户，无功能限制
            .New(111).Enabled = True
            .Open(112).Enabled = True
            .DefaultFolder(21).Enabled = True
            .initialize(22).Enabled = True
        Else
            '非法用户或试用结束，有功能限制
            .New(111).Enabled = False
            .Open(112).Enabled = False
            .DefaultFolder(21).Enabled = False
            .initialize(22).Enabled = False
        End If
        .PrintBMB(113).Enabled = False
        .MNBM(114).Enabled = False
        .consolidate(1211).Enabled = False
        .Sort(1212).Enabled = False
        .CreateReport(122).Enabled = False
        .PrintReport(123).Enabled = False
        .Save(14).Enabled = False
        .Close(15).Enabled = False
    End With
End Sub
Private Sub Form_Load()
    '初始化
    ClickTimes = 0
    RegTestBackVal = MyApp.RegisterCheck()
    ResetForm '重置菜单项状态
End Sub
Private Sub Label1_Click()
    '操作说明
    ClickTimes = ClickTimes + 1
    With Me
        If ClickTimes Mod 2 = 1 Then
            .Label1.Caption = "操作步骤："
            .Label2.Caption = _
                "一、基础数据设置：" & Chr(10) & _
                "1、设置默认保存目录，也可在保存时第一次指定；" & Chr(10) & _
                "2、单击〖设置〗→〖初始化〗，完成班级设置及班主任名单。" & Chr(10) & _
                "二、登记报名情况：" & Chr(10) & _
                "1、单击〖文件〗→〖报名登记表〗→〖新建〗/〖打开〗；" & Chr(10) & _
                "2、输入或修改各班报名情况。" & Chr(10) & _
                "三、报表打印输出：汇总数据→生成报表→报表打印。" & Chr(10) & _
                "特别提醒：文件修改后需通过〖保存〗菜单项来保存更改!"
        Else
            .Label1.Caption = "说明..."
            .Label2.Caption = ""
        End If
    End With
End Sub
Private Sub New_Click(Index As Integer)
    '基于模板新建并生成报名登记表
    With Me '改变菜单项状态
        .New(111).Enabled = False
        .Open(112).Enabled = False
        .initialize(22).Enabled = False
        .PrintBMB(113).Enabled = True
        .MNBM(114).Enabled = True
        .consolidate(1211).Enabled = True
        .Save(14).Enabled = True
        .Close(15).Enabled = True
    End With
    With Xlapp
        .ScreenUpdating = False '关闭屏幕更新
        .Workbooks.Add (App.Path & "\号码对照表及分组分道编排.xlt")
        .Visible = True '显示Excel窗口
        With .ActiveWorkbook
            '撤消工作簿保护
            .Unprotect
            MyApp.CreateBMB
            '保护工作簿
            .Protect Structure:=True, Windows:=True
        End With
        .ScreenUpdating = True '恢复屏幕更新
    End With
End Sub

djk1020

4、主界面菜单控件代码(三)
Private Sub CreateReport_Click(Index As Integer)
    '生成报表：对当前窗口中汇总好了的数据 自动编号，再生成 号码对照表报表 和 比赛项目名单报表
    With Xlapp
        If .Workbooks.Count = 0 Then
            MsgBox "文件被关闭!", vbInformation, MsgBoxTitle
            ResetForm
        Else
            Me.PrintReport(123).Enabled = True '更改菜单状态
            '自动生成报表
            .ScreenUpdating = False '关闭屏幕更新
            With .ActiveWorkbook
                .Unprotect
                MyApp.Report
                .Protect Structure:=True, Windows:=True
            End With
            .Worksheets("号码对照表报表").Select
            .Range("A1").Select
            .ScreenUpdating = True '恢复屏幕更新
        End If
    End With
End Sub
Private Sub PrintReport_Click(Index As Integer)
    '打印当前窗口中的报表(号码对照表和分组分道编排表)
    If Xlapp.Workbooks.Count = 0 Then
        MsgBox "文件被关闭!", vbInformation, MsgBoxTitle
        ResetForm
    Else
        If MsgBox("准备好了要打印吗？", vbYesNo + vbQuestion, MsgBoxTitle) = vbYes Then
            On Error Resume Next
            Xlapp.Sheets(Array("号码对照表报表", "比赛项目名单报表")).PrintOut Copies:=1
        End If
    End If
End Sub
Private Sub Save_Click(Index As Integer)
    If Xlapp.Workbooks.Count = 0 Then
        MsgBox "文件被关闭!", vbInformation, MsgBoxTitle
        ResetForm
    Else
        If Xlapp.ActiveWorkbook.Path <> "" Then
            '存过盘的文件
            Xlapp.ActiveWorkbook.Save
        Else '未存过盘的新文件(基于模板新建的，应保存为.xls类型)
            '从注册表读取默认目录
            DefaultPath = GetSetting(ExcelName, "SportsMeetReportForms\MySection", "DefaultPath")
            If DefaultPath = "" Then
                '设置默认目录
                MsgBox "请指定保存的默认目录!", vbInformation, MsgBoxTitle
                DefaultPath = MyApp.PathLocation
                If DefaultPath <> "1" Then
                    SaveSetting ExcelName, "SportsMeetReportForms\MySection", "DefaultPath", DefaultPath
                Else
                    Exit Sub
                End If
            End If
            '自动命名并保存到默认目录
            File_Name = "号码对照表及分组分道编排表_" & Year(Date) & "-" & Right("0" & Month(Date), 2) & _
                 "-" & Right("0" & Day(Date), 2) & "_" & Right("00000" & Int(Timer), 5) & ".xls"
            Xlapp.ActiveWorkbook.SaveAs DefaultPath + "\" + File_Name
        End If
    End If
End Sub
Private Sub Close_Click(Index As Integer)
    '直接关闭Excel文件窗口(不保存更改)
    With Xlapp
        If .Workbooks.Count = 0 Then
            MsgBox "文件被关闭!", vbInformation, MsgBoxTitle
        Else
            .ActiveWorkbook.Saved = True
            .ActiveWorkbook.Close
            .Visible = False
        End If
    End With
    ResetForm
End Sub
Private Sub Quit_Click(Index As Integer)
    '退出Excel和本系统
    With Xlapp
        If .Workbooks.Count <> 0 Then
            .ActiveWorkbook.Saved = True
            .ActiveWorkbook.Close
        End If
        .Quit '退出excel
    End With
    Unload Me '关闭程序主界面，退出本系统
End Sub
Private Sub DefaultFolder_Click(Index As Integer)
    '设置默认目录
    Dim bHide As Boolean
    bHide = Xlapp.Visible
    DefaultPath = GetSetting(ExcelName, "SportsMeetReportForms\MySection", "DefaultPath")
    If DefaultPath <> "" Then
        If MsgBox("默认目录已设置：" & Chr(10) & DefaultPath & Chr(10) & "要修改吗？", _
                vbYesNo + vbQuestion, MsgBoxTitle) = vbYes Then
            DefaultPath = MyApp.PathLocation
            If bHide = False Then
                Xlapp.Visible = False
            End If
            If DefaultPath = "1" Then
                Exit Sub
            End If
            SaveSetting ExcelName, "SportsMeetReportForms\MySection", "DefaultPath", DefaultPath
        End If
    Else
        MsgBox "请指定保存的默认目录!", vbInformation, MsgBoxTitle
        DefaultPath = MyApp.PathLocation
        If bHide = False Then
            Xlapp.Visible = False
        End If
        If DefaultPath = "1" Then
            Exit Sub
        End If
        SaveSetting ExcelName, "SportsMeetReportForms\MySection", "DefaultPath", DefaultPath
    End If
End Sub
Private Sub initialize_Click(Index As Integer)
    '打开模板，设置原始数据
    With Xlapp
        .Workbooks.Open FileName:=App.Path + "\号码对照表及分组分道编排.xlt", Editable:=True
        .ActiveWorkbook.Unprotect
        .ActiveWorkbook.Protect Structure:=True, Windows:=True
        .Visible = True
    End With
    '更改菜单状态
    With Me
        .New(111).Enabled = False
        .Open(112).Enabled = False
        .initialize(22).Enabled = False
        .Save(14).Enabled = True
        .Close(15).Enabled = True
    End With
End Sub
Private Sub About_Click(Index As Integer)
    '打开关于界面
    MyApp.About (RegTestBackVal)
End Sub

djk1020

部分程序代码：
1、主程序
Sub Main()
    If Dir(App.Path & "\号码对照表及分组分道编排.xlt") = "" Then
        MsgBox "文件缺失，请联系作者!"
    Else
        Dim RemoveX As New RemoveControlBoxClass
        '屏蔽Excel的控制菜单
        RemoveX.RemoveX (Xlapp.hWnd)
        '屏蔽Excel的任务栏窗口右键菜单???????
        
        With Xlapp
            '屏蔽Excel的文件菜单
            .CommandBars(1).Controls("文件(&F)").Enabled = False
            '屏蔽Excel的保护子菜单
            .CommandBars(1).Controls("工具(&T)").Controls("保护(&P)").Enabled = False
            '屏蔽Excel的关闭快捷键
            .OnKey "^{F4}", "" '关闭文件
            .OnKey "%{F4}", "" '关闭Excel
            
            SetWindowPos MainMenu.hWnd, -1, 602, 0, 360, 185, 0
            MainMenu.Show 1 '模式窗口，直到窗体被隐藏或卸载才执行后面的语句
            
            '恢复Excel的文件菜单
            .CommandBars(1).Controls("文件(&F)").Enabled = True
            '恢复Excel的保护子菜单
            .CommandBars(1).Controls("工具(&T)").Controls("保护(&P)").Enabled = True
            '恢复Excel的关闭快捷键
            .OnKey "^{F4}"
            .OnKey "%{F4}"
        End With
    End If
    Set Xlapp = Nothing
End Sub

djk1020

3、主界面菜单控件代码(二)
Private Sub Open_Click(Index As Integer)
    '打开 默认位置 特定名称 的最新文件
    Dim arr() As String, arr_Date() As Date, arr_Time() As Long
    Dim i%, j%, p%, m%, n%
    '从注册表读取默认目录
    DefaultPath = GetSetting(ExcelName, "SportsMeetReportForms\MySection", "DefaultPath")
    If DefaultPath = "" Then
        MsgBox "文件不存在，请先建立!", vbInformation, MsgBoxTitle
    Else
        i = 0
        File_Name = Dir(DefaultPath & "\号码对照表及分组分道编排表_????-??-??_?????.xls")
        While File_Name <> "" '取得默认目录下的所有特定文件及数目
            i = i + 1
            ReDim Preserve arr(1 To i) As String
            arr(i) = File_Name
            File_Name = Dir
        Wend
        If i = 0 Then
            MsgBox "文件不存在，请先建立!", vbInformation, MsgBoxTitle
        Else
            ReDim arr_Date(1 To i) As Date
            ReDim arr_Time(1 To i) As Long
            For j = 1 To i
                arr_Date(j) = CDate(Replace(Mid(arr(j), 15, 10), "-", "/"))
                arr_Time(j) = CLng(Left(Right(arr(j), 9), 5))
            Next
            '取得最新文件
            p = 1
            For j = 2 To i
                m = arr_Date(j) - arr_Date(p)
                If m > 0 Then
                    p = j
                Else
                    If m = 0 Then
                        If arr_Time(j) - arr_Time(p) > 0 Then
                            p = j
                        End If
                    End If
                End If
            Next
            File_Name = arr(p)
            '打开
            With Xlapp
                .ScreenUpdating = False
                .Workbooks.Open DefaultPath & "\" & File_Name
                .ActiveWorkbook.Unprotect
                .ActiveWorkbook.Protect Structure:=True, Windows:=True
                .Worksheets("1").Select
                .Range("C4").Select
                .Visible = True '显示Excel窗口
                .ScreenUpdating = True
            End With
            With Me
                '设置菜单项状态
                .New(111).Enabled = False
                .Open(112).Enabled = False
                .initialize(22).Enabled = False
                .PrintBMB(113).Enabled = True
                .MNBM(114).Enabled = True
                .consolidate(1211).Enabled = True
                .Save(14).Enabled = True
                .Close(15).Enabled = True
               
                Set WkSht(1) = Xlapp.Sheets("班级设置及班主任名单")
                m = WkSht(1).Range("B8").Value '班级总数
                Set WkSht(1) = Nothing
               
                n = Xlapp.Sheets.Count '工作表总数
                If n >= m + 4 Then
                    .Sort(1212).Enabled = True
                    .CreateReport(122).Enabled = True
                    If n = m + 6 Then
                        .PrintReport(123).Enabled = True
                    End If
                End If
            End With
        End If
    End If
End Sub
Private Sub PrintBMB_Click(Index As Integer)
    '打印窗口中的报名登记表样表
    With Xlapp
        If .Workbooks.Count = 0 Then
            MsgBox "文件被关闭!", vbInformation, MsgBoxTitle
            ResetForm
        Else
            Set WkSht(2) = .Worksheets("报名表样表")
            .ScreenUpdating = False '关闭屏幕更新
            .ActiveWorkbook.Unprotect
            WkSht(2).Visible = True
            If MsgBox("准备好了要打印『报名表』吗？", vbYesNo + vbQuestion, MsgBoxTitle) = vbYes Then
                On Error Resume Next
                WkSht(2).PrintOut Copies:=1
            End If
            WkSht(2).Visible = False
            ActiveWorkbook.Protect Structure:=True, Windows:=True
            Set WkSht(2) = Nothing
            .ScreenUpdating = True '恢复屏幕更新
        End If
    End With
End Sub
Private Sub MNBM_Click(Index As Integer)
    '模拟报名
    If Xlapp.Workbooks.Count = 0 Then
        MsgBox "文件被关闭!", vbInformation, MsgBoxTitle
        ResetForm
    Else
        MyApp.MNBM
    End If
End Sub
Private Sub consolidate_Click(Index As Integer)
    '对当前窗口汇总数据
    If Xlapp.Workbooks.Count = 0 Then
        MsgBox "文件被关闭!", vbInformation, MsgBoxTitle
        ResetForm
    Else
        With Me
            .Sort(1212).Enabled = True
            .CreateReport(122).Enabled = True
        End With
        With Xlapp
            .ScreenUpdating = False
            .ActiveWorkbook.Unprotect
            .DisplayAlerts = False
            For Each Sht In .Worksheets
                If Sht.Name = "号码对照表" Then
                    Sht.Delete
                End If
            Next
            .DisplayAlerts = True
            Set WkSht(3) = .Worksheets("比赛项目名单")
            .Worksheets.Add(before:=WkSht(3)).Name = "号码对照表"
            .Cells(1, 1).Value = "姓名"
            .Cells(1, 2).Value = "号码"
            WkSht(3).Visible = True
            Set WkSht(3) = Nothing
            Me.Caption = MsgBoxTitle + " - 正在汇总报名信息，请稍候..."
            MyApp.SJHZ
            Me.Caption = MsgBoxTitle
            .ActiveWorkbook.Protect Structure:=True, Windows:=True
            .ScreenUpdating = True
        End With
    End If
End Sub
Private Sub Sort_Click(Index As Integer)
    '对当前窗口中的数据排序
    If Xlapp.Workbooks.Count = 0 Then
        MsgBox "文件被关闭!", vbInformation, MsgBoxTitle
        ResetForm
    Else
        MyApp.SJPX
    End If
End Sub

djk1020

审核太慢了!                                

djk1020