frmmain.frm

用vb6.0实现的一个可以通用的企业档案管理系统。

'"数据备份"菜单单击事件
Private Sub mnuDatabaseBackup_Click()
    Dim fDataBack As frmDataBackup
    
    Set fDataBack = New frmDataBackup
    fDataBack.Show vbModal   '弹出数据备份窗体
    
End Sub

'"数据库初始化"菜单单击事件
Private Sub mnuDatabaseInit_Click()
Dim Msg As String

Msg = MsgBox("数据库初始化将删除除文书类型表以外的所有数据！按[确定]继续。", vbYesNo + vbInformation)
Select Case Msg
    Case vbYes
    '通过SQL语句删除所有数据
    With conCaseMain
        Screen.MousePointer = vbHourglass
        .Execute "DELETE FROM dj_qy"
        .Execute "DELETE FROM dj_gt"
        .Execute "DELETE FROM dj_wg"
        .Execute "DELETE FROM dj_wz"
        .Execute "DELETE FROM dj_zc"
        .Execute "DELETE FROM sys_Image"
        .Execute "DELETE FROM sys_Path"
        .Execute "DELETE FROM Operation_System_Rules_Detail"
        .Execute "DELETE FROM Operation_UserDefined_Rules"
        .Execute "DELETE FROM Operation_System_Rules"
    End With
    MsgBox "数据库初始化完毕！", vbInformation
    
    '显示示忙窗体
    frmMsg.Show
    frmMsg.Refresh
    
    '刷新fCenter
    Unload fCenter
    Load fCenter
    
    Unload frmMsg
    fCenter.Show
    Screen.MousePointer = vbDefault
    
End Select

End Sub

'"系统导入"菜单单击事件
Private Sub mnuDataImport_Click()
    Dim fZT97Import As frmZT97Import

    Set fZT97Import = New frmZT97Import   '注意创建方式
    fZT97Import.Show vbModal   '通过fZT97Import窗体导入数据
    
End Sub

'"数据库整理"菜单单击事件
Private Sub mnuDatebaseClean_Click()

    Dim DatabaseName
    Dim dbFileName As String
    
    DatabaseName = App.Path & "\data\" & "CaseMain.mdb"
    On Error Resume Next
    Screen.MousePointer = vbHourglass  '设定鼠标形状
    DoEvents
    DBEngine.CompactDatabase DatabaseName, DatabaseName  '压缩修复数据库
    DoEvents
    On Error Resume Next
    Kill App.Path & "\data\" + "OLD.MDB"    '删除备份数据库
    Name App.Path & "\data\" As App.Path & "\data\" + "OLD.MDB"  '创建新的数据库备份
    On Error GoTo ErrorHandler
    
    Screen.MousePointer = vbDefault   '设定鼠标形状为原来的
    MsgBox "数据库整理完毕，欢迎继续使用本系统。", vbOKOnly + vbInformation, "系统提示"
    
    Exit Sub
ErrorHandler:
    If Err Then
        MsgBox Err.Description, vbInformation
        Err.Clear
    End If
End Sub

'"文书删除"菜单单击事件
Private Sub mnuDelCase_Click()
    Dim fDelCase As frmDelCase
   
    Set fDelCase = New frmDelCase
    fDelCase.Show vbModal  '显示文书删除窗体
End Sub

'"文书转移"菜单单击事件
Private Sub mnuFileMove_Click()
    Dim fMoveFile As frmMoveFile
    
    Set fMoveFile = New frmMoveFile
    fMoveFile.Show vbModal    '显示移动文书窗体
End Sub

Private Sub mnuHelpAbout_Click()
    frmAbout.Show vbModal, Me
End Sub

Private Sub mnuHelpSearchForHelpOn_Click()
    Dim nRet As Integer

    '如果这个工程没有帮助文件，显示消息给用户
    '可以在“工程属性”对话框中为应用程序设置帮助文件
    If Len(App.HelpFile) = 0 Then
        MsgBox "无法显示帮助目录，该工程没有相关联的帮助。", vbInformation, Me.Caption
    Else

    On Error Resume Next
        nRet = OSWinHelp(Me.hwnd, App.HelpFile, 261, 0)
        If Err Then
            MsgBox Err.Description
        End If
    End If

