mdlmain.bas

金算盘软件代码

Attribute VB_Name = "MDIMain"
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'  主模块
'  作者：黄涛
'  日期：1998.02.21
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Option Explicit
Public strBasePassWord As String                        '数据库口令
Public gAllInFormation As Boolean                        '全狗信息
Public gEndDate As String                                '全狗到期日
Public gExistIndog As Boolean
Private mstrDatabaseType As String                      ' 数据库类型 只能是Access或Oracle

Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, _
ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long

Public Sub Main()
    '当前版本的数据库类型
    'mstrDatabaseType = "ACCESS"
    mstrDatabaseType = "ORACLE"

     '系统实例处理
    If App.PrevInstance Then End
    
    App.HelpFile = "zw98.chm"
    
    '建立全局对象
    '建立帮助对象
    Set gclsEniv = New Eniv
    Set gclsSys = New Sys
    Set gclsBase = New Base
    
    Set gclsRes = New Res
    #If conWan = 1 Then
        gclsRes.ResourceFile = "AcntWinner.dll"
        strBasePassWord = Trim(Security(GetSetting("Winner Oracle Base", "Login", "PassWord", "")))
    #Else
        gclsRes.ResourceFile = "AcntRes.dll"
        strBasePassWord = Trim(Security(GetSetting("Gold Abacus Oracle Base", "Login", "PassWord", "")))
    #End If
    
    gclsBase.VersionInfo = "5.32.20000128"
    
    ExistDog
    GetTitle
    frmSplash.Show
    If frmSplash.ActiveRefresh Then frmSplash.Refresh
    
    Load frmMain
    frmMain.AutoShowChildren = False
    '等待动画运行结束
    Do While Not frmSplash.HaveComplete
    Loop
    Unload frmSplash
    Set frmSplash = Nothing
    frmMain.PicBrower.Visible = False
    frmMain.Show
    frmMain.OpenLast
    frmMain.SetToolBar
    
    If Not gclsBase.BaseDB Is Nothing Then
       UserRight.ShowWarnList
    End If
End Sub

Private Sub GetTitle()
  Dim lngSize As Long, lngReturnSize As Long
  Dim strKey As String
  Dim strINIFile As String
  Dim strByteName As String, strByteKey As String
  Dim strDefault As String, strTitle As String
    
    lngSize = 255
    strByteKey = "SYSTEM"
    strINIFile = App.Path & "\Account.ini"
    #If conWan = 1 Then
       strByteName = "万能软件"
    #Else
       strByteName = "金算盘软件"
    #End If
    
    #If conVersionType = 1 Then
       strDefault = "金算盘财务及企业管理软件(标准版)"
       gVersionType = vtStandard
    #Else
       #If conVersionType = 2 Then
          strDefault = "金算盘财务及企业管理软件(行政事业版)"
          gVersionType = vtAdmin
       #Else
          #If conVersionType = 4 Then
            strDefault = "金算盘商务管理软件(实达专用版)"
            gVersionType = vtStar
          #Else
            #If conVersionType = 8 Then
               strDefault = "金算盘商务管理软件(标准版)"
               gVersionType = vtTrade
            #Else
               strDefault = "金算盘财务软件中小型企业版"
               gVersionType = vtAccount
            #End If
          #End If
          '....其它版本
       #End If
    #End If
    
    '取得INI文件中的字符串（节名，关键字，默认值，返回字符串，返回字符串长度，文件名）
    '取得INI文件中样板数据库路径
    strTitle = Space(255)
    lngReturnSize = GetPrivateProfileString(strByteName, strByteKey, strDefault, strTitle, lngSize, strINIFile)
    App.title = Left(strTitle, lngReturnSize)
End Sub

'软件狗是否存在
Private Function ExistDog() As Boolean
       If CkInfo(9) = 0 And Trim(RdInfo(170, 11, 181)) = "Gold Abacus" Then
          ExistDog = True
          ReadDog
          gExistIndog = True
       Else
          ExistDog = False
          gExistIndog = False
       End If
   
End Function

