base.cls

金算盘软件代码

       If UCase(strDriver) = UCase("Oracle ODBC Driver") Then
              mstrCon = "uid=" & mUID & ";pwd=" & sPWD & ";DBQ=" & strConnect & ";Driver={" & strDriver & "};"
              Set mvarBaseDB = mvarBaseWorkSpace.OpenConnection(dsName:="", _
                     Prompt:=rdDriverNoPrompt, _
                     Connect:=mstrCon)
       Else
              mstrCon = "uid=" & mUID & ";pwd=" & sPWD & "@" & strConnect & ";" & "Driver={" & strDriver & "};"
              Set mvarBaseDB = mvarBaseWorkSpace.OpenConnection(dsName:="", _
                     Prompt:=rdDriverNoPrompt, _
                     Connect:=mstrCon)
       End If
        On Error GoTo ErrHandle
    Else
       BaseFile = ""
       OpenDatabase = False
       Exit Function
    End If
    
    strSql = "ALTER SESSION SET NLS_DATE_FORMAT='YYYY-MM-DD'"
    mvarBaseDB.Execute strSql
    strSql = "Select * From Business"
    Set rstVersion = BaseDB.OpenResultset(strSql, rdOpenStatic)
    #If conDebug = 0 Then
        With rstVersion
           If Not .EOF Then
              If UCase(!strVer) <> UCase(mstrVersion) Then
                 ShowMsg frmMain.hwnd, "升级版不能打开老帐套!", vbQuestion + vbOKOnly, App.title
                 Set mvarBaseDB = Nothing
                 frmMain.mnuWindowDiagram.Checked = False
                 Exit Function
              End If
           End If
        End With
        
        If InStr(1, UCase(StrFileName), "SYSBASE") > 0 Then
           OpenDatabase = True
           Exit Function
        End If
    #End If
    
    '打开上机日志
    Set grecLog = BaseDB.OpenResultset("SELECT * FROM Log", rdOpenDynamic, rdConcurValues)

    BaseFile = StrFileName
    BaseType = conBaseType
    GetBaseInfo
    frmMain.Caption = App.title + ":" + BaseFile
    If IsLogin Then
        If Not frmLogin.LogIn Then
            CloseDatabase
            OpenDatabase = False
            Exit Function
        End If
        SetMenuRight
        frmMain.UpdateMenuStatus
        frmMain.UpdateStatus
    End If
    
    #If conVersionType = 4 Then
       If CDate(mvarBaseDate) > CDate("1998-12-30") Then
           ShowMsg frmMain.hwnd, "实达专用版试用期不能超过1998年12月30日", vbOKOnly, App.title
           CloseDatabase
           Exit Function
       End If
    #End If
    
    OpenDatabase = True
    
    If IsEditMnu Then
        UpdateMRU StrFileName
    End If
    
    Exit Function

ErrHandle:
    edtErrReturn = Errors.ErrorsDeal(, , ErrNum)
    
    If edtErrReturn = edtResume Then
         Resume
    End If
    
    BaseFile = ""
    OpenDatabase = False
    Exit Function
Err1:
    If Err.Number = 40002 Then
        If lngTime = 0 Then
            lngTime = 1
            Resume ReOpen
        Else
            blnShowWindow = True
            If ShowMsg(frmMain.hwnd, "因为帐套“" & StrFileName & "”已被破坏或者Oracle的连接字或ODBC驱动程序的选择错误等原因导致导致连接Oracle数据库失败，是否要改变Oracle的连接字或ODBC驱动程序重试？", vbYesNo, App.title) = IDYES Then
                Resume ReOpen
            End If
        End If
    End If
    
    Err.Clear
    BaseFile = ""
    OpenDatabase = False
End Function