End Sub

Private Sub mnuHelpContents_Click()
    Dim nRet As Integer


    '如果这个工程没有帮助文件，显示消息给用户
    '可以在“工程属性”对话框中为应用程序设置帮助文件
    If Len(App.HelpFile) = 0 Then
        MsgBox "无法显示帮助目录，该工程没有相关联的帮助。", vbInformation, Me.Caption
    Else
        On Error Resume Next
        nRet = OSWinHelp(Me.hwnd, App.HelpFile, 3, 0)
        If Err Then
            MsgBox Err.Description
        End If
    End If

End Sub


Private Sub mnuModeManage_Click()
    Dim fNewMode As frmNewMode
    Set fNewMode = New frmNewMode
    fNewMode.Show vbModal
End Sub

'"文件存放路径设置"菜单单击事件
Private Sub mnuImgPathSet_Click()
    Dim fImgPathSet As frmImgPathSet
    
    Set fImgPathSet = New frmImgPathSet
    fImgPathSet.Show vbModal   '显示文件路径设置窗体
End Sub

Private Sub mnuWindowArrangeIcons_Click()
    Me.Arrange vbArrangeIcons
End Sub

Private Sub mnuWindowTileVertical_Click()
    Me.Arrange vbTileVertical
End Sub

Private Sub mnuWindowTileHorizontal_Click()
    Me.Arrange vbTileHorizontal
End Sub

Private Sub mnuWindowCascade_Click()
    Me.Arrange vbCascade
End Sub

Private Sub mnuWindowNewWindow_Click()
    LoadNewDoc
End Sub

Private Sub mnuViewWebBrowser_Click()
    '应做:添加 'mnuViewWebBrowser_Click' 代码。
    MsgBox "添加 'mnuViewWebBrowser_Click' 代码。"
End Sub

Private Sub mnuViewOptions_Click()
    '应做:添加 'mnuViewOptions_Click' 代码。
    MsgBox "添加 'mnuViewOptions_Click' 代码。"
End Sub

Private Sub mnuViewRefresh_Click()
    '应做:添加 'mnuViewRefresh_Click' 代码。
    MsgBox "添加 'mnuViewRefresh_Click' 代码。"
End Sub

Private Sub mnuViewToolbar_Click()
    '应做:添加 'mnuViewToolbar_Click' 代码。
    MsgBox "添加 'mnuViewToolbar_Click' 代码。"
End Sub

Private Sub mnuEditPasteSpecial_Click()
    '应做:添加 'mnuEditPasteSpecial_Click' 代码。
    MsgBox "添加 'mnuEditPasteSpecial_Click' 代码。"
End Sub

Private Sub mnuEditPaste_Click()
    On Error Resume Next
    ActiveForm.rtfText.SelRTF = Clipboard.GetText

End Sub

Private Sub mnuEditCopy_Click()
    On Error Resume Next
    Clipboard.SetText ActiveForm.rtfText.SelRTF

End Sub

Private Sub mnuEditCut_Click()
    On Error Resume Next
    Clipboard.SetText ActiveForm.rtfText.SelRTF
    ActiveForm.rtfText.SelText = vbNullString

End Sub

Private Sub mnuEditUndo_Click()
    '应做:添加 'mnuEditUndo_Click' 代码。
    MsgBox "添加 'mnuEditUndo_Click' 代码。"
End Sub

Private Sub mnuFileExit_Click()
    '卸载窗体
Call MDIForm_Unload(0)
End Sub

Private Sub mnuFileSend_Click()
    '应做:添加 'mnuFileSend_Click' 代码。
    MsgBox "添加 'mnuFileSend_Click' 代码。"
End Sub

