utility.bas

金算盘软件代码

'寻找记录集资源位置,并返回位置(-1表示没找到)
Private Function FindRecLoc(ByVal lrtType As ListRecordSetType) As Integer
Dim intCount As Integer
Dim blnIsFinded As Boolean
    '资源数组为空，返回-1
    If ArrIsEmpty(arrListRecSetType) Then FindRecLoc = -1: Exit Function
    '资源数组不为空，根据枚举类型查找
    For intCount = 0 To UBound(arrListRecSetType)
        If arrListRecSetType(intCount) = lrtType Then
            blnIsFinded = True
            Exit For
        End If
    Next intCount
    If blnIsFinded Then
         '找到了，返回位置
         FindRecLoc = intCount
    Else
         '没找到，返回-1
         FindRecLoc = -1
    End If
End Function
    
'得到列表的记录集资源
Public Function GetListRecordSet(ByVal lrtType As ListRecordSetType) As rdoResultset
    Dim intCount As Integer, intLoc As Integer
    Dim blnIsFinded As Boolean, blnIsEmpty As Boolean
    
    '不是全局记录集资源，退出过程
    Select Case lrtType
    Case 1, 2, 3, 4, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 19, 20, 26, 27, 31
    Case Else
         Exit Function
    End Select
    blnIsFinded = False
    '第一次调用时，对数组初始化
    If ArrIsEmpty(arrListRecSetType) Then
        ReDim arrListRecSet(0)
        ReDim arrListRecSetType(0)
        ReDim arrListRecSetCount(0)
        '装载记录集到数组
        Set arrListRecSet(0) = LoadResRecordSet(lrtType)
        arrListRecSetType(0) = lrtType
        arrListRecSetCount(0) = 1
        
        'TempCode:执行提交操作后，打开的结果集无效
        arrListRecSet(0).Requery
        
        '过程返回记录集
        Set GetListRecordSet = arrListRecSet(0)
        Exit Function
    End If
    
    '根据记录集资源类型寻找记录集资源
    For intCount = 0 To UBound(arrListRecSetType)
        If arrListRecSetType(intCount) = lrtType Then
            blnIsFinded = True
            Exit For
        End If
    Next intCount
    
    If blnIsFinded Then
        '找到了记录集资源，计数器加1，过程返回记录集
        arrListRecSetCount(intCount) = arrListRecSetCount(intCount) + 1
        arrListRecSet(intCount).Requery
        Set GetListRecordSet = arrListRecSet(intCount)
     Else
        '寻找空缺位置
        For intLoc = 0 To UBound(arrListRecSetType)
            If arrListRecSetType(intLoc) = -1 Then
                blnIsEmpty = True
                Exit For
            End If
        Next intLoc
        
        If Not blnIsEmpty Then
            '没有空位了，增加数组维数
            intLoc = UBound(arrListRecSetType) + 1
            ReDim Preserve arrListRecSet(intLoc)
            ReDim Preserve arrListRecSetType(intLoc)
            ReDim Preserve arrListRecSetCount(intLoc)
        End If
        '装载资源，计数器为1，过程返回记录集
        Set arrListRecSet(intLoc) = LoadResRecordSet(lrtType)
        arrListRecSetType(intLoc) = lrtType
        arrListRecSetCount(intLoc) = 1
        arrListRecSet(intLoc).Requery
        Set GetListRecordSet = arrListRecSet(intLoc)
    End If
End Function

'删除列表的记录集资源
Public Sub RemoveListRecordSet(ByVal lrtType As Long)
    Dim intCount As Integer
    Dim blnIsFinded As Boolean
    If lrtType < 1 And lrtType > 19 Then Exit Sub
    blnIsFinded = False
    '寻找资源类型
    If ArrIsEmpty(arrListRecSetType) Then Exit Sub
    For intCount = 0 To UBound(arrListRecSetType)
        If arrListRecSetType(intCount) = lrtType Then
            blnIsFinded = True
            Exit For
        End If
    Next intCount
    
    If blnIsFinded Then
        '找到了资源，计数器减1
        arrListRecSetCount(intCount) = arrListRecSetCount(intCount) - 1
        '若计数器为0，卸载资源
        If arrListRecSetCount(intCount) = 0 Then
            arrListRecSetType(intCount) = -1
            Set arrListRecSet(intCount) = Nothing
        End If
    Else      '没找到资源
    End If
End Sub
'清除列表的记录集资源
Public Sub ClearListRecordSet()
    ReDim arrListRecSet(0)
    ReDim arrListRecSetCount(0)
    ReDim arrListRecSetType(0)
    arrListRecSetType(0) = -1
End Sub

