base.cls

金算盘软件代码

            GoTo EndProc
        End If
    End If
EndProc:
    Set clsFomular = Nothing
    Set rstBudget = Nothing
End Function

'关闭帐套数据库
Public Sub CloseDatabase()
  Dim intCount As Integer
  
    '关闭上机日志
    If Not grecLog Is Nothing Then
        grecLog.Close
        Set grecLog = Nothing
    End If
    
    'Close MDI Windows
    On Error Resume Next
    gblnCancel = False
    For intCount = 1 To gclsSys.MainControls.Count
       Unload gclsSys.MainControls(1).Form
       If gblnCancel Then
          Exit Sub
       End If
    Next
    
    '关闭数据库
    If Not BaseDB Is Nothing Then
        BaseDB.Close
        Set BaseDB = Nothing
    End If
    
    '关闭工作区
    If Not mvarBaseWorkSpace Is Nothing Then
        mvarBaseWorkSpace.Close
        Set mvarBaseWorkSpace = Nothing
    End If
    BaseFile = ""
    BaseType = ""
    '清除公用记录集资源
    ClearListRecordSet
    
    frmMain.UpdateStatus
    frmMain.UpdateMenuStatus
End Sub

'判断日期是否合法(演示版只能用三个月)
Public Function DateIsValid(ByVal strDate As String) As Boolean
  Dim intCount As Integer
  Dim intUse As Integer, strUse As String, strVersion As String
  
    If gExistIndog Then
       DateIsValid = True
       Exit Function
    End If
    
    Select Case mbytVersionType
       Case 0
          strVersion = "演示版"
          strUse = "三"
          intUse = 2
       Case 1
          strVersion = "教学版"
          strUse = "六"
          intUse = 5
    End Select
    
    If mbytBeginPeriod + intUse <= 12 Then
       intCount = mbytBeginPeriod + intUse
    Else
       intCount = 12
    End If
    If strDate > mcolPeriodEnd.Item(intCount) Then
       ShowMsg frmMain.hwnd, strVersion & "只能用" & strUse & "个期间并且不能超过第十二个期间,日期非法！", vbOKOnly + vbInformation, App.title
       DateIsValid = False
    Else
       DateIsValid = True
    End If
End Function

'取一会计年度的起止日期
Public Function DateOfFanYear(ByVal intYear As Integer, Optional dBegin As Date, Optional dEnd As Date)
  Dim rstYear As rdoResultset
   Set rstYear = BaseDB.OpenResultset("Select * from AccountPeriod Where intYear=" & intYear, rdOpenStatic)
   With rstYear
       If .EOF Then
          Exit Function
       End If
       .MoveFirst
       dBegin = !strStartDate
       .MoveLast
       dEnd = !strEndDate
   End With
End Function

'取一会计期间的起止日期
Public Function DateOfPeriod(ByVal intYear As Integer, ByVal intPeriod As Integer, Optional dBegin As Date, Optional dEnd As Date)
  Dim rstPeriod As rdoResultset
   Set rstPeriod = BaseDB.OpenResultset("Select * from AccountPeriod Where intYear=" & intYear & "And bytPeriod=" & intPeriod, rdOpenStatic)
   With rstPeriod
       If .EOF Then
          Exit Function
       End If
       dBegin = !strStartDate
       dEnd = !strEndDate
   End With
End Function

'执行动作查询
Public Function ExecSQL(ByVal strSql As String) As Boolean
    Dim edtErrReturn As ErrDealType
    On Error GoTo Err_Handle
    BaseDB.Execute strSql, rdExecDirect
    
    ExecSQL = True
    
    Exit Function

Err_Handle:
    edtErrReturn = Errors.ErrorsDeal
End Function

'取指定日期对应的会计年度（可同时返回其起止日期）
Public Function FYearOfDate(ByVal dDate As Date, Optional dBegin As Date, Optional dEnd As Date, Optional Period As Integer) As Integer
  Dim intCount As Integer
    
    For intCount = 1 To mcolPeriodBegin.Count
        If Format(dDate, "yyyy-mm-dd") >= mcolPeriodBegin.Item(intCount) _
           And Format(dDate, "yyyy-mm-dd") <= mcolPeriodEnd.Item(intCount) Then
           FYearOfDate = Val(mcolYear.Item(intCount))
           Period = Val(mcolPeriod.Item(intCount))
           dBegin = mcolPeriodBegin.Item(intCount)
           dEnd = mcolPeriodEnd.Item(intCount)
           Exit Function
        End If
    Next intCount
    FYearOfDate = Year(dDate)
    Period = 0
    dBegin = dDate
    dEnd = dDate
