hcconst.bas

财务信息管理系统,适合做毕业论文的人使用

  'CuiDong Efficiency-A 2000/06/19 效率优化A OK
  Dim rsl As New UfRecordset

  If UnitName = "" Then
    IsUnitNameExist = False
    Exit Function
  End If
  
'  Set rsl = dbsZJ.OpenRecordset("FD_AccUnit", dbOpenDynaset)  'CuiDong Efficiency-A 2000/06/19 效率优化A
  Set rsl = dbsZJ.OpenRecordset("Select cUnitName From FD_AccUnit Where cUnitName = '" & UnitName & "'", dbOpenDynaset) 'CuiDong Efficiency-A 2000/06/19 效率优化A
'  rsl.FindFirst "cUnitName = '" & UnitName & "'"              'CuiDong Efficiency-A 2000/06/19 效率优化A
'  If rsl.NoMatch Then                                         'CuiDong Efficiency-A 2000/06/19 效率优化A
  If rsl.EOF Or rsl.BOF Then                                   'CuiDong Efficiency-A 2000/06/19 效率优化A
    IsUnitNameExist = False
    Exit Function
  End If
  
  IsUnitNameExist = True
  Set rsl = Nothing
  
End Function

'求存款日期
Public Function SaveBillDay(AccCode As String) As Date
    'CuiDong Efficiency-A 2000/06/19 效率优化A OK
    Dim rsSav As New UfRecordset
    
'    Set rsSav = dbsZJ.OpenRecordset("FD_Sav", dbOpenDynaset)  'CuiDong Efficiency-A 2000/06/19 效率优化A
    Set rsSav = dbsZJ.OpenRecordset("Select dbill_date From FD_Sav Where cAccID = '" & AccCode & "'", dbOpenDynaset) 'CuiDong Efficiency-A 2000/06/19 效率优化A
    With rsSav
'        .FindFirst "cAccID = '" & AccCode & "'"               'CuiDong Efficiency-A 2000/06/19 效率优化A
'        If Not .NoMatch Then                                  'CuiDong Efficiency-A 2000/06/19 效率优化A
        If Not (.EOF Or .BOF) Then                             'CuiDong Efficiency-A 2000/06/19 效率优化A
            SaveBillDay = !dbill_date
        End If
    End With
    CloseRS rsSav
    
End Function
'金额格式化
Public Function MoneyFormat(money As Variant) As String

  If money = "" Then
    MoneyFormat = ""
    Exit Function
  End If
  
  MoneyFormat = Format(money, "##,###,###,##0.00")

End Function

Public Function BillNameToCode(BillName As String) As String
  'CuiDong Efficiency-A 2000/06/19 效率优化A OK
  
  Dim rsClass As New UfRecordset

'  Set rsClass = dbsZJ.OpenRecordset("FD_Class", dbOpenDynaset)  'CuiDong Efficiency-A 2000/06/19 效率优化A
  Set rsClass = dbsZJ.OpenRecordset("Select cSign From FD_Class Where cText = '" & BillName & "'", dbOpenDynaset) 'CuiDong Efficiency-A 2000/06/19 效率优化A
  
  With rsClass
 '   .FindFirst "cText = '" & BillName & "'"                     'CuiDong Efficiency-A 2000/06/19 效率优化A
'    If .NoMatch Then                                            'CuiDong Efficiency-A 2000/06/19 效率优化A
    If .EOF Or .BOF Then                                         'CuiDong Efficiency-A 2000/06/19 效率优化A
      BillNameToCode = ""
      Exit Function
    End If
    
    BillNameToCode = !cSign
  End With
    
  Set rsClass = Nothing
  
End Function

Public Function BillTxtToNumBh(TxtBh As String) As String
    If TxtBh <> "" Then
        BillTxtToNumBh = BillNameToCode(left(TxtBh, InStr(1, TxtBh, "-") - 1)) & right(TxtBh, 8)
    End If