'加载列表的记录集资源
Private Function LoadResRecordSet(lrtType As ListRecordSetType) As rdoResultset
 Dim strSql As String
 Dim recCurrency As rdoResultset
 
    Select Case lrtType
    Case ListRecordSetType.lrtCustomer          '单位
        strSql = "SELECT lngCustomerID, strCustomerCode, strCustomerName " _
             & "From Customer WHERE blnIsInActive=0 AND strCustomerCode<>' ' ORDER BY strCustomerCode ASC"
    Case ListRecordSetType.lrtDepartment        '部门
        strSql = "SELECT lngDepartmentID, strDepartmentCode, strDepartmentName " _
            & "From Department WHERE blnIsInActive=0 AND strDepartmentCode<>' ' ORDER BY strDepartmentCode ASC"
    Case ListRecordSetType.lrtEmployee           '职员
        strSql = "SELECT lngEmployeeID,strEmployeeCode,strEmployeeName " _
                & " FROM Employee WHERE blnIsInActive=0 AND strEmployeeCode<>' ' ORDER BY strEmployeeCode ASC"
    Case ListRecordSetType.lrtClass1             '统计
        strSql = "SELECT lngClassID, strClassCode, strClassName " _
            & "From Class1 WHERE blnIsInActive=0 AND strClassCode<>' ' ORDER BY strClassCode ASC"
    Case ListRecordSetType.lrtTerm                '付款条件
        strSql = "SELECT lngTermID, strTermCode, strTermName " _
             & "From Term WHERE blnIsInActive=0 AND strTermCode<>' ' ORDER BY strTermCode ASC"
    
    Case ListRecordSetType.lrtAccount             '科目
        strSql = "SELECT lngAccountID, strAccountCode, strAccountName " _
             & "From Account WHERE blnIsInActive=0 AND strAccountCode<>' ' ORDER BY strAccountCode ASC"
    Case ListRecordSetType.lrtItem                '商品
        strSql = "SELECT lngItemID, strItemCode, strItemName,strItemStyle " _
                 & "From Item WHERE blnIsInActive=0 AND strItemCode<>' ' ORDER BY strItemCode ASC"
    Case ListRecordSetType.lrtJob                 '工程表
        strSql = "SELECT lngJobID, strJobCode, strJobName " _
             & "From Job WHERE blnIsInActive=0 AND strJobCode<>' ' ORDER BY strJobCode ASC"
    Case ListRecordSetType.lrtPosition            '货位
        strSql = "SELECT lngPositionID, strPositionCode, strPositionName " _
             & "From Position WHERE blnIsInActive=0 AND strPositionCode<>' ' ORDER BY strPositionCode ASC"
    Case ListRecordSetType.lrtRemark              '摘要
        strSql = "SELECT lngRemarkID,strRemarkCode, strRemarkName  " _
             & "From Remark ORDER BY strRemarkCode ASC"
    
    Case ListRecordSetType.lrtCustom1             '自定义项目1
        strSql = "SELECT lngCustomID, strCustomCode, strCustomName " _
             & "From Custom1 WHERE blnIsInActive=0 AND strCustomCode<>' ' ORDER BY strCustomCode ASC"
    Case ListRecordSetType.lrtCustom2             '自定义项目2
        strSql = "SELECT lngCustomID, strCustomCode, strCustomName " _
             & "From Custom2 WHERE blnIsInActive=0 AND strCustomCode<>' '  ORDER BY strCustomCode ASC"
    Case ListRecordSetType.lrtCustom3             '自定义项目3
        strSql = "SELECT lngCustomID, strCustomCode, strCustomName " _
             & "From Custom3 WHERE blnIsInActive=0 AND strCustomCode<>' '  ORDER BY strCustomCode ASC"
    Case ListRecordSetType.lrtCustom4             '自定义项目4
        strSql = "SELECT lngCustomID, strCustomCode, strCustomName " _
             & "From Custom4 WHERE blnIsInActive=0 AND strCustomCode<>' '  ORDER BY strCustomCode ASC"
    Case ListRecordSetType.lrtCustom5             '自定义项目5
        strSql = "SELECT lngCustomID, strCustomCode, strCustomName " _
             & "From Custom5 WHERE blnIsInActive=0 AND strCustomCode<>' '  ORDER BY strCustomCode ASC"
    
    Case ListRecordSetType.lrtClass2              '项目
        strSql = "SELECT lngClassID, strClassCode, strClassName " _
             & "From Class2 WHERE blnIsInActive=0 AND strClassCode<>' ' ORDER BY strClassCode ASC"
    Case lrtVoucherType                           '凭证类型
        strSql = "SELECT lngVoucherTypeID, strVoucherTypeCode, strVoucherTypeName " _
             & "From VoucherType WHERE blnIsInActive=0 AND strVoucherTypeCode<>' ' ORDER BY strVoucherTypeCode ASC"
    Case ListRecordSetType.lrtCustom0             '自定义项目0
        strSql = "SELECT lngCustomID, strCustomCode, strCustomName " _
             & "From Custom0 WHERE blnIsInActive=0 AND strCustomCode<>' '  ORDER BY strCustomCode ASC"
    Case ListRecordSetType.lrtInvRecAccount       '应收/应付科目
        strSql = "SELECT lngAccountID,strAccountCode,strAccountName " _
             & "FROM Account " _
             & "WHERE (lngAccountNatureID = 3 OR lngAccountNatureID = 4) AND blnIsInActive=0 ORDER BY strAccountCode ASC"
    Case ListRecordSetType.lrtBusinessAddress     '企业地址
        strSql = "SELECT lngBusinessAddressID,strBusinessAddressCode,strBusinessAddressName " _
             & "FROM BusinessAddress ORDER BY strBusinessAddressCode ASC"
    
    Case ListRecordSetType.lrtBusinessBank        '企业开户银行
        strSql = "SELECT lngBusinessBankID,strBankName,strAccountNO " _
             & "FROM BusinessBank ORDER BY lngBusinessBankID,strBankName"
    Case lrtPaymentMethod                         '付款方式
        strSql = "SELECT lngPaymentmethodID, strPaymentmethodCode, strPaymentmethodName " _
             & "From PaymentMethod WHERE blnIsInActive=0 AND strPaymentmethodCode<>' ' ORDER BY strPaymentmethodCode ASC"
    End Select
    '若SQL语句有效，打开并返回记录集资源
    If strSql <> "" Then Set LoadResRecordSet = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