' 新版本读狗，限定Access版只能使用Access版狗，Oracle版本只能使用Oracle狗
Private Function RdInfo2(ByVal intAddr As Integer, ByVal intLen As Integer, ByVal intPass As Integer, ByVal strDBType As String) As String
    Dim strInfo As String
    Dim strRight As String
    
    strInfo = RdInfo(intAddr, intLen, intPass)
    strRight = Right(strInfo, 1)
    
    If strDBType = "ACCESS" Then
        ' 制作码中Oracle版本是以3(主站)或4(工作站)结尾
        If strRight = "3" Or strRight = "4" Then
            strInfo = Space(intLen)
        End If
    Else
        If strRight <> "3" And strRight <> "4" Then
            strInfo = Space(intLen)
        End If
    End If
    RdInfo2 = strInfo
End Function

'读软件狗信息
Private Function ReadDog() As Boolean
    Dim strMid As String
    #If conVersionType = 4 Then
        If Trim(RdInfo(159, 3, 162)) = "ALL" Then
            gAllInFormation = True
            gcolDogInfo.Add RdInfo(159, 3, 162), "All" '全狗
            strMid = Trim(RdInfo(162, 8, 170)) '全狗到期日
            gEndDate = Mid(strMid, 1, 4) & "-" & Mid(strMid, 5, 2) & "-" & Mid(strMid, 7, 2)
            Exit Function
        Else
            gAllInFormation = False
        End If
         gcolDogInfo.Add RdInfo2(0, 5, 5, mstrDatabaseType), "ZW" '帐务
         gcolDogInfo.Add RdInfo2(5, 2, 7, mstrDatabaseType), "YS" '应收
         gcolDogInfo.Add RdInfo2(7, 2, 9, mstrDatabaseType), "YF" '应付
         gcolDogInfo.Add RdInfo2(9, 2, 11, mstrDatabaseType), "ET" '电子报表
         gcolDogInfo.Add RdInfo2(11, 2, 13, mstrDatabaseType), "YH" '现金银行
         gcolDogInfo.Add RdInfo2(13, 2, 15, mstrDatabaseType), "GZ" '工资
         gcolDogInfo.Add RdInfo2(15, 2, 17, mstrDatabaseType), "GD" '固定资产
         gcolDogInfo.Add RdInfo2(17, 2, 19, mstrDatabaseType), "CG" '采购
         gcolDogInfo.Add RdInfo2(19, 2, 21, mstrDatabaseType), "XS" '销售
         gcolDogInfo.Add RdInfo2(21, 2, 23, mstrDatabaseType), "KC" '库存
         
         gcolDogInfo.Add RdInfo2(35, 2, 37, mstrDatabaseType), "CX" '领导查询
         gcolDogInfo.Add RdInfo2(37, 2, 39, mstrDatabaseType), "FX" '帐务分析
         gcolDogInfo.Add RdInfo2(39, 2, 41, mstrDatabaseType), "JY" '经营分析
         
         gcolDogInfo.Add RdInfo2(43, 2, 45, mstrDatabaseType), "WT" ' 委托加工

         
        ' gcolDogInfo.Add RdInfo2(45, 2, 47, mstrDatabaseType), "BS" '电子报税
'         gcolDogInfo.Add RdInfo2(38, 2, 40, mstrDatabaseType), "ZJ" ' 资金中心
'         gcolDogInfo.Add RdInfo2(40, 2, 42, mstrDatabaseType), "JH" ' 内部稽核
         
      #Else
         If Trim(RdInfo(159, 3, 162)) = "ALL" Then
            gAllInFormation = True
            gcolDogInfo.Add RdInfo(159, 3, 162), "All" '全狗
            strMid = Trim(RdInfo(162, 8, 170)) '全狗到期日
            gEndDate = Mid(strMid, 1, 4) & "-" & Mid(strMid, 5, 2) & "-" & Mid(strMid, 7, 2)
            Exit Function
         Else
            gAllInFormation = False
         End If
         gcolDogInfo.Add RdInfo2(0, 5, 5, mstrDatabaseType), "ZW" '帐务
         gcolDogInfo.Add RdInfo2(5, 2, 7, mstrDatabaseType), "YS" '应收
         gcolDogInfo.Add RdInfo2(7, 2, 9, mstrDatabaseType), "YF" '应付
         gcolDogInfo.Add RdInfo2(9, 2, 11, mstrDatabaseType), "ET" '电子报表
         gcolDogInfo.Add RdInfo2(11, 2, 13, mstrDatabaseType), "YH" '现金银行
         gcolDogInfo.Add RdInfo2(13, 2, 15, mstrDatabaseType), "GZ" '工资
         gcolDogInfo.Add RdInfo2(15, 2, 17, mstrDatabaseType), "GD" '固定资产
         gcolDogInfo.Add RdInfo2(17, 2, 19, mstrDatabaseType), "CG" '采购
         gcolDogInfo.Add RdInfo2(19, 2, 21, mstrDatabaseType), "XS" '销售
         gcolDogInfo.Add RdInfo2(21, 2, 23, mstrDatabaseType), "KC" '库存
         
         gcolDogInfo.Add RdInfo2(35, 2, 37, mstrDatabaseType), "CX" '领导查询
         gcolDogInfo.Add RdInfo2(37, 2, 39, mstrDatabaseType), "FX" '帐务分析
         gcolDogInfo.Add RdInfo2(39, 2, 41, mstrDatabaseType), "JY" '经营分析
         gcolDogInfo.Add RdInfo2(43, 2, 45, mstrDatabaseType), "WT" ' 委托加工
         
