base.cls

金算盘软件代码

       If .EOF Then
          Exit Function
       End If
       Do While Not .EOF
          If CDate(!strStartDate) <= dDate Then
              blnOverBegin = True
          End If
          If CDate(!strEndDate) >= dDate And blnOverBegin Then
              PeriodOfDate = !bytPeriod
              dBegin = CDate(!strStartDate)
              dEnd = CDate(!strEndDate)
              Exit Do
          End If
          .MoveNext
       Loop
   End With
End Function

'科目是否明细科目
Public Function AccountIsDetail(ByVal AccountID As Long, Optional GetSub As Boolean = False, Optional SubAccountID As String, Optional NoCommaSubCode As String, Optional SubAccountName As String, Optional SubAccountDirect As String) As Boolean
   Dim strSql As String
   Dim rstAccount As rdoResultset
   
   strSql = "Select blnIsDetail,strAccountCode,strAccountName,strAccountCode,intDirection,lngAccountId,strFullName From Account Where lngAccountId=" & AccountID
   Set rstAccount = mvarBaseDB.OpenResultset(strSql, rdOpenStatic)
   With rstAccount
      If Not .EOF Then
         AccountIsDetail = !blnIsDetail
         If GetSub And Not AccountIsDetail Then
            GetSubAccount AccountID, , SubAccountID, NoCommaSubCode, SubAccountName, SubAccountDirect
         Else
            SubAccountID = !lngAccountID
            SubAccountName = Trim(!strFullName)
            SubAccountDirect = Trim(str(!intDirection))
            NoCommaSubCode = Trim(!strAccountCode)
         End If
      End If
   End With
End Function

'取科目方向
Public Function AccountDirect(ByVal AccountID As Long) As Integer
  Dim strSql As String
  Dim rstAccount As rdoResultset
  strSql = "Select intDirection From Account Where Account.lngAccountId=" & AccountID
  Set rstAccount = mvarBaseDB.OpenResultset(strSql, rdOpenStatic)
  With rstAccount
     If Not .EOF Then
        AccountDirect = !intDirection
     End If
  End With
End Function

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'取下级科目
'参数说明：
'AccountId   :科目ID
'AccountCode :科目编码
'SubAccountId:返回下级科目ID,如:"1,2,3,4"
'NoCommaSubCode:返回不带单引号的科目编码,如:"10901 10902 10903 10904"
'返回:返回带单引号的科目编码,如:"'10901','10902','10903','10904'"
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function GetSubAccount(Optional ByVal AccountID As Long, Optional AccountCode As String = "", Optional SubAccountID As String, Optional NoCommaSubCode As String, Optional SubAccountName As String, Optional SubAccountDirect As String) As String
   Dim strSql As String
   Dim rstAccount As rdoResultset
   
   If AccountCode = "" Then
        strSql = "Select strAccountCode From Account Where lngAccountId=" & AccountID
        Set rstAccount = mvarBaseDB.OpenResultset(strSql, rdOpenStatic)
        If Not rstAccount.EOF Then
           AccountCode = Trim(rstAccount!strAccountCode)
        Else
           Exit Function
        End If
   End If
   
   strSql = "Select lngAccountId,strAccountCode,strFullName,intDirection From Account Where strAccountcode LIKE '" & AccountCode & "-%'"
   Set rstAccount = mvarBaseDB.OpenResultset(strSql, rdOpenStatic)
   With rstAccount
        If Not .EOF Then
            Do While Not .EOF
                If SubAccountID = "" Then
                    SubAccountID = !lngAccountID
                    GetSubAccount = "'" & Trim(!strAccountCode) & "'"
                    NoCommaSubCode = Trim(!strAccountCode)
                    SubAccountName = Trim(!strFullName)
                    SubAccountDirect = Trim(str(!intDirection))
                Else
                    SubAccountID = SubAccountID & "," & !lngAccountID
                    GetSubAccount = GetSubAccount & ",'" & Trim(!strAccountCode) & "'"
                    NoCommaSubCode = NoCommaSubCode & " " & Trim(!strAccountCode)
                    SubAccountName = SubAccountName & " " & Trim(!strFullName)
                    SubAccountDirect = SubAccountDirect & " " & Trim(str(!intDirection))
                End If
                .MoveNext
            Loop
        End If
   End With
