frmsystem.frm

一个用VB写的财务软件源码

            .txtAccountID.text = frmLogin.m_sUserID
            .txtAccountID.Enabled = False
            .txtAccountID.BackColor = vbButtonFace
            
            .txtCurrency.text = sCurrencyName
            .txtCurrency.Enabled = False
            .txtCurrency.BackColor = vbButtonFace
            
            .txtBeginYear.text = strBeginyear
            .txtBeginYear.Enabled = False
            .txtBeginYear.BackColor = vbButtonFace
            .updBeginYear.Enabled = False
            
            .txtBeginMonth.text = strBeginMonth
            .txtBeginMonth.Enabled = False
            .txtBeginMonth.BackColor = vbButtonFace
            .updBeginMonth.Enabled = False
            
            .mfgCodeLevel.Enabled = False
            .Frame1.Enabled = False
            If sSeparateChar <> "0" Then
                .txtSeperateChar.text = sSeparateChar
                .txtSeperateChar.Enabled = False
                .txtSeperateChar.BackColor = vbButtonFace
            End If
             .txtEnterName = sEntername
             .txtTelCode = sTelCode
             .txtZip = sZip
             .txtAddress = sAddress
             .txtEMail = sEmail
             .txtTaxNo = sTaxNo
             .txtLaw = sLaw
             .txtEconomyProperty = sEconomyProperty
             .txtEnterType = sEnterType
            .cboTradeKind.text = cTradeName
            .cboTradeKind.Enabled = False
            .cboTradeKind.BackColor = vbButtonFace
            
            .chkPreSet.Enabled = False
            .txtAccountName.text = sAccountName
            .txtMaster.text = sMaster
        End With
    frmWizard.bUpdate = True
    frmWizard.Caption = "修改账套信息"
    frmWizard.Label20.Caption = "现在开始修改账套信息，请输入要修改账套的信息。"
    frmWizard.lblMsg.Caption = "按“完成”按钮完成修改账套。"
    frmWizard.HelpContextID = 202
    frmWizard.Show 1, Me
    Exit Sub
HandleErr:
    
End Sub

'-------------------------------------------------------
'重新授权
'-------------------------------------------------------
Private Sub mnuSystemReRegedit_Click()
    Dim ML As Object
On Error GoTo Err_Exit
    Me.MousePointer = 11
    Set ML = CreateObject("ykCLicence.CheckLicence")
    ML.DBFlat = g_FLAT
    ML.LoadInfo
    If ML.reregedit Then
        MsgBox "授权成功您将使用新的注册号！", vbOKOnly + vbInformation, Me.Caption
    End If
    Me.MousePointer = 0
    Set ML = Nothing
    Exit Sub
Err_Exit:
    Me.MousePointer = 0
    MsgBox "重新授权失败，原因：" & Err.Description, vbOKOnly + vbInformation, Me.Caption
    Set ML = Nothing
End Sub
Private Sub mnuViewInfor_Click()
    frmInforAccounts.HelpContextID = 203
    frmInforAccounts.Show 1, Me
End Sub

'一级菜单：年度账(&Y)

'年度账－－建立
Private Sub mnuYearCreate_Click()
    Dim sAccountID As String
    Dim sAccountName As String
    
    If IsSubSysUsed(sAccountID, sAccountName) Then
        With frmCreateDatabaseNewYear
            .usAccountID = sAccountID
            .usAccountName = sAccountName
            .HelpContextID = 301
            .Show 1
        End With
    Else
        MsgBox "账务子系统没有启用，不能建立新年度账！", vbInformation
    End If
End Sub

'年度账－－结转上年数据
Private Sub mnuYearDeal_Click()
    Dim sAccountID As String
    Dim sAccountName As String
    
    If IsSubSysUsed(sAccountID, sAccountName) Then
        With frmLastYearCarryForward
            .usAccountID = sAccountID
            .usAccountName = sAccountName
            .Show 1
        End With
    Else
        MsgBox "账务子系统没有启用，不能进行上年数据结转！", vbInformation
    End If