Private Sub mnuFilePrint_Click()
    On Error Resume Next
    If ActiveForm Is Nothing Then Exit Sub
    

    With dlgCommonDialog
        .DialogTitle = "Print"
        .CancelError = True
        .FLAGS = cdlPDReturnDC + cdlPDNoPageNums
        If ActiveForm.rtfText.SelLength = 0 Then
            .FLAGS = .FLAGS + cdlPDAllPages
        Else
            .FLAGS = .FLAGS + cdlPDSelection
        End If
        .ShowPrinter
        If Err <> MSComDlg.cdlCancel Then
            ActiveForm.rtfText.SelPrint .hDC
        End If
    End With

End Sub

Private Sub mnuFilePrintPreview_Click()
    '应做:添加 'mnuFilePrintPreview_Click' 代码。
    MsgBox "添加 'mnuFilePrintPreview_Click' 代码。"
End Sub

Private Sub mnuFilePageSetup_Click()
    On Error Resume Next
    With dlgCommonDialog
        .DialogTitle = "页面设置"
        .CancelError = True
        .ShowPrinter
    End With

End Sub

Private Sub mnuFileProperties_Click()
    '应做:添加 'mnuFileProperties_Click' 代码。
    MsgBox "添加 'mnuFileProperties_Click' 代码。"
End Sub

Private Sub mnuFileSaveAll_Click()
    '应做:添加 'mnuFileSaveAll_Click' 代码。
    MsgBox "添加 'mnuFileSaveAll_Click' 代码。"
End Sub

Private Sub mnuFileSaveAs_Click()
    Dim sFile As String
    

    If ActiveForm Is Nothing Then Exit Sub
    

    With dlgCommonDialog
        .DialogTitle = "另存为"
        .CancelError = False
        'ToDo: 设置 common dialog 控件的标志和属性
        .Filter = "所有文件 (*.*)|*.*"
        .ShowSave
        If Len(.FileName) = 0 Then
            Exit Sub
        End If
        sFile = .FileName
    End With
    ActiveForm.Caption = sFile
    ActiveForm.rtfText.SaveFile sFile

End Sub

Private Sub mnuFileSave_Click()
    Dim sFile As String
    If Left$(ActiveForm.Caption, 8) = "Document" Then
        With dlgCommonDialog
            .DialogTitle = "保存"
            .CancelError = False
            'ToDo: 设置 common dialog 控件的标志和属性
            .Filter = "所有文件 (*.*)|*.*"
            .ShowSave
            If Len(.FileName) = 0 Then
                Exit Sub
            End If
            sFile = .FileName
        End With
        ActiveForm.rtfText.SaveFile sFile
    Else
        sFile = ActiveForm.Caption
        ActiveForm.rtfText.SaveFile sFile
    End If

End Sub

Private Sub mnuFileClose_Click()
    '应做:添加 'mnuFileClose_Click' 代码。
    MsgBox "添加 'mnuFileClose_Click' 代码。"
End Sub

Private Sub mnuFileOpen_Click()
    Dim sFile As String

    If ActiveForm Is Nothing Then LoadNewDoc
    

    With dlgCommonDialog
        .DialogTitle = "打开"
        .CancelError = False
        'ToDo: 设置 common dialog 控件的标志和属性
        .Filter = "所有文件 (*.*)|*.*"
        .ShowOpen
        If Len(.FileName) = 0 Then
            Exit Sub
        End If
        sFile = .FileName
    End With
    ActiveForm.rtfText.LoadFile sFile
    ActiveForm.Caption = sFile

End Sub

Private Sub mnuFileNew_Click()
    LoadNewDoc
End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)

Select Case Button.Key
    Case "Import"
        Call mnuDataImport_Click
    Case "Center"
        Call mnuCenter_Click
    Case "Class"
        Call mnuCaseManage_Click
    Case "Move"
        Call mnuFileMove_Click
    Case "Delete"
        Call mnuDelCase_Click
    Case "Exit"
        Call MDIForm_Unload(1)
End Select
End Sub