'         gcolDogInfo.Add RdInfo2(86, 2, 88, mstrDatabaseType), "BS" '电子报税
'         gcolDogInfo.Add RdInfo2(88, 2, 90, mstrDatabaseType), "ZJ" ' 资金中心
'         gcolDogInfo.Add RdInfo2(90, 2, 92, mstrDatabaseType), "JH" ' 内部稽核
      #End If
  
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'权限在软件狗中是否存在
'strModal：模块代码
'          总分类帐：ZW  应收应付：WL  现金银行：YH  电子表格：ET  工资系统：GZ
'          固定资产：GD  库存：KC  采购：CG  销售：XS  数据挖掘：WJ  经营分析：FX
'          领导查询：CX  计划预算：YS  电子报税：BS  资金中心：ZJ  内部稽核：JH 全狗:All
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function RightInDog(ByVal strModal As String) As Boolean
  Dim strRight As String
   On Error GoTo ErrHandle
   strRight = Trim(gcolDogInfo.Item(strModal))
   If strRight = "" Then
       RightInDog = False
   Else
       RightInDog = True
   End If
ErrHandle:
End Function
Public Function IsExistDogInformation(ByVal strModal As String) As Boolean
        IsExistDogInformation = False
        IsExistDogInformation = (RightInDog(strModal) Or gAllInFormation)
End Function
'业务重组的Function
'strModal：模块代码

'总分类帐:Account  应收: Income   应付：Pay 现金银行：CashBank 工资系统： Salary
'固定资产：FixedAssets 库存：Stock    采购： Purchase 销售： Sale  财务分析：AnalysOFFinances
'领导查询：LeaderLook  企业资料    : InfoOFBusiness 委托加工: LENDPROCESS 经营分析： AnalysOFManage
'电子表格 : ElectricTable
Public Function EnableMudal(ByVal strMudal As String) As Boolean
    EnableMudal = False
    If Not ExistInDog Then
        EnableMudal = True
        Exit Function
    End If
    If RightInDog("All") Then
        EnableMudal = True
        Exit Function
    End If
    Select Case UCase(strMudal)
        Case "ACCOUNT"
            If RightInDog("ZW") Then EnableMudal = True
        Case "INCOME"
            If RightInDog("YS") Then EnableMudal = True
        Case "PAY"
            If RightInDog("YF") Then EnableMudal = True
        Case "CASHBANK"
            If RightInDog("YH") Then EnableMudal = True
        Case "SALARY"
            If RightInDog("GZ") Then EnableMudal = True
        Case "FIXEDASSETS"
            If RightInDog("GD") Then EnableMudal = True
        Case "STOCK"
            If RightInDog("KC") Then EnableMudal = True
        Case "PURCHASE"
            If RightInDog("CG") Then EnableMudal = True
        Case "SALE"
            If RightInDog("XS") Then EnableMudal = True
        Case "ANALYSOFMANAGE"
            If RightInDog("JY") Then EnableMudal = True
        Case "LEADERLOOK"
            If RightInDog("CX") Then EnableMudal = True
        Case "ANALYSOFFINANCES"
            If RightInDog("FX") Then EnableMudal = True
        Case "ELECTRICTABLE"
            If RightInDog("ET") Then EnableMudal = True
        Case "INFOOFBUSINESS"
            EnableMudal = True
        Case "LENDPROCESS"
            If RightInDog("WT") Then EnableMudal = True
    End Select
    
End Function
Public Function ExistInDog() As Boolean
    ExistInDog = gExistIndog
End Function