End Function

'取一时间段对应的起始日期
Public Function GetBeginAndEndDate(ByVal DateType As String, Optional dNow As Date, Optional dBegin As Date, Optional dEnd As Date, Optional blnFinancial As Boolean = False)
  Dim Interval As Integer
  Dim dTemp As Date, intQuarter As Integer, intYear As Integer
     
     If dNow = 0 Then
       dNow = mvarBaseDate
     End If
     
     Select Case DateType
         Case "今天"
             dBegin = dNow
             dEnd = dNow
         Case "本周"
             Interval = DatePart("W", dNow)
             dBegin = DateAdd("W", -(Interval - 1), dNow)
             dEnd = DateAdd("d", 6, dBegin)
         Case "本周至今日"
             Interval = DatePart("W", dNow)
             dBegin = DateAdd("W", -(Interval - 1), dNow)
             dEnd = Format(mvarBaseDate, "YYYY-MM-DD")
         Case "上周"
             dTemp = DateAdd("WW", -1, dNow)
             GetBeginAndEndDate "本周", dTemp, dBegin, dEnd
         Case "本期"
             PeriodOfDate dNow, dBegin, dEnd
         Case "本期至今日"
             PeriodOfDate dNow, dBegin, dEnd
             dEnd = Format(mvarBaseDate, "YYYY-MM-DD")
         Case "上期"
             PeriodOfDate dNow, dBegin, dEnd
             dBegin = DateAdd("D", -1, dBegin)
             PeriodOfDate dBegin, dBegin, dEnd
         Case "本月"
             Interval = Day(dNow)
             dBegin = DateAdd("D", -(Interval - 1), dNow)
             dEnd = DateAdd("M", 1, dBegin)
             dEnd = DateAdd("D", -1, dEnd)
         Case "本月至今日"
             Interval = Day(dNow)
             dBegin = DateAdd("D", -(Interval - 1), dNow)
             dEnd = Format(mvarBaseDate, "YYYY-MM-DD")
         Case "上月"
             dTemp = DateAdd("M", -1, dNow)
             GetBeginAndEndDate "本月", dTemp, dBegin, dEnd
         Case "本季度"
             dTemp = dNow
             intQuarter = DatePart("Q", dTemp)
             Do While DatePart("Q", DateAdd("M", -1, dTemp)) = intQuarter
                 dTemp = DateAdd("M", -1, dTemp)
             Loop
             GetBeginAndEndDate "本月", dTemp, dBegin
             Do While DatePart("Q", DateAdd("M", 1, dTemp)) = intQuarter
                 dTemp = DateAdd("M", 1, dTemp)
             Loop
             GetBeginAndEndDate "本月", dTemp, , dEnd
         Case "本季至今日"
             dTemp = dNow
             intQuarter = DatePart("Q", dTemp)
             Do While DatePart("Q", DateAdd("M", -1, dTemp)) = intQuarter
                 dTemp = DateAdd("M", -1, dTemp)
             Loop
             GetBeginAndEndDate "本月", dTemp, dBegin
             dEnd = Format(mvarBaseDate, "YYYY-MM-DD")
         Case "上季度"
             dTemp = DateAdd("Q", -1, dNow)
             GetBeginAndEndDate "本季度", dTemp, dBegin, dEnd
         Case "本年"
              If blnFinancial Then
                  FYearOfDate dNow, dBegin, dEnd
              Else
                  Interval = DatePart("Y", dNow)
                  dBegin = DateAdd("D", -(Interval - 1), dNow)
                  dEnd = DateAdd("YYYY", 1, dBegin)
                  dEnd = DateAdd("D", -1, dEnd)
              End If
         Case "本年至今日"
              If blnFinancial Then
                  FYearOfDate dNow, dBegin, dEnd
              Else
                  Interval = DatePart("Y", dNow)
                  dBegin = DateAdd("D", -(Interval - 1), dNow)
                  dEnd = Format(mvarBaseDate, "YYYY-MM-DD")
              End If
         Case "去年"
              If blnFinancial Then
                  FYearOfDate dNow, dBegin, dEnd
                  dTemp = DateAdd("D", -1, dBegin)
                  GetBeginAndEndDate "本年", dTemp, dBegin, dEnd
              Else
                  dTemp = DateAdd("YYYY", -1, dNow)
                  GetBeginAndEndDate "本年", dTemp, dBegin, dEnd
              End If
     
     End Select
     dBegin = Format(dBegin, "YYYY-MM-DD")
     dEnd = Format(dEnd, "YYYY-MM-DD")