Public Sub GetBaseInfo()
  Dim rstCur As rdoResultset
  Dim rstBaseInfo As rdoResultset
  Dim strQuanFat As String, strNatureFat As String, strPriceFat As String, strSql As String
  Dim strKey As String, strTemp As String
  
      On Error Resume Next
      Set rstCur = mvarBaseDB.OpenResultset("Select * From Currencys Order By lngCurrencyID", rdOpenStatic)
      With rstCur
         If Not .EOF Then
             mvarNaturalCurId = !lngCurrencyID
             mvarNaturalCurCode = !strCurrencyCode
             mvarNaturalCurName = !strCurrencyName
             mvarNaturalCurDec = !bytCurrencydec
             mvarNaturalRateDec = !bytRateDec
             strNatureFat = GetFormat(mvarNaturalCurDec, True)
         End If
         Set mcolCurrencyDec = New Collection
         Set mcolRateDec = New Collection
         Do While Not .EOF
            mcolCurrencyDec.Add .rdoColumns("bytCurrencyDec").Value, Trim(.rdoColumns("strCurrencyName").Value)
            mcolRateDec.Add .rdoColumns("bytRateDec").Value, .rdoColumns("strCurrencyName").Value
            .MoveNext
         Loop
      End With
      
      Set rstCur = Nothing
      
      Set rstBaseInfo = mvarBaseDB.OpenResultset("Select Business.*,Trade.strTradeName From Business,Trade Where Business.lngTradeID=Trade.lngTradeID", rdOpenStatic)
      With rstBaseInfo
         If Not .EOF Then
             mblnNoOrder = !blnVoucher
             mstrTrade = !strTradeName
             mblnIsControl = !blnIsControl
             mvarQuantityDec = !bytQuantityDec
             mvarPriceDec = !bytPriceDec
             mvarManager = !strManager
             mstrAccountSys = !strAccountSystem
             
             strQuanFat = GetFormat(mvarQuantityDec, True)
             strPriceFat = GetFormat(mvarPriceDec, True)
             On Error GoTo 0
             mvarCustomerAddress = !strBillToAddress
             mvarCustomerName = IIf(IsNull(!StrUserName), "", !StrUserName)
             If Not IsNull(!strStartDate) Then
                mvarBeginDate = CDate(!strStartDate)
             Else
                mvarBeginDate = Date
             End If
         End If
      End With
      Set rstBaseInfo = Nothing
      