End Function
Private Function GetBaseStartAndEndDate(sDate As Date, eDate As Date) As Boolean
    Dim strSql As String
    Dim recTmp As rdoResultset
    
    GetBaseStartAndEndDate = True
    strSql = "select * from AccountPeriod ORDER BY intYear,bytPeriod ASC"
    
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    
    If recTmp Is Nothing Then
        sDate = gclsBase.BaseDate
        eDate = gclsBase.BaseDate
        GetBaseStartAndEndDate = False
        Exit Function
    End If
    If recTmp.BOF And recTmp.EOF Then
        sDate = gclsBase.BaseDate
        eDate = gclsBase.BaseDate
        GetBaseStartAndEndDate = False
        recTmp.Close
        Set recTmp = Nothing
        Exit Function
    End If
    recTmp.MoveFirst
    sDate = recTmp!strStartDate
    recTmp.MoveLast
    eDate = recTmp!strEndDate
    recTmp.Close
    Set recTmp = Nothing
End Function

'判断期间是否已结帐
Public Function PeriodIsClosed(ByVal intYear As Integer, ByVal bytPeriod As Byte, Optional IsMonth As Boolean = False) As Boolean
  Dim strBegin As String, strEnd As String
  Dim strKey As String
  
    On Error GoTo ErrHandle
    strKey = intYear & Format(bytPeriod, "00")
    
    IsMonth = False
    
    If mcolPeriodClose.Item(strKey) <> "0" Then
       PeriodIsClosed = True
    Else
       PeriodIsClosed = False
    End If
    If bytPeriod <= 12 Then
        strBegin = intYear & "-" & Format(bytPeriod, "00") & "-01"
        strEnd = DateAdd("M", 1, CDate(strBegin))
        strEnd = Format(DateAdd("D", -1, CDate(strEnd)), "yyyy-mm-dd")
        If strBegin = mcolPeriodBegin.Item(strKey) And strEnd = mcolPeriodEnd.Item(strKey) Then
           IsMonth = True
        End If
    End If
    Exit Function
ErrHandle:
End Function

'判断日期所在期间是否已结帐，已结帐为 TRUE
'1  在开始日期之外
'2  在结束日期之外
'0  OK
'-1 已结帐
Public Function PeriodClosed(ByVal strDate As String) As Integer
Dim strSql As String
Dim recTmp As rdoResultset
Dim dStartDate As Date
Dim dEndDate As Date

On Error Resume Next
    strDate = Format(strDate, "yyyy-MM-dd")
    PeriodClosed = 0
    If Not IsDate(strDate) Then
        '非日期格式视为未结帐
        PeriodClosed = 0
        Exit Function
    End If
    
    If GetBaseStartAndEndDate(dStartDate, dEndDate) = False Then
        PeriodClosed = 0
        Exit Function
    End If
    If CDate(strDate) < dStartDate Then
        PeriodClosed = 1
        Exit Function
    ElseIf CDate(strDate) > dEndDate Then
        PeriodClosed = 2
        Exit Function
    End If
        
    If Format(mvarBeginDate, "yyyy-MM-dd") > strDate Then
        '小于帐套启用日期视为已结帐
        PeriodClosed = -1
        recTmp.Close
        Set recTmp = Nothing
        Exit Function
    End If
    
    strSql = "Select * from AccountPeriod Where strStartDate <='" _
             & strDate & "' and strEndDate >='" & strDate & "'  AND lngCloseID>0"

    Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If recTmp Is Nothing Then
        Exit Function
    End If
    If Not recTmp.EOF Then
        If recTmp!lngCloseID > 0 Then
            PeriodClosed = -1
        End If
    End If
    recTmp.Close
    Set recTmp = Nothing
End Function

Public Function GetCurrencyID(Optional ByVal CurName As String = "", Optional ByVal CurCode As String = "") As Long
   Dim rstCurrency As rdoResultset
   Dim strSql As String
   
     If CurName <> "" Then
         strSql = "Select lngCurrencyId From Currencys Where strCurrencyName='" & CurName & "'"
     End If
     If CurCode <> "" Then
         strSql = "Select lngCurrencyId From Currencys Where strCurrencyCode='" & CurCode & "'"
     End If
     If strSql <> "" Then
         Set rstCurrency = mvarBaseDB.OpenResultset(strSql, rdOpenStatic)
         With rstCurrency
             If Not .EOF Then
                 GetCurrencyID = !lngCurrencyID
             End If
         End With
     End If