End Function

Public Function ArrIsEmpty(ByVal TestArray As Variant) As Boolean
    Dim x As Integer
    On Error GoTo ErrHandle
    '设置错误陷阱
    x = UBound(TestArray)
    ArrIsEmpty = False
    Exit Function
ErrHandle:
    ArrIsEmpty = True
End Function
'帮助文件
Public Sub SetHelpID(ByVal HelpID As Long)
    Dim strPage As String
    Dim strBuffer As String * 128
    Dim strURL As String
    Dim ret As Long
    strPage = GetHelpHtml(HelpID)
    ret = GetWindowsDirectory(strBuffer, 128)
    If strPage <> "" Then
        strURL = "mk:@MSITStore:" & Left(strBuffer, ret) & "\HELP\" & "Ac98Nav.chm" & "::/" & strPage
    Else
        strURL = "mk:@MSITStore:" & Left(strBuffer, ret) & "\HELP\" & "Ac98Nav.chm" & "::/bzml01.htm"
    End If
    
    frmMain.ShowDeskTopHelp strURL
End Sub
Public Sub DrawACashLine(ByVal hdc As Long, ByVal lngLeftPos As Long, ByVal lngTop As Long, ByVal lngRightPos As Long, ByVal lngButton As Long, _
                        Optional ByVal cL As Long = -1, _
                       Optional ByVal cT As Long = -1, _
                       Optional ByVal cR As Long = -1, _
                       Optional ByVal cB As Long = -1)
    Dim x1 As Long, x2 As Long, y1 As Long, y2 As Long
    Dim i As Long, j As Long, lngWidth As Long
    lngWidth = 8 * Screen.TwipsPerPixelY
    If lngTop >= lngButton Then Exit Sub
    If lngRightPos < lngLeftPos + lngWidth Then Exit Sub
    
    y1 = lngTop
    y2 = lngButton
 
    i = 1
    j = 2 'gclsBase.NaturalCurDec
    Do While lngRightPos - lngWidth * i > lngLeftPos + 0 * Screen.TwipsPerPixelY
        x1 = lngRightPos - lngWidth * i - Screen.TwipsPerPixelY
        If i = j Then '小数点分隔线
            If cL = -1 And cT = -1 And cR = -1 And cB = -1 Then
                DrawBLine hdc, x1, y1, x1, y2, RGB(255, 0, 0)
            Else
                DrawALine hdc, x1, y1, x1, y2, cL, cT, cR, cB, RGB(255, 0, 0)
            End If
        ElseIf ((i - j) \ 3) * 3 = i - j Then '千分隔线
            If cL = -1 And cT = -1 And cR = -1 And cB = -1 Then
                DrawBLine hdc, x1, y1, x1, y2, RGB(0, 128, 0)
            Else
                DrawALine hdc, x1, y1, x1, y2, cL, cT, cR, cB, RGB(0, 128, 0)
            End If
        Else '一般分隔线
            If cL = -1 And cT = -1 And cR = -1 And cB = -1 Then
                DrawBLine hdc, x1, y1, x1, y2, RGB(192, 192, 192)
            Else
                DrawALine hdc, x1, y1, x1, y2, cL, cT, cR, cB, RGB(192, 192, 192)
            End If
        End If
        
        i = i + 1
    Loop