End Function
'获取利息单最大号
Public Function GetLXDMaxBh()
    
    Dim rsTemp As New UfRecordset
    
    Set rsTemp = dbsZJ.OpenRecordset("Select Max(cCarID) As MaxID From FD_CadAcr", dbOpenSnapshot)
    With rsTemp
        If .EOF Then
            GetLXDMaxBh = "00000000"
        Else
            If Not IsNull(!MaxID) Then
                GetLXDMaxBh = right(!MaxID, 8)
            Else
                GetLXDMaxBh = "00000000"
            End If
        End If
    End With
    rsTemp.oClose
    
End Function
'重新注册
Public Sub ReLogin()
    
    Dim i As Integer, oldzth As String
    On Error GoTo errLogExit
    
    If Forms.count > 3 Then
        If Forms.count = 4 Then
            For i = 0 To Forms.count - 1
                If Forms(i).Caption = "RightMenu" Then GoTo Continue
            Next i
        End If
        MsgBox "请先退出所有任务后,再重新注册!", vbInformation, zjGl_Name
        Exit Sub
    End If
    
    oldzth = zjLogInfo.cAcc_Id
    
Continue:
    i = 0
    If zjLogInfo.Login("FD") Then
        If zjLogInfo.curDate > Date Then
            If zjLogInfo.LogState = 100 Then
                GoTo errLogExit
            Else
                'V8.50 章景峰
                g_sDataSourceName = zjLogInfo.UfDbName
                g_sMenuDSN = mID(zjLogInfo.UfDbName, 1, InStrRev(zjLogInfo.UfDbName, "=")) & "UFSystem"
                
                'MsgBox "登录时间不能大于本计算机时间！", vbCritical, zjGl_Name                                                                                                                                               'cuidong 2001.12.06
                If MsgBox("登录日期（" & Format(zjLogInfo.curDate, "YYYY-MM-DD") & "）在系统日期（" & Format(Date, "YYYY-MM-DD") & "）之后，继续运行吗？", vbInformation + vbYesNo + vbDefaultButton1, zjGl_Name) = vbNo Then 'cuidong 2001.12.06
                   i = i + 1
                   If i > 1 Then
                       GoTo errLogExit
                   Else
                       GoTo Continue
                   End If
                End If
            End If
        End If
        
        If zjLogInfo.LogState = 100 Then
            zjLogInfo.ClearError
            Exit Sub
        End If
        
        dbsZJ.oClose
        Set dbsZJ = Nothing
        dbsZJ.OpenDatabase zjLogInfo.UfDbName, False, False, ";PWD=" & zjLogInfo.SysPassword
        
        '判断启用日期
        If Pd_qyrqsz() <> 1 Then GoTo errLogExit
        
        Screen.MousePointer = vbHourglass
        
        '--- From 810 To 811
        UpgradeTo811
        
        Set aClsPub = New clsPub
        aClsPub.InitPubs2 "FD", zjLogInfo.UfSystemDb, dbsZJ, zjLogInfo.cAcc_Id, zjLogInfo.cIYear, zjLogInfo.cUserId, zjLogInfo.curDate, zjLogInfo.SysPassword
        Set mDbTemp = aClsPub.DataMdbTemp
        
        '导入科目级次
        LoadKmGrade
        
        '----zcl change start 2001-02-16
        Dim vDemo As Variant
        
        zjLogInfo.GetAccInfo 10000, vDemo
        g_bIsDemo = Not CBool(vDemo)
        If g_bIsDemo Then
            frmMain.Caption = "资金管理(演示/教学版)"
        End If
        '----zcl change end
        
        With frmMain.stbInfo
            .Panels(2).Text = "操作员:" & zjLogInfo.cUserName & IIf(zjLogInfo.IsAdmin, "(账套主管)", "")
            .Panels(3).Text = "业务日期:" & Format(zjLogInfo.curDate, "yyyy-mm-dd")
            .Panels(1).Text = "账套:[" & zjLogInfo.cAcc_Id & "]" & zjLogInfo.cAccName
            .Panels(1).width = frmMain.width - .Panels(2).width - .Panels(3).width - .Panels(4).width
        End With
        
        Auth_Right
        
        If oldzth <> zjLogInfo.cAcc_Id Then
            With zjNotecom
                .DBName = zjLogInfo.UfSystemDb.Name
                .UseTName = "UA_User"
                .NoteShow zjLogInfo.cUserName, Format(zjLogInfo.curDate, "yyyy-mm-dd")
            End With
            IsAutoAlarm
        End If
        Screen.MousePointer = vbDefault
    End If
    Set oV.connDB = dbsZJ.DbConnect
    Set oUniFind.UfDatabase = dbsZJ
    Exit Sub
