frmsystem.frm

来自「一个用VB写的财务软件源码」· FRM 代码 · 共 1,038 行 · 第 1/3 页

    
    With mFg
        .RowHeight(0) = 300
        .ColWidth(0) = 1000
        .ColWidth(1) = 1000
        .ColWidth(2) = 800
        .ColWidth(3) = 1800
        .ColWidth(5) = 2500
        .ColWidth(7) = 2500
    End With
    
    With sBr
        .Panels(1).text = "Version " & App.Major & _
                "." & App.Minor & "." & App.Revision
        .Panels(2).text = App.LegalTrademarks & " " & App.CompanyName
        .Panels(3).text = App.Comments
    End With
    
End Sub

Private Function MakeQueryString()
    Dim datFrom As Date, sFrom As String
    Dim datTo As Date, sTo As String
    
    datFrom = DateAdd("d", m_iShowDay * -1, Date)
    datTo = DateAdd("d", m_iShowDay, Date)
    sFrom = Format(datFrom, "yyyy-mm-dd")
    sTo = Format(datTo, "yyyy-mm-dd")
    Select Case g_FLAT
        Case "SQL"
            MakeQueryString = _
                "select A.[ComputerName] as COMPU,B.[SubSysName] as SUBSY," & _
                "C.[UserName] as USERN,D.[AccountName] as ACCOU,A.[AccountYear] as AYEAR," & _
                "A.[LoginDateTime] as LOGDT,A.[RunState] as RUNST," & _
                "A.[QuitDateTime] as QUITT" & _
                " from tSYS_Manage A,tSYS_SubSys B,tSYS_User C,tSYS_Account D" & _
                " where A.[SubSysID]=B.[SubSysID] and A.[UserID]=C.[UserID] and" & _
                " A.[AccountID]=D.[AccountID] and (A.[LoginDateTime] between '" & _
                sFrom & " 00:00:00' and '" & sTo & " 23:59:59') order by 1,2,3,4,5,6"
        Case "ORACLE"
            MakeQueryString = _
                "select A.ComputerName COMPU,B.SubSysName SUBSY," & _
                "C.UserName USERN,D.AccountName ACCOU,A.AccountYear AYEAR," & _
                "A.LoginDateTime LOGDT,A.RunState RUNST," & _
                "A.QuitDateTime QUITT" & _
                " from tSYS_Manage A,tSYS_SubSys B,tSYS_User C,tSYS_Account D" & _
                " where A.SubSysID=B.SubSysID and A.UserID=C.UserID and" & _
                " A.AccountID=D.AccountID and to_char(A.LoginDateTime,'YYYY-MM-DD HH24:mm:ss')>='" & _
                sFrom & " 00:00:00' and to_char(A.LoginDateTime,'YYYY-MM-DD HH24:mm:ss')<='" & _
                sTo & " 23:59:59' order by 1,2,3,4,5,6"
        Case Else
            Err.Raise 5
    End Select

End Function

Private Sub Form_Resize()
    On Error Resume Next
    mFg.Width = Me.ScaleWidth - 50
    mFg.Height = Me.ScaleHeight - 350
End Sub

Private Sub Form_Unload(Cancel As Integer)
Dim frm As Form
    If MsgBox("确实要退出吗？", vbQuestion + vbYesNo) = vbNo Then
        Cancel = 1
    Else
        For Each frm In Forms
            If TypeOf frm Is frmSystem Then
            Else
                Unload frm
            End If
        Next
        Set s = Nothing
        'Unload glo.frmProg
    End If
End Sub


Private Sub mnuAutoBackup_Click()
frmAutoBackup.Show 1, Me
End Sub

Private Sub mnuDealBackup_Click()
With frmAccount
    .uiStatus = "Export"
    .HelpContextID = 601
    .Show 1, Me
End With
End Sub

Private Sub mnuDealRestore_Click()
With frmAccount
    .uiStatus = "Import"
    .HelpContextID = 602
    .Show 1, Me
End With

End Sub

Private Sub mnuFileDatabak_Click()
''   Frmbackup.Show 1, Me
'Dim sFile As New FileSystemObject
'If sFile.FileExists(App.Path & "\BackUp\AutoBackup.exe") Then
'Shell App.Path & "\BackUp\AutoBackup.exe"
'Else
'MsgBox App.Path & "\BackUp\AutoBackup.exe文件不存在！", vbInformation, "提示"
'End If
If g_FLAT = "ORACLE" Then
    frmZTBackup.HelpContextID = 603
    frmZTBackup.Show 1, Me