End Function

'取币种小数位数
Public Function GetCurrencyDec(ByVal strCurrencyName As String) As Integer
  On Error Resume Next
  GetCurrencyDec = mcolCurrencyDec.Item(strCurrencyName)
End Function

'取一时间条件对应的起止时间
Public Function GetDateOfCond(Optional dBegin As Date, Optional dEnd As Date, Optional ByVal TableName As String = "", Optional ByVal FieldName As String = "", Optional Cond As String = "") As Boolean
  Dim strSql As String
  Dim rstDate As rdoResultset
  Dim strWhereTemp As String
        
      On Error GoTo ErrHandle
      strWhereTemp = IIf(Trim(Cond) = "", " ", " where ")
      strSql = "Select " & FieldName & " From " & TableName & strWhereTemp & Cond & " Order By " & FieldName
      Set rstDate = mvarBaseDB.OpenResultset(strSql, rdOpenStatic)
      With rstDate
         If Not .EOF Then
             .MoveFirst
             dBegin = CDate(.rdoColumns(FieldName))
             .MoveLast
             dEnd = CDate(.rdoColumns(FieldName))
         Else
             dBegin = Date
             dEnd = Date
         End If
      End With
      GetDateOfCond = True
      Exit Function
ErrHandle:
End Function


'取汇率小数位数
Public Function GetRateDec(ByVal strCurrencyName As String) As Integer
  On Error Resume Next
  GetRateDec = mcolRateDec.Item(strCurrencyName)
End Function


'取视图ID
Public Function GetViewID(strViewName As String) As Long
 Dim rstView As rdoResultset
 Dim strSql As String
  strSql = "Select lngViewID from View Where strViewName='" & strViewName & "'"
  Set rstView = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
  If Not rstView.EOF Then
     GetViewID = rstView!lngViewId
  End If
End Function

'取视图 SQL 的 FROM 子句
Public Function GetViewSqlFrom(Optional ByVal lngViewId As Long, Optional strViewName As String = "") As String
 Dim strSql As String
 Dim rstView As rdoResultset
   If strViewName = "" Then
      strSql = "select strViewSQL from View Where lngViewID=" & lngViewId
   Else
      strSql = "select strViewSQL from View Where strViewName='" & strViewName & "'"
   End If
   Set rstView = gclsBase.BaseDB.OpenResultset(strSql)
   If Not rstView.EOF Then
       GetViewSqlFrom = rstView!strViewSQL
   End If
End Function

'打开帐套数据库
Public Function OpenDatabase(ByVal StrFileName As String, Optional IsLogin As Boolean = True, _
                             Optional IsEditMnu As Boolean = True, Optional ErrNum As Long, Optional Exclusive As Boolean = False) As Boolean
    Dim edtErrReturn As ErrDealType
    Dim rstVersion As rdoResultset, strSql As String
    Dim sPWD As String
    Dim strDriver As String
    Dim strConnect As String
    Dim blnShowWindow As Boolean
    Dim lngTime As Long
    strConnect = ""
    On Error GoTo ErrHandle
    lngTime = 0
    If InStr(StrFileName, "\") > 0 Then
        StrFileName = ""
    End If
    mUID = StrFileName
    If InStr(mUID, "/") > 0 Then
        mUID = Mid$(mUID, InStr(mUID, "/") + 1)
    End If
    
    ' 关闭以前打开的数据库及工作区
    If Not mvarBaseDB Is Nothing Then
       CloseDatabase
    End If
    
    '打开工作区
    Set mvarBaseWorkSpace = rdoEnvironments(0)
    mvarBaseWorkSpace.CursorDriver = rdUseOdbc
    blnShowWindow = False
ReOpen:
    If frmODBCLogon.OpenBase(mUID, strConnect, strDriver, blnShowWindow, sPWD) Then
       '打开数据库
       On Error GoTo Err1