errLogExit:
    ShowLogErrMsg
    Unload frmMain
    
End Sub
'注册时错误处理
Public Sub ShowLogErrMsg()
    On Error Resume Next
    With zjLogInfo
        If .LogState <> 0 And .LogState <> 100 Then
             Beep
             MsgBox GetLoginErrStr(.LogState), vbCritical, zjGl_Name
        End If
        .ClearError
    End With
    On Error GoTo 0
End Sub

Public Function GetLoginErrStr(ByVal nErrNo As Integer) As String

    GetLoginErrStr = zjLogInfo.ShareString
'    Select Case nErrNo
'        Case 1
'            GetLoginErrStr = "缺少参数(1)。"
'        Case 2
'            GetLoginErrStr = "未用(2)。"
'        Case 3
'            GetLoginErrStr = "已经有账套独占任务运行(3)。"
'        Case 4
'            GetLoginErrStr = "已经有年度独占任务运行(4)。"
'        Case 5
'            GetLoginErrStr = "服务对象已经卸载(5)。"
'        Case 6
'            GetLoginErrStr = "打不开系统数据库(6)。"
'        Case 7
'            GetLoginErrStr = "环境错误，可能是服务端程序的DCOM配置不正常，或网络不正常等因素(7)。"
'        Case 8
'            GetLoginErrStr = "子系统未安装(8)。"
'        Case 9
'            GetLoginErrStr = "未用(9)。"
'        Case 10
'            GetLoginErrStr = "未检测到加密盒" & Chr(13) & "或此子系统登录数超过加密盒额定最大操作员数(10)。"
'        Case 11
'            GetLoginErrStr = "未用(11)。"
'        Case 12
'            GetLoginErrStr = "共享路径无效(12)。"
'        Case 13
'            GetLoginErrStr = "不能共享路径(13)。"
'        Case 14
'            GetLoginErrStr = "必须设置共享方式为〖共享级访问控制〗(14)。"
'        Case 15
'            GetLoginErrStr = "未知的共享错误(15)。"
'        Case 16
'            GetLoginErrStr = "打不开年度数据库(16)。"
'        Case 17
'            GetLoginErrStr = "年度数据库不是当前账套的数据库(17)。"
'        Case 18
'            GetLoginErrStr = "任务对象中年度和账套号无效(18)。"
'        Case 19
'            GetLoginErrStr = "打开账套错误(19)。"
'        Case 20
'            GetLoginErrStr = "用户没有当前子系统的权限(20)。"
'        Case 21
'            GetLoginErrStr = "本年已经有其他互斥任务运行(21)。"
'        Case 22
'            GetLoginErrStr = "无此任务号，不能释放任务(22)。"
'        Case 23
'            GetLoginErrStr = "任务对象不合法，TaskId为空(23)。"
'        Case 100
'            GetLoginErrStr = "登录过程被取消(100)。"
'        Case 101
'            GetLoginErrStr = "没有账套或年度〖账套/年度没有创建或被输出〗(101)。"
'        Case 102
'            GetLoginErrStr = "当前子系统当前账套当前年度没有任何用户(102)。"
'        Case 103
'            GetLoginErrStr = "口令不对(103)。"
'        Case 104
'            GetLoginErrStr = "未用(104)。"
'        Case 105
'            GetLoginErrStr = "重新注册时，子系统号不一致(105)。"
'        Case 106
'            GetLoginErrStr = "未用(106)。"
'        Case 107
'            GetLoginErrStr = "不能执行系统管理或跟系统管理连接。可能是:" & Chr(13) & "  1.[UFAdmin.EXE]没有正确安装。" & Chr(13) & "  2.[UFAdmin.EXE]没有正确注册。" & Chr(13) & "  3.[UFAdmin.EXE]被移动位置。" & Chr(13) & "  4.[UFSystem.MDB]被损坏。" & Chr(13) & "  5.如果是网络应用，也可能是网络连接不正常。" & Chr(13) & "  6.如果是网络应用，服务端应用超级用户组的用户登录." & Chr(13) & "  7.服务端有关配置被破坏。" & Chr(13) & "请检查上述情况，确认后再登录(107)。"
'        Case 108
'            GetLoginErrStr = "未用(108)。"
'        Case 109
'            GetLoginErrStr = "没有设置当前程序的ProcessId或者程序意外终止(109)。"
'        Case 200
'            GetLoginErrStr = "演示数据已经过期(200)。"
'        Case Else
'            GetLoginErrStr = "不明错误(" & nErrNo & ")。"
'    End Select
End Function

