zjmain.bas

VB财务软件系统下载源代码提供自由下载使用学习

Attribute VB_Name = "ZjMain"
'软件著作权: 北京用友软件集团有限公司
'系统名称: 资金计息8.0
'功能说明: 系统启动模块
'作者: 魏小黎、赵春立

Option Explicit
'----全局常量
Public Const g_conSysID         As String = "FD"                     '----子系统号
Public Const g_conSysName       As String = "用友ERP-U8资金管理"      '----子系统名称
Public Const g_conVersion       As String = "V8.50"                  '----版本号
Public Const g_conMark          As String = "Y"                      '----标志符号
Public Const g_conMoveLimit     As Long = 1000                       '----
Public Const g_conF1FileName    As String = "F1File.Vts"             '----F1Book文件名

'----全局变量
Public g_oMenu                  As DOMDocument
Public g_sMenuDSN               As String
Public g_sF1FileName            As String
Public g_sDataSourceName        As String                            '----数据库连接串
Public g_oDataDB                As ADODB.Connection                  '----数据库对象
'Public g_oSysDB                 As UfDatabase                       '----系统数据库对象
'Public g_oTmpDB                 As DAO.Database                     '----本地临时数据库对象

'----枚举
Enum ShowModeEnum       '----显示方式
    smAddNew = 1
    smEdit
    smView
End Enum

Public Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Public Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Public Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
'Public Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Public Declare Function MessageBox Lib "user32" Alias "MessageBoxA" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As Long
Public Declare Function WinHelp Lib "user32" Alias "WinHelpA" (ByVal hwnd As Long, ByVal lpHelpFile As String, ByVal wCommand As Long, ByVal dwData As Long) As Long

Public zjLogInfo  As U8Login.clsLogin ' UFLoginSQL.Login
Public aClsPub    As clsPub                  '公用参照对象
Public zjNotecom  As New Notesvr.NoteCom

Public g_bIsDemo    As Boolean              '----演示版标志：True-演示版；False-正版

Public Sub Main()
    Dim mSplash As New U8Splash.clsSplash
    
    On Error GoTo errLogExit
    
    ZjAccInfo.zjPrnCtrl = True
    If App.PrevInstance Then
        Dim hwnd As Long, wndTitle As String
        wndTitle = GetSetting(App.Title, "Settings", "wndTitle", "")
        hwnd = FindWindow("ThunderRT5Form", wndTitle)
        If hwnd <> 0 Then
            ShowWindow hwnd, 1
            BringWindowToTop hwnd
            SetForegroundWindow hwnd
            Exit Sub
        Else
            Exit Sub
        End If
    End If
    
    Dim temp As String
    Dim xAccID As String
    Dim xYear As String
    Dim xUserID As String
    Dim xUserPwd As String
    Dim xDate As String
    Dim xServer As String 'Cuidong 2000/08/24
    Dim i As Integer
    Dim bLogin As SbarStyleConstants
    
    xYear = CDate(Date)
    If InStr(1, xYear, "-") = 0 Then
        MsgBox "系统日期格式必须为 YYYY-MM-DD ！", vbCritical, zjGl_Name
        Exit Sub
    End If
           
    Set zjLogInfo = New U8Login.clsLogin 'UFLoginSQL.Login
    'zjLogInfo.ProcessId = GetCurrentProcessId() 'Cuidong 2000/08
        
    '资金带参命令行
    i = 0
    If InStr(1, Command(), "-L") = 1 Then
        temp = Trim(Command())
        temp = Trim(mID(temp, InStr(1, temp, "{") + 1, InStr(1, temp, "}") - InStr(1, temp, "{") - 1))
        xAccID = left(temp, InStr(1, temp, vbTab) - 1)
        temp = mID(temp, InStr(1, temp, Chr(9)) + 1)
        xYear = left(temp, InStr(1, temp, Chr(9)) - 1)
        temp = mID(temp, InStr(1, temp, Chr(9)) + 1)
        xUserID = left(temp, InStr(1, temp, Chr(9)) - 1)
        temp = mID(temp, InStr(1, temp, Chr(9)) + 1)
        xUserPwd = left(temp, InStr(1, temp, Chr(9)) - 1)
        temp = mID(temp, InStr(1, temp, Chr(9)) + 1)
'        xDate = Temp                                  'Cuidong 2000/08/24
        xDate = left(temp, InStr(1, temp, Chr(9)) - 1) 'Cuidong 2000/08/24
        temp = mID(temp, InStr(1, temp, Chr(9)) + 1)   'Cuidong 2000/08/24
        xServer = temp                                 'Cuidong 2000/08/24
'        bLogin = zjLogInfo.Login("FD", xAccID, xYear, xUserID, xUserPwd, xDate)         'Cuidong 2000/08/24
        bLogin = zjLogInfo.Login("FD", xAccID, xYear, xUserID, xUserPwd, xDate, xServer) 'Cuidong 2000/08/24
    Else