Else
    frmZTSQLBackup.HelpContextID = 603
    frmZTSQLBackup.Show 1, Me
End If
End Sub

Private Sub mnuFileDataRecover_Click()
''  If g_FLAT = "SQL" Then
If g_FLAT = "ORACLE" Then
    frmZTRestore.HelpContextID = 604
    frmZTRestore.Show 1, Me
Else
    frmZTSQLRestore.HelpContextID = 604
    frmZTSQLRestore.Show 1, Me
End If
''  Exit Sub
''  End If
''  Dim filename, FilePart As String
''  Dim FilePath As String * 100
''  Dim ReturnValue, BufferLength As Long
''  Me.MousePointer = vbArrowHourglass
''  filename = "vad.exe"
''  BufferLength = 100
''  ReturnValue = SearchPath(vbNullString, filename, vbNullString, BufferLength, FilePath, FilePart)
''  If ReturnValue = 0 Then
''    Me.MousePointer = vbDefault
''    MsgBox "应用程序丢失！", vbCritical, "出错"
''    Exit Sub
''  End If
'''  If CheckUser(Userinform.UserID, "a05") Then  '参数说明: 用户代码,模块代码
''    pidNotepad = Shell(Trim(FilePath), vbMaximizedFocus)
''    Hprocess = OpenProcess(Process_Query_Information, False, pidNotepad)
''    Do
''      GetExitCodeProcess Hprocess, Ingexitcode
''    Loop While Ingexitcode = Still_Active
'''  End If
''  Me.MousePointer = vbDefault
End Sub

Private Sub mnuMutexClear_Click()
    frmClearMutex.HelpContextID = 501
    frmClearMutex.Show
End Sub

Private Sub mnuMutexInfo_Click()
    frmMutex.Show 1, Me
End Sub

Private Sub mnuMutexObjectInfo_Click()
    frmObjectMutex.Show 1
End Sub

Private Sub mnuRegistMaintenance_Click()
Dim sFile As New FileSystemObject
If sFile.FileExists(App.Path & "\RegeditSetting.exe") Then
Shell App.Path & "\RegeditSetting.exe"
Else
MsgBox App.Path & "\RegeditSetting.exe文件不存在！", vbInformation, "提示"
End If
End Sub

'一级菜单：系统(&S)

'系统－－注册
Private Sub mnuSystemLogin_Click()
    frmLogin.HelpContextID = 101
    frmLogin.Show vbModal, Me
    If frmLogin.OK Then
        '注册成功则依据操作员的性质置各菜单项可用与否
        glo.sUserID = frmLogin.usUserID
        glo.sUserName = frmLogin.usUserName
        glo.iUserType = frmLogin.uiUserType
        mnuSystemLogin.Enabled = False
        mnuSystemLogout.Enabled = True
        mnuViewRefresh.Enabled = True
        mnuViewClearLock.Enabled = True
        mnuViewOption.Enabled = True
        mnuViewInfor.Enabled = True
        Select Case glo.iUserType
            Case 0
                mnuAccountCreate.Enabled = True
                mnuAccountDelete.Enabled = True
                mnuDealBackup.Enabled = True
                mnuDealRestore.Enabled = True
                mnuWorkUser.Enabled = True
                mnuWorkAuth.Enabled = True
                mnuMutexInfo.Enabled = True
                mnuMutexObjectInfo.Enabled = True
                mnuViewLog.Enabled = True
                mnuFileDatabak.Enabled = True
                mnuFileDataRecover.Enabled = True
            Case 1
                mnuAccountUpdate.Enabled = True
                mnuYearCreate.Enabled = True
                mnuYearDeal.Enabled = True
'                mnuDealBackup.Enabled = True
'                mnuDealRestore.Enabled = True
                mnuWorkSet.Enabled = True
                mnuViewLog.Enabled = True
            Case Else
        End Select
        Unload frmLogin
    End If
    
End Sub