'科目及辅助项参照
Public Sub ShowAssRef(AssType As RefType, ParaRet As String, RetMode As SwitchMode, Optional xmdl As String)
        On Error GoTo errHandle
        Select Case AssType
            Case iKm
                Dim objSubRef As New KmRef.clsKmRef
                Dim tempView As New clsViewAbout
                Set objSubRef.NewZwPub = aClsPub
                Set objSubRef.NewLogIn = zjLogInfo
                objSubRef.RefDirect
                tempView.Viewpara1 = aClsPub.ViewVar.Viewpara1
                objSubRef.DRSetAttrib tempView
                objSubRef.DRReference
                objSubRef.DRGetAttrib tempView
                Set aClsPub.ViewVar = tempView
                If tempView.Isreturn Then
                    If RetMode = AS_CODE Then
                        ParaRet = tempView.Viewreturn1
                    Else
                        ParaRet = tempView.Viewreturn2
                    End If
                End If
                Set objSubRef = Nothing
                Set tempView = Nothing
            Case iItem
                Dim objxmRef As New ItemRef.clsXmRef
                Dim tempView1 As New clsViewAbout
                tempView1.Viewpara1 = xmdl
                tempView1.Viewpara2 = ParaRet
                Set objxmRef.ObjLogin = zjLogInfo
                Set objxmRef.MyZwPub = aClsPub
                objxmRef.DRSetAttrib tempView1
                objxmRef.DRReference
                objxmRef.DRGetAttrib tempView1
                If tempView1.Isreturn Then
                    If RetMode = AS_CODE Then
                        ParaRet = tempView1.Viewreturn1
                    Else
                        ParaRet = tempView1.Viewreturn2
                    End If
                End If
                Set objxmRef = Nothing
                Set tempView1 = Nothing
            Case Else
                Dim vParaA As Variant
                Dim objRefAll As New ClsRefer
                objRefAll.DRSetAttrib 0, dbsZJ
                objRefAll.DRSetAttrib 1, AssType
                objRefAll.DRSetAttrib 2, ParaRet
                objRefAll.DRSetAttrib 3, True

                If objRefAll.DRReference = True Then
                    If AssType = iPerson Or AssType = iDepart Then
                        If RetMode = AS_CODE Then
                            objRefAll.DRGetAttrib 1, vParaA
                        Else
                            objRefAll.DRGetAttrib 2, vParaA
                        End If
                    ElseIf AssType = iCustomer Or AssType = iVendor Then
                        If RetMode = AS_CODE Then