End Sub
Public Sub WriteACashAmount(ByVal hdc As Long, ByVal strCur As String, ByVal lngLeftPos As Long, ByVal lngTop As Long, ByVal lngRightPos As Long, _
            Optional ByVal blnIsNumber As Boolean = True, _
            Optional ByVal lngBkColor As Long = 16777215, _
            Optional ByVal blnBkTransparent As Boolean = False, Optional ByVal lngForeColor As Long = 0)
    Dim intJ As Integer
    Dim lngLeft As Long
    Dim lngLenth As Long
    Dim lngColor As Long
    Dim lngFontHeight As Long
    Dim lngPointPosition As Long
    Dim strTmp As String
    On Error Resume Next
    If blnIsNumber Then
        lngFontHeight = 12
        strCur = FilterString(strCur, ",")
        If InStr(strCur, "E") = 0 Then
            lngPointPosition = InStr(strCur, ".")
            If lngPointPosition > 0 Then
                strTmp = Mid(strCur, lngPointPosition + 1)
                If Len(strTmp) > gclsBase.NaturalCurDec Then
                    strTmp = Left(strTmp, gclsBase.NaturalCurDec)
                ElseIf Len(strTmp) < gclsBase.NaturalCurDec Then
                    strTmp = strTmp & "00000000000000000000000000000000000000000"
                    strTmp = Left(strTmp, gclsBase.NaturalCurDec)
                End If
                strCur = Left(strCur, lngPointPosition - 1) + strTmp
            Else
                strTmp = "000000000000000000000000000000000000000000000000000000000"
                strTmp = Left(strTmp, gclsBase.NaturalCurDec)
                strCur = strCur + strTmp
            End If
        End If
        If C2Dbl(strCur) = 0 Then strCur = Space(1)
        Do While Left(strCur, 1) = "0" And Len(strCur) > 3
             strCur = Mid(strCur, 2)
        Loop
        
        If Left(strCur, 1) = "-" Then
            lngColor = RGB(255, 0, 0)
            strCur = Mid(strCur, 2)
        Else
           lngColor = RGB(0, 0, 0)
        End If
        If strCur <> Space(1) Then
            Do While StrLen(strCur) < 3
                strCur = "0" & strCur
            Loop
        End If
        strCur = Space(30) + strCur
    Else
        lngFontHeight = -9
        lngColor = lngForeColor
    End If
    'blnBkTransparent = true
     
     For intJ = Len(strCur) To 1 Step -1
         lngLeft = lngRightPos - (Len(strCur) - intJ + 1) * 8 * Screen.TwipsPerPixelY
         If lngLeft < lngLeftPos Then Exit For
         WriteAString hdc, lngLeft, lngTop, Mid(strCur, intJ, 1), StrLen(Mid(strCur, intJ, 1)), lngColor, lngFontHeight, lngBkColor, blnBkTransparent
     Next intJ
End Sub
Public Function RefreshRect(ByVal hwnd As Long, cL As Long, cT As Long, cR As Long, cB As Long) As Long
    Dim RectClip As RECT
    RectClip.Left = cL \ Screen.TwipsPerPixelX
    RectClip.top = cT \ Screen.TwipsPerPixelY
    RectClip.Right = cR \ Screen.TwipsPerPixelX
    RectClip.Bottom = cB \ Screen.TwipsPerPixelY
    RefreshRect = InvalidateRect(hwnd, RectClip, True)
End Function
Public Function unRefreshRect(ByVal hwnd As Long, cL As Long, cT As Long, cR As Long, cB As Long) As Long
    Dim RectClip As RECT
    RectClip.Left = cL \ Screen.TwipsPerPixelX
    RectClip.top = cT \ Screen.TwipsPerPixelY
    RectClip.Right = cR \ Screen.TwipsPerPixelX
    RectClip.Bottom = cB \ Screen.TwipsPerPixelY
    unRefreshRect = ValidateRect(hwnd, RectClip)
End Function


'字符串strSource中包含strInclude的个数
Public Function StringCount2(ByVal strSource As String, ByVal strInclude As String) As Integer
   Dim intCount As Integer, i As Integer
   Dim strTemp As String
     For i = 1 To StrLen(strSource)
         strTemp = Mid(strSource, i, 1)
         If strTemp = strInclude Then
            intCount = intCount + 1
         End If
     Next i
     StringCount2 = intCount
End Function