'      strSql = "Update NumFormat Set strNatrueFormat='" & strNatureFat & "',strQuantityFormat='" & strQuanFat & _
'               "',strPriceFormat='" & strPriceFat & "'"
'      ExecSQL strSql
'
'      strSql = "Select * From NumFormat"
'      Set rstBaseInfo = mvarBaseDB.OpenResultset(strSql, rdOpenDynamic, rdConcurValues)
'      With rstBaseInfo
'        Do While Not .EOF
'           .Edit
'              strTemp = !strFormat
'              strTemp = strReplace(strTemp, "#0", "99999999999999")
'              !strFormat = strTemp
'           .Update
'           .MoveNext
'        Loop
'      End With
'      Set rstBaseInfo = Nothing
      
      Set rstBaseInfo = mvarBaseDB.OpenResultset("Select intYear From AccountYear", rdOpenStatic)
      With rstBaseInfo
         If Not .EOF Then
            .MoveFirst
            mintBeginYear = !intYear
         End If
      End With
      Set rstBaseInfo = Nothing
      
      strSql = " Select strStartDate,strEndDate,lngCloseID,intYear,bytPeriod From AccountPeriod Order By intYear,bytPeriod"
      Set rstBaseInfo = mvarBaseDB.OpenResultset(strSql, rdOpenStatic)
      With rstBaseInfo
         If Not .EOF Then
            mstrFirstDate = Format(!strStartDate, "yyyy-MM-dd")
            .MoveLast
            mvarEndDate = !strEndDate
            Set mcolPeriodClose = New Collection
            Set mcolPeriodBegin = New Collection
            Set mcolPeriodEnd = New Collection
            Set mcolYear = New Collection
            Set mcolPeriod = New Collection
            mbytBeginPeriod = 0
            mintMaxClosedYear = 0
            mbytMaxClosedPeriod = 0
            .MoveFirst
            Do While Not .EOF
                If !strStartDate <= Format(mvarBeginDate, "yyyy-mm-dd") And !strEndDate >= Format(mvarBeginDate, "yyyy-mm-dd") Then
                   mbytBeginPeriod = !bytPeriod
                End If
                strKey = !intYear & Format(!bytPeriod, "00")
                If .rdoColumns("lngCloseID").Value <> 0 Then
                   mintMaxClosedYear = !intYear
                   mbytMaxClosedPeriod = !bytPeriod
                End If
                mcolPeriodClose.Add .rdoColumns("lngCloseID").Value, strKey
                mcolPeriodBegin.Add .rdoColumns("strStartDate").Value, strKey
                mcolPeriodEnd.Add .rdoColumns("strEndDate").Value, strKey
                mcolYear.Add .rdoColumns("intYear").Value, strKey
                mcolPeriod.Add .rdoColumns("bytPeriod").Value, strKey
                .MoveNext
            Loop
         End If
      End With
      Set rstBaseInfo = Nothing

      strSql = " Select * From Setting Where strKey='单据号不可修改'"
      Set rstBaseInfo = mvarBaseDB.OpenResultset(strSql, rdOpenStatic)
      With rstBaseInfo
         If Not .EOF Then
            If UCase(!strSetting) = UCase("True") Then
               mblnAutoNo = True
            Else
               mblnAutoNo = False
            End If
         Else
            mblnAutoNo = False
         End If
      End With
      Set rstBaseInfo = Nothing
      
      strSql = " Select * From Setting Where strKey='原始非控制科目模式'"
      Set rstBaseInfo = mvarBaseDB.OpenResultset(strSql, rdOpenStatic)
      With rstBaseInfo
         If Not .EOF Then
            If UCase(!strSetting) = UCase("True") Then
               mblnBaseNoControl = True
            Else
               mblnBaseNoControl = False
            End If
         Else
            mblnBaseNoControl = True
         End If
      End With
      Set rstBaseInfo = Nothing
      
      strSql = " Select * From Setting Where strKey='单据号不可修改'"
      Set rstBaseInfo = mvarBaseDB.OpenResultset(strSql, rdOpenStatic)
      With rstBaseInfo
         If Not .EOF Then
            If UCase(!strSetting) = UCase("True") Then
               mblnAutoNo = True
            Else
               mblnAutoNo = False
            End If
         Else
            mblnAutoNo = False
         End If
      End With
      Set rstBaseInfo = Nothing
      
      strSql = " Select * From Setting Where strKey='修改机制凭证'"
      Set rstBaseInfo = mvarBaseDB.OpenResultset(strSql, rdOpenStatic)
      With rstBaseInfo
         If Not .EOF Then
            mbytEditMVoucher = IIf(IsNull(!strSetting), 1, !strSetting)
         Else
            mbytEditMVoucher = 1
         End If
      End With
      
      '得到社保参数
      #If conHos Then
            strSql = "Select * From Setting Where lngModuleID=16 And (strSection='缴费比例' Or strSection='统筹基金起付标准')"
            Set rstBaseInfo = mvarBaseDB.OpenResultset(strSql, rdOpenStatic)
            With rstBaseInfo
               Do While Not .EOF
                  Select Case !strKey
                  Case "单位为退休人员缴纳比例"
                      mintToRetireRate = !strSetting
                  Case "单位为在职人员缴纳比例"
                      mintToWorkRate = !strSetting
                  Case "在职人员个人缴纳比例"
                      mintPersonRate = !strSetting
                  Case "划入退休人员个人帐户比例"
                      mintRetireRate = !strSetting
                  Case "年平均"
                      mdblFundAverage = !strSetting
                  Case "最高限额"
                      mdblFundLimit = !strSetting
                  End Select
                  .MoveNext
               Loop
            End With
      #End If
      Set rstBaseInfo = Nothing
End Sub

Public Function GetFormat(ByVal intDec As Integer, Optional IsForSql As Boolean = False) As String
  Dim intCount As Integer
  
   If intDec <= 0 Then
      GetFormat = ""
      Exit Function
   Else
      If IsForSql Then
         '位数需增加
         GetFormat = "999999999990."
      Else
         GetFormat = "#0."
      End If
   End If
   For intCount = 1 To intDec
        GetFormat = GetFormat & "0"
   Next intCount
End Function

Public Function GetSqlFormat(ByVal intDec As Integer) As String
  Dim intCount As Integer
  
   If intDec <= 0 Then
      GetSqlFormat = ""
      Exit Function
   Else
      GetSqlFormat = "99999999999990."
   End If
   For intCount = 1 To intDec
        GetSqlFormat = GetSqlFormat & "0"
   Next intCount
End Function

'取指定日期对应的会计期间（可同时返回其起止日期）
Public Function PeriodOfDate(ByVal dDate As Date, Optional dBegin As Date, Optional dEnd As Date) As Integer
   Dim rstPeriod As rdoResultset
   Dim intYear As Integer
   Dim blnOverBegin As Boolean
   
   intYear = FYearOfDate(dDate)
   Set rstPeriod = BaseDB.OpenResultset("Select * from AccountPeriod Where intYear=" & intYear & " Order By bytPeriod", rdOpenStatic)
   blnOverBegin = False
   With rstPeriod