End Sub

'一级菜单：岗位(&W)

'岗位－－权限目录
Private Sub mnuWorkAuth_Click()
    Me.MousePointer = vbHourglass
    Load frmAuth
    Me.MousePointer = vbDefault
    frmAuth.HelpContextID = 402
    frmAuth.Show 1, Me
End Sub

'岗位－－操作员权限设置
Private Sub mnuWorkSet_Click()
    Me.MousePointer = vbHourglass
    frmUserAuth.usAccountID = glo.sUserID
    Load frmUserAuth
    Me.MousePointer = vbDefault
'    frmUserAuth.HelpContextID = mnuWorkSet.HelpContextID
    frmUserAuth.Show , Me
End Sub

'岗位－－操作员目录
Private Sub mnuWorkUser_Click()
    Me.MousePointer = vbHourglass
    Load frmUser
    Me.MousePointer = vbDefault
    frmUser.HelpContextID = 401
    frmUser.Show 1, Me
End Sub

'一级菜单：视图(&V)

'视图－－上机日志
Private Sub mnuViewLog_Click()
    frmLog.HelpContextID = 702
    frmLog.Show 1, Me
End Sub

'视图－－选项
Private Sub mnuViewOption_Click()
    frmOption.HelpContextID = 701
    frmOption.Show 1, Me
End Sub

'视图－－清除死锁
Private Sub mnuViewClearLock_Click()

End Sub

'视图－－刷新
Private Sub mnuViewRefresh_Click()

End Sub

'一级菜单：帮助(&H)

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

Private Sub mnuHelpContent_Click()
    Dim nRet As Integer

    'if there is no helpfile for this project display a message to the user
    'you can set the HelpFile for your application in the
    'Project Properties dialog
'    If Len(App.HelpFile) = 0 Then
'        MsgBox "Unable to display Help Contents. There is no Help associated with this project.", vbInformation
'    Else
'        On Error Resume Next
'        nRet = OSWinHelp(Me.hwnd, App.HelpFile, 15, 0)
'        If Err Then
'            MsgBox Err.Description
'        End If
'    End If
Dim hwndHelp As Long
    
    hwndHelp = HtmlHelp(hwnd, App.HelpFile, _
        HH_DISPLAY_TOC, 0)
End Sub

Private Sub mnuHelpIndex_Click()
    Dim nRet As Integer
    
    'if there is no helpfile for this project display a message to the user
    'you can set the HelpFile for your application in the
    'Project Properties dialog
'    If Len(App.HelpFile) = 0 Then
'        MsgBox "Unable to display Help Contents. There is no Help associated with this project.", vbInformation
'    Else
'        On Error Resume Next
'        nRet = OSWinHelp(Me.hwnd, App.HelpFile, 261, 0)
'        If Err Then
'            MsgBox Err.Description
'        End If
'    End If
Dim hwndHelp As Long
    
    hwndHelp = HtmlHelp(hwnd, App.HelpFile, _
        HH_DISPLAY_TOC, 0)