End Function

'取视图字段名称
Public Function GetViewFiledName(ByVal ViewId As Long, FieldDesc As String) As String
  Dim rstViewField As rdoResultset
  Dim strSql As String
    
    strSql = "Select strFieldName From ViewField Where strViewFieldDesc='" & FieldDesc & "'"
    Set rstViewField = mvarBaseDB.OpenResultset(strSql, rdOpenStatic)
    With rstViewField
       If Not .EOF Then
           GetViewFiledName = !strFieldName
       End If
    End With
End Function

'科目是否有数量核算
Public Function ItemOfAccount(AcntID As Long) As Boolean
   Dim strSql As String
   Dim rstAccount As rdoResultset
      ItemOfAccount = False
      strSql = "Select blnIsQuantity From Account Where lngAccountID=" & AcntID
      Set rstAccount = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
      With rstAccount
         If Not .EOF Then
            ItemOfAccount = !blnIsQuantity
         End If
      End With
      Set rstAccount = Nothing
End Function

Public Function FirstDayOfYear(ByVal strDate As String) As String
  Dim strSql As String
  Dim rstPeriod As rdoResultset, rstPeriod1 As rdoResultset

    strSql = "Select * From AccountPeriod Where strStartDate<='" & Format$(strDate, "yyyy-mm-dd") & "' And strEndDate>='" & Format$(strDate, "yyyy-mm-dd") & "'"
    Set rstPeriod = BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not rstPeriod.EOF Then
        strSql = "Select * From AccountPeriod Where intYear=" & rstPeriod!intYear & " Order By intYear,bytPeriod"
        Set rstPeriod1 = BaseDB.OpenResultset(strSql, rdOpenStatic)
        If Not rstPeriod1.EOF Then
            FirstDayOfYear = Format(rstPeriod1!strStartDate, "yyyy-mm-dd")
        End If
    End If
End Function
Private Sub KillSession()

    Dim strSql As String
    Dim rec As rdoResultset
    Dim strSID As String
strSql = "SELECT  SID ID ,SERIAL# SE FROM v$Session WHERE  " _
& "USERNAME=" & mUID & " AND UPPER(OSUSER) = 'TJY' AND UPPER(MACHINE)" _
& "= 'TJY' AND UPPER(PROGRAM) = 'VB6.EXE'"
    Set rec = BaseDB.OpenResultset(strSql, rdOpenStatic)
    With rec
        .MoveFirst
        Do While Not .EOF
            strSID = "'" & rec!ID & "," & rec!SE & "'"
            .MoveNext
            If Not .EOF Then
                strSql = "ALTER system kill session " & strSID
                BaseDB.Execute strSql
            End If
        Loop
    End With

End Sub

Private Sub Class_Initialize()
  Dim strPath As String, strDefault As String
  Dim strVersionType As String
  Dim lngSize As Long, lngTmp As Long
  Dim strByteKey As String, strByteName As String
  Dim strININame As String
  
    #If conWan <> 1 Then
        strByteName = "金算盘软件"
    #Else
        strByteName = "万能软件"
    #End If
  
    If Right(App.Path, 2) = ":\" Then
        strPath = StringOut(App.Path, "\")
    Else
        strPath = App.Path
    End If
        
    strDefault = "0"
    strVersionType = Space(255)
    lngSize = Len(strVersionType)
    strByteKey = "Teach"
    strININame = strPath & "\Account.ini"
    
    lngTmp = GetPrivateProfileString(strByteName, strByteKey, strDefault, strVersionType, lngSize, strININame)
    strVersionType = Left(strVersionType, lngTmp)
    If IsNumeric(strVersionType) Then
        mbytVersionType = Val(strVersionType)
    Else
        mbytVersionType = 0
    End If
End Sub

Private Sub Class_Terminate()
   Set mcolPeriodClose = Nothing
   Set mcolPeriodBegin = Nothing
   Set mcolPeriodEnd = Nothing
   Set mcolCurrencyDec = Nothing
   Set mcolRateDec = Nothing
   Set mcolYear = Nothing
   Set mcolPeriod = Nothing
End Sub