redl:   bLogin = zjLogInfo.Login("FD")
    End If
    
    If Not bLogin Then GoTo errLogExit
    
    'V8.50 章景峰
    App.Title = "用友ERP-U8资金管理"
    g_sDataSourceName = zjLogInfo.UfDbName
    g_sMenuDSN = mID(zjLogInfo.UfDbName, 1, InStrRev(zjLogInfo.UfDbName, "=")) & "UFSystem"
    
    If zjLogInfo.curDate > Date Then
        'MsgBox "登录时间不能大于机器时间！", vbCritical, zjGl_Name
        If MsgBox("登录日期（" & Format(zjLogInfo.curDate, "YYYY-MM-DD") & "）在系统日期（" & Format(Date, "YYYY-MM-DD") & "）之后，继续运行吗？", vbInformation + vbYesNo + vbDefaultButton1, zjGl_Name) = vbNo Then
           i = i + 1
           If i > 1 Then
               GoTo errLogExit
           Else
               GoTo redl
           End If
        End If
    End If
        
    '----zcl change 2001.6.21
    Dim vDemo As Variant
    
    zjLogInfo.GetAccInfo 10000, vDemo
    g_bIsDemo = Not CBool(vDemo)
    
    '孙志远加
    m_objAddon.IniCommon zjLogInfo
    gToolbarStyle = 2  '现在世普通按钮情况
    gToolbarStyle = GetToolbarStyle
    m_objAid.LoadFromTemplate "budgetmgr/auth_ref", m_objAuthTree
    m_objAid.LoadFromTemplate "budgetmgr/sql_ref", m_objRefTree
    
    If g_bIsDemo Then
        mSplash.logStartup "资金管理 V8.50", "SQL Server 7.0/2000/MSDE" & Chr(10) + Chr(13) & "(演示/教学版)"
    Else
        mSplash.logStartup "资金管理 V8.50", "SQL Server 7.0/2000/MSDE"
    End If
    '----zcl change end
    
    DoEvents
    '设置打印模板(.REP) 路径
    ZjAccInfo.zjRepPath = App.Path & "\RES\"
    
    dbsZJ.OpenDatabase zjLogInfo.UfDbName, False, False, ";PWD=" & zjLogInfo.SysPassword
    
    '判断启用日期
    If Pd_qyrqsz(mSplash.logGethWnd()) <> 1 Then GoTo errLogExit
        
    Screen.MousePointer = vbHourglass
    
    '设置帮助文件
    App.HelpFile = ZjAccInfo.zjRepPath & "FDHelp.HLP"
    
    '建立临时库
    Dim str As String * 64, pos As Byte
    
    ZjAccInfo.zjTempDB = "ZJTEMP" & frmMain.hwnd & ".MDB"
    GetTempPath 64, str
    
    i = 1
    While i > 0
        pos = i
        i = i + 1
        i = InStrEx(i, str, "\")
    Wend
    ZjAccInfo.zjTempPath = LeftEx(str, pos - 1)
    AddSep ZjAccInfo.zjTempPath
            
    If Dir(ZjAccInfo.zjTempPath & ZjAccInfo.zjTempDB) <> "" Then
        Kill ZjAccInfo.zjTempPath & ZjAccInfo.zjTempDB     '清除本地临时库
    End If
    
    '凭证处理初始化
    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
    '建立并打开本地临时库
    Set dbsZjTemp = CreateDatabase(ZjAccInfo.zjTempPath & ZjAccInfo.zjTempDB, dbLangGeneral, dbVersion30)
        
    '创建打印临时表
    Ct_Prtab
     
    '导入科目级次
    LoadKmGrade
    
    Auth_Right
    
    Load frmMain
    mSplash.logEnd
    
    '--- From 8.10 To 8.11 升级模块
    UpgradeTo811
    
    '----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
    
    frmMain.Show
    'frmBackground.Show
    
    DoEvents
    '账套信息显示
    
    
    Dim iBkbc As Integer
'    iBkbc = frmBackground.ScaleHeight - frmBackground.imgCtlMain.Top
'    frmBackground.imgCtlMain.Top = frmBackground.ScaleHeight
'    frmBackground.imgCtlMain.Visible = True
'    For i = 1 To iBkbc
'        frmBackground.imgCtlMain.Top = frmBackground.imgCtlMain.Top - 1
'    Next
    
    frmMain.mnu_desktop.Checked = True
    frmMain.SetFocus
    
    '判断是否自动报警
    IsAutoAlarm
    
    With zjNotecom
        .DBName = zjLogInfo.UfSystemDb.Name
        .UseTName = "UA_User"
        .NoteShow zjLogInfo.cUserName, Format(zjLogInfo.curDate, "yyyy-mm-dd")
    End With
    
    ZjAccInfo.zjPrnCtrl = False
    Screen.MousePointer = vbDefault
    
    'zycAdd
    Set oV.connDB = dbsZJ.DbConnect
    Set oUniFind.UfDatabase = dbsZJ
    
    
    Exit Sub
    
errLogExit:
    
    ShowLogErrMsg
    
    ZjAccInfo.zjPrnCtrl = False
    Unload frmMain
    
End Sub

Public Sub AddSep(str As String)
    str = Trim(str)
    If RightEx(str, 1) <> gstrSEP_DIR Then
        str = str & gstrSEP_DIR
    End If
End Sub

Public Function LenEx(ByVal str As String) As Long
    LenEx = frmMain.ComEx.LenEx(str)
End Function

Public Function LeftEx(ByVal str As String, ByVal n As Long) As String
    LeftEx = frmMain.ComEx.LeftEx(str, n)
End Function

Public Function RightEx(ByVal str As String, ByVal n As Long) As String
    RightEx = frmMain.ComEx.RightEx(str, n)
End Function

Public Function InStrEx(ByVal Start As Long, ByVal str1 As String, ByVal str2 As String) As Long
    InStrEx = frmMain.ComEx.InStrEx(Start, str1, str2)
End Function

Public Sub UpgradeTo811()
   On Error Resume Next
      'zycAdd
   Dim sQ As String
   
   '升级FD_AccDef表 cuidong 2001.10.23
   '-------------------------------------
   sQ = "ALTER TABLE FD_AccDef ADD iYt INT NULL "
   dbsZJ.Execute sQ
   sQ = "ALTER TABLE FD_AccDef ADD cYtID VARCHAR(8) NULL "
   dbsZJ.Execute sQ
   '-------------------------------------
   
   If dbsZJ.TableDefs("fd_intras").Fields("bde").oType = 11 Then 'dbBoolean
            sQ = "ALTER TABLE fd_intras ADD bdeTemp tinyint "
            dbsZJ.Execute sQ
            sQ = "update fd_intras set bdeTemp=bde"
            dbsZJ.Execute sQ
            sQ = "EXEC sp_rename 'fd_intras.bde', 'bdeOld', 'COLUMN'"
            dbsZJ.Execute sQ
            sQ = "EXEC sp_rename 'fd_intras.bdeTemp', 'bde', 'COLUMN'"
            dbsZJ.Execute sQ
            sQ = " EXEC sp_bindefault 'FD_IntRas_bde_D','FD_IntRas.bde'"
            dbsZJ.Execute sQ
            sQ = "EXEC sp_unbindefault 'FD_IntRas.bdeOld'"
            dbsZJ.Execute sQ
            sQ = "ALTER TABLE fd_intras DROP COLUMN bdeOld"
            dbsZJ.Execute sQ
            dbsZJ.TableDefs.Refresh
   End If
   dbsZJ.Execute "ALTER TABLE FD_AccDef ADD cAccBank VARCHAR(60) NULL"
   dbsZJ.Execute "ALTER TABLE FD_CadAcr ADD mJs money "
   dbsZJ.Execute "ALTER TABLE FD_CadAcr ADD mcdeJs money "
   On Error GoTo 0
End Sub

'----取出当前所有币别名称，返回一维变长数组
Public Function GetAllCurrencyNames() As Variant
    Dim con As New ADODB.Connection
    Dim rec As New ADODB.Recordset
    Dim sql As String
    Dim arrTmp()    As String
    ReDim arrTmp(1)
    
    con.Open g_sDataSourceName
    
    sql = "select cexch_name from foreigncurrency group by cexch_name"
    
    rec.Open sql, con, adOpenDynamic
        
    With rec
        If Not rec.EOF Then
            .MoveFirst
            Do While Not .EOF
                arrTmp(UBound(arrTmp) - 1) = ![cexch_name]
                ReDim Preserve arrTmp(UBound(arrTmp) + 1)
                .MoveNext
            Loop
        End If
        .Close
    End With
    Set rec = Nothing
    Set con = Nothing
    ReDim Preserve arrTmp(UBound(arrTmp) - 1)
    GetAllCurrencyNames = arrTmp
End Function

'----得到临时目录
Public Function GetTmpPath() As String
    Dim str     As String * 128
    Dim iSize   As Long
    
    iSize = 127
    If GetTempPath(iSize, str) <> 0 Then
        GetTmpPath = left(str, InStr(1, str, Chr(0)) - 1)
    End If
End Function

Public Function SwitchDataType(DataType As U8FDEso.DataTypeEnum) As Integer
    Select Case DataType
        Case 1
            SwitchDataType = EditStr
        Case 2
            SwitchDataType = EditDate
        Case 3, 4
            SwitchDataType = EditDbl
        Case 5, 6
            SwitchDataType = EditLng
        Case 9
            SwitchDataType = EditId
        Case Else
            SwitchDataType = EditNormal
    End Select
End Function