End Sub
Private Sub tMr_Timer()
    Dim i As Long
    Dim lSpace As Long
    Dim str As String
    '自动备份
    Dim frmR As frmZTBackup
    Dim frmSQLR As frmZTSQLBackup
    str = GetSetting(App.Title, "AutoBackup", "Path")
    str = GetSetting(App.Title, "AutoBackup", "周期")
    If GetSetting(App.Title, "AutoBackup", "设置") = "自动" Then
        If str = "Day" Then
           If Format(Time, "hh:mm") = GetSetting(App.Title, "AutoBackup", "DayTime") Then
                If g_FLAT = "ORACLE" Then
                   If isAutoBackup = False Then
                        isAutoBackup = True
                        Set frmR = New frmZTBackup
                        Call frmR.cmdOk_Click
                        Set frmR = Nothing
                   End If
                Else
                  If isAutoBackup = False Then
                        isAutoBackup = True
                        Set frmSQLR = New frmZTSQLBackup
                        Call frmSQLR.cmdOk_Click
                        Set frmSQLR = Nothing
                  End If
                End If
           Else
                isAutoBackup = False
           End If
        Else
           If Weekday(Date, vbMonday) = GetSetting(App.Title, "AutoBackup", "WeekDay") And Time = GetSetting(App.Title, "AutoBackup", "WeekTime") Then
                If g_FLAT = "ORACLE" Then
                   If isAutoBackup = False Then
                        isAutoBackup = True
                        Set frmR = New frmZTBackup
                        Call frmR.cmdOk_Click
                        Set frmR = Nothing
                   End If
                Else
                   If isAutoBackup = False Then
                        isAutoBackup = True
                        Set frmSQLR = New frmZTSQLBackup
                        Call frmSQLR.cmdOk_Click
                        Set frmSQLR = Nothing
                   End If
                End If
            Else
                isAutoBackup = False
            End If
        End If
    End If
    '刷新
    With rstManage
        If .State = adStateOpen Then
            .Close
        End If
        .CursorLocation = adUseClient
        .Open MakeQueryString(), gloSys.cnnSys, adOpenStatic, adLockReadOnly
        mFg.Redraw = False
        mFg.Rows = 1
        i = 0
        If .RecordCount <> 0 Then
            .MoveFirst
    '        站点|<子系统|<用户|<账套|<会计年度|<注册时间|<运行状态|<终止时间
            Do Until .EOF
                mFg.Rows = mFg.Rows + 1
                i = i + 1
                mFg.TextMatrix(i, 0) = "" & .Fields("COMPU").Value
                mFg.TextMatrix(i, 1) = "" & .Fields("SUBSY").Value
                mFg.TextMatrix(i, 2) = "" & .Fields("USERN").Value
                mFg.TextMatrix(i, 3) = "" & .Fields("ACCOU").Value
                mFg.TextMatrix(i, 4) = "" & .Fields("AYEAR").Value
                mFg.TextMatrix(i, 5) = IIf(IsNull(.Fields("LOGDT").Value), "", Format(.Fields("LOGDT").Value, "yyyy年MM月dd日hh时mm分ss秒"))
                mFg.TextMatrix(i, 6) = "" & .Fields("RUNST").Value
                mFg.TextMatrix(i, 7) = IIf(IsNull(.Fields("QUITT").Value), "", _
                        Format(.Fields("QUITT").Value, "yyyy年MM月dd日hh时mm分ss秒"))
                .MoveNext
            Loop
        End If
        mFg.Redraw = True
    End With

End Sub


Private Function IsSubSysUsed(ByRef sAccountID As String, _
                        ByRef sAccountName As String) As Boolean
    Dim adoRst As ADODB.Recordset
    Dim adoSQL As String

    Set adoRst = New ADODB.Recordset
    adoRst.CursorLocation = adUseClient
    
    sAccountID = glo.sUserID
    sAccountName = GetAccountName(glo.sUserID)
    
    '判断当前账套的账务子系统是否启用
    adoSQL = "SELECT * FROM tSYS_SubSysUsed" & _
            " WHERE AccountID = '" & sAccountID & _
            "' AND SubSysID = 'ZW'"
    With adoRst
        .Open adoSQL, gloSys.cnnSys, adOpenStatic, adLockReadOnly
        If .RecordCount > 0 Then
            IsSubSysUsed = True
        End If
        .Close
    End With

End Function

'根据账套号，取得一个账套的名称
Private Function GetAccountName(ByVal sID As String) As String
    Dim rSt As ADODB.Recordset
    
    Set rSt = New ADODB.Recordset
    With rSt
        .Open "select accountname from tSYS_Account where AccountID='" & _
                Trim("" & sID) & "'", gloSys.cnnSys, adOpenStatic, adLockReadOnly
        If Not (.EOF And .BOF) Then
            GetAccountName = Trim$("" & .Fields(0).Value)
        Else
            GetAccountName = ""
        End If
        .Close
    End With
    
End Function