'系统－－注销
Private Sub mnuSystemLogout_Click()
    If MsgBox("确实要注销吗？", vbQuestion + vbYesNo) = vbYes Then
        '注销后置各菜单项不可用（除“注册”）
        mnuSystemLogin.Enabled = True
        mnuSystemLogout.Enabled = False
        
        mnuAccountCreate.Enabled = False
        mnuAccountDelete.Enabled = False
        mnuAccountUpdate.Enabled = False
        
        mnuDealBackup.Enabled = False
        mnuDealRestore.Enabled = False
        
        mnuYearCreate.Enabled = False
        mnuYearDeal.Enabled = False
        
        mnuWorkUser.Enabled = False
        mnuWorkAuth.Enabled = False
        
        mnuMutexInfo.Enabled = False
        mnuMutexObjectInfo.Enabled = False
        mnuWorkSet.Enabled = False
        
        mnuViewRefresh.Enabled = False
        mnuViewClearLock.Enabled = False
        mnuViewOption.Enabled = False
        mnuViewInfor.Enabled = False
        mnuViewLog.Enabled = False
        mnuFileDatabak.Enabled = False
        mnuFileDataRecover.Enabled = False
    End If
End Sub

'系统－－退出
Private Sub mnuSystemQuit_Click()
    Unload Me
End Sub

'一级菜单：账套(&A)
'账套－－建立
Private Sub mnuAccountCreate_Click()
    frmWizard.bUpdate = False
    frmWizard.HelpContextID = 201
    frmWizard.Show 1, Me
End Sub

'账套－－删除
Private Sub mnuAccountDelete_Click()
    frmListAccounts.HelpContextID = 203
    frmListAccounts.Show 1, Me
End Sub
'账套--修改
Private Sub mnuAccountUpdate_Click()
    Dim rSt As ADODB.Recordset
    Dim rst1 As ADODB.Recordset
    
    Dim sCurrencyName As String
    Dim iTradeId As Integer
    Dim cTradeName As String
    Dim sSeparateChar As String
    Dim blnUpdateAll As Boolean
    
    Dim strBeginyear As String
    Dim strBeginMonth As String
    Dim sAccountName As String
    Dim sMaster As String
    Dim sEntername As String
    Dim sTelCode As String
    Dim sAddress As String
    Dim sZip As String
    Dim sEmail As String
    Dim sTaxNo As String
    Dim sLaw As String
    Dim sEconomyProperty As String
    Dim sEnterType As String
    Dim sVoucherPrintMode As String
    Dim iVoucherNumberMode As Integer
    Dim iSubjectonFront As Integer
    Dim sSeparateSubject As String
    
    Set rSt = New ADODB.Recordset
    Set rst1 = New ADODB.Recordset
    On Error GoTo HandleErr
    With rSt
        .CursorLocation = adUseClient
        .Open "select * from tsys_account where accountid='" & frmLogin.m_sUserID & "'", _
        gloSys.cnnSys, adOpenStatic, adLockReadOnly
        If Not (.EOF And .BOF) Then
            sCurrencyName = Trim("" & .Fields("currencyname").Value)
            iTradeId = .Fields("tradeid").Value
            sSeparateChar = Trim("" & .Fields("SeparateChar").Value)
            strBeginyear = .Fields("beginyear").Value & ""
            strBeginMonth = .Fields("beginmonth").Value & ""
            sAccountName = Trim(.Fields("AccountName").Value & "")
            sMaster = Trim(.Fields("master").Value & "")
            sEntername = Trim(.Fields("entername") & "")
            sTelCode = Trim(.Fields("telcode") & "")
            sZip = Trim(.Fields("zip") & "")
            sAddress = Trim(.Fields("address") & "")
            sEmail = Trim(.Fields("email") & "")
            sTaxNo = Trim(.Fields("taxno") & "")
            sLaw = Trim(.Fields("law") & "")
            sEconomyProperty = Trim(.Fields("economyproperty") & "")
            sEnterType = Trim(.Fields("entertype") & "")
        End If
        .Close
    End With
    Set rSt = Nothing
    
    rst1.CursorLocation = adUseClient
    rst1.Open "select name from tsys_trade where id=" & iTradeId, _
    gloSys.cnnSys, adOpenStatic, adLockReadOnly
    If Not (rst1.EOF And rst1.BOF) Then
        cTradeName = rst1.Fields("name").Value
    End If
    rst1.Close
    Set rst1 = Nothing
    Set rst1 = New ADODB.Recordset
    rst1.Open "select count(*) aa from tsys_subsysused where accountid='" _
               & frmLogin.m_sUserID & "'", gloSys.cnnSys
    If rst1.Fields("aa").Value = 0 Then
        blnUpdateAll = True
    Else
        blnUpdateAll = False
    End If
        
        With frmWizard
            .bUpdate = True