utility.bas

金算盘软件代码

Attribute VB_Name = "Utility"
 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'  公用代码
'  作者：黄涛
'  日期：1998.02.21
'
'  LoadMRU              从系统注册表中加载最近打开文件到mnuFileMenu数组
'  SaveMRU              把mnuFileMenu数组中最近打开文件存储到系统注册表
'  UpdateMRU            根据打开文件strFileName，调整MRU
'
'  LoadFormSetting      从系统注册表中加载窗体位置、大小
'  SaveFormSetting      把窗体位置、大小存储到系统注册表中。
'
'  LoadFormResPicture   加载窗体内控件的图片资源
'  UnLoadFormResPicture 卸载窗体内控件的图片资源
'
'  GetFormResPicture    得到窗体内控件的图片资源
'  RemoveFormResPicture 删除窗体内控件的图片资源
'
'  GetListRecordSet     得到列表的记录集资源
'  RemoveListRecordSet  删除列表的记录集资源
'  ClearListRecordSet   清除列表的记录集资源
'  ListRecordSetType    列表的记录集资源类型(枚举)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Option Explicit
Public Const OPAQUE = 2
Public Enum ListRecordSetType                             '带'*'表示局部记录集资源
     lrtCustomer = 1             '单位
     lrtDepartment               '部门
     lrtEmployee                 '职员
     lrtClass1                   '统计
     lrtCurrencys                '全币种                  *
     lrtTerm                     '付款条件
     lrtAccount                  '科目
     lrtItem                     '商品
     lrtJob                      '工程表
     lrtPosition                 '货位
     
     lrtRemark                   '摘要
     lrtCustom1                  '自定义项目1
     lrtCustom2                  '自定义项目2
     lrtCustom3                  '自定义项目3
     lrtCustom4                  '自定义项目4
     lrtCustom5                  '自定义项目5
     lrtClass2                   '项目
     lrtRate                     '汇率                    *
     lrtVoucherType              '凭证类型
     lrtCustom0                  '自定义项目0
     
     lrtTemplate                 '单据模板                *
     lrtAccountType              '科目类型                *
     lrtInvRecAccount            '应收/应付科目           *
     lrtCustomerAddress          '单位发货地址            *
     lrtCustomerBank             '单位开户银行            *
     lrtBusinessAddress          '企业地址
     lrtBusinessBank             '企业开户银行
     lrtItemUnit                 '商品单位                *
     lrtTax                      '税率                    *
     lrtTransVoucher             '转帐凭证                *
     
     lrtPaymentMethod            '付款方式                *

End Enum
Declare Function SetWindowContextHelpId Lib "user32" (ByVal hwnd As Long, ByVal dw As Long) As Long
Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Public Declare Function ValidateRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Public Declare Function ValidateRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long) As Long
Public Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT, ByVal bErase As Long) As Long
Public Declare Function InvalidateRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bErase As Long) As Long
Public Declare Function UpdateWindow Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

'Declare Function UpdateColors Lib "gdi32" (ByVal hdc As Long) As Long
Private arrResPicture() As Object                '图片资源数组
Private arrResPictureID() As Long                '图片资源ID数组
Private arrResPictureCount() As Integer          '图片资源加载个数数组
Private arrResPictureType() As Integer           '图片资源类型

Private arrListRecSet() As rdoResultset             '列表的记录集资源数组
Private arrListRecSetType() As ListRecordSetType '列表的记录集资源类型数组
Private arrListRecSetCount() As Integer          '列表的记录集资源使用个数数组

'改变控件Tag属性
'参数：strTag 需要改变的Tag，strRep 替换的字符串，intSect 要替换的段号
Public Function ChangeTag(ByVal strTag As String, strRep As String, intSect As Integer, Optional strSep As String = "/", Optional SecondSep As String = "") As String
   Dim strTemp As String
   Dim intSepNum As Integer
   Dim strLeft As String
   Dim strRight As String
   Dim intCount As Integer
   
   If SecondSep = "" Then
        intSepNum = strCount(strTag, strSep) + 1
   Else
        intSepNum = strCount(strTag, SecondSep) + 2
   End If
   
   For intCount = 1 To intSect - 1
        If SecondSep = "" Then
            If strLeft = "" Then
               strLeft = GetNoXString(strTag, intCount, strSep)
            Else
               strLeft = strLeft & strSep & GetNoXString(strTag, intCount, strSep)
            End If
        Else
            If intCount = 1 Then
               strLeft = GetNoXString(strTag, intCount, strSep)
            Else
               If strLeft = "" Then
                   strLeft = GetNoXString(GetNoXString(strTag, 2, strSep), intCount - 1, SecondSep)
               Else
                   strLeft = strLeft & IIf(intCount < 3, strSep, SecondSep) & GetNoXString(GetNoXString(strTag, 2, strSep), intCount - 1, SecondSep)
               End If
            End If
        End If
   Next intCount
   
   For intCount = intSect + 1 To intSepNum
        If SecondSep = "" Then
            If strRight = "" Then
               strRight = GetNoXString(strTag, intCount, strSep)
            Else
               strRight = strRight & strSep & GetNoXString(strTag, intCount, strSep)
            End If
        Else
            If intCount = 1 Then
               strRight = GetNoXString(strTag, intCount, strSep)
            Else
               If strRight = "" Then
                   strRight = GetNoXString(GetNoXString(strTag, 2, strSep), intCount - 1, SecondSep)
               Else
                   strRight = strRight & IIf(intCount < 3, strSep, SecondSep) & GetNoXString(GetNoXString(strTag, 2, strSep), intCount - 1, SecondSep)
               End If
            End If
        End If
   Next intCount
   
   If SecondSep = "" Then
        If strLeft = "" Then
            ChangeTag = strRep & strSep & strRight
        Else
            ChangeTag = strLeft & strSep & strRep & strSep & strRight
        End If
   Else
        If intSect <= 2 Then
            If strLeft = "" Then
                ChangeTag = strRep & strSep & strRight
            Else
                ChangeTag = strLeft & strSep & strRep & strSep & strRight
            End If
        Else
            If strLeft = "" Then
                ChangeTag = strRep & SecondSep & strRight
            Else
                ChangeTag = strLeft & SecondSep & strRep & SecondSep & strRight
            End If
        End If
   End If
End Function

'取栏目宽度
Public Function GetDisplayWidth(ByVal strCaption As String, intLenth As Integer) As Long
   On Error GoTo ErrHandle
   GetDisplayWidth = frmMain.ActiveForm.TextWidth("A") * ((IIf(StrLen(strCaption) > intLenth, StrLen(strCaption), intLenth)) + 1)
   Exit Function
ErrHandle:
   GetDisplayWidth = 90 * (IIf(StrLen(strCaption) > intLenth, StrLen(strCaption), intLenth))
End Function

'取小数位数对应的格式化字符串
Public Function GetFormatString(ByVal intDec As Integer, Optional IsShowSep As Boolean = True) As String
    Dim intI As Integer
    If intDec = 0 Then
        If IsShowSep Then
           GetFormatString = "###,###,###,###,##0"
        Else
           GetFormatString = "#0"
        End If
        Exit Function
    End If
    If IsShowSep Then
       GetFormatString = "###,###,###,###,##0."
    Else
       GetFormatString = "#0."
    End If
    For intI = 1 To intDec
        GetFormatString = GetFormatString + "0"
    Next intI
End Function

'取出用分隔符分隔的字符串中第X个子串（第intSect段）
Public Function GetNoXString(Optional ByVal strSource As String = "", Optional ByVal intSect As Integer = 1, Optional strSeprater As String = " ") As String
 Dim strTemp As String
 Dim intCount As Integer
   GetNoXString = ""
   For intCount = 1 To intSect
       If Trim(strSource) = "" Then
          GetNoXString = ""
          Exit For
       End If
       GetNoXString = Trim(StringOut(strSource, strSeprater))
   Next intCount
End Function

'从系统注册表中加载最近打开文件到mnuFileMenu数组。
Public Sub LoadMRU()
    Dim intCnt As Integer
    Dim strProduceName As String
    
    strProduceName = App.title
    For intCnt = 0 To 3
        With frmMain.mnuFileMRU(intCnt)
            .Caption = GetSetting(strProduceName, "ORAMRU", "File" & intCnt, "")
            If .Caption <> "" Then
                .Visible = True
                .Caption = "&" & (intCnt + 1) & " " & .Caption
            Else
                .Visible = False
            End If
        End With
    Next
        
    frmMain.mnuFileMRUBar.Visible = frmMain.mnuFileMRU(0).Visible
End Sub

'把mnuFileMenu数组中最近打开文件存储到系统注册表。
Public Sub SaveMRU()
    Dim intCnt As Integer
    Dim strProduceName As String
    
    strProduceName = App.title
    For intCnt = 0 To 3
        With frmMain.mnuFileMRU(intCnt)
            SaveSetting strProduceName, "ORAMRU", "File" & intCnt, IIf(.Visible, Mid(.Caption, 4), "")
        End With
    Next
End Sub

'根据打开文件strFileName，调整MRU
Public Sub UpdateMRU(StrFileName As String, Optional strErrFile As String = "")
    Dim intCnt As Integer, intFound As Integer
    Dim strProduceName As String
    Dim strTempName As String
    
    ' 从mnuFileMRU中查找strFileName
    intFound = 3
    For intCnt = 0 To 2
        With frmMain.mnuFileMRU(intCnt)
            If .Visible Then
                If UCase(Mid(.Caption, 4)) = UCase(StrFileName) Then
                    intFound = intCnt
                    Exit For
                End If
            End If
        End With
    Next
    
    strProduceName = App.title
    With frmMain
        For intCnt = intFound To 1 Step -1
            .mnuFileMRU(intCnt).Caption = "&" & intCnt + 1 & " " & Mid(.mnuFileMRU(intCnt - 1).Caption, 4)
            .mnuFileMRU(intCnt).Visible = .mnuFileMRU(intCnt - 1).Visible
        Next
        
        With .mnuFileMRU(0)
            If StrFileName <> "" Then
                .Caption = "&1 " & StrFileName
                .Visible = True
            Else
                If strErrFile <> "" Then
                    intFound = 0
                    For intCnt = 1 To 3
                        If Mid(frmMain.mnuFileMRU(intCnt).Caption, 4) <> strErrFile Then
                            frmMain.mnuFileMRU(intFound).Caption = "&" & intFound + 1 & " " & Mid(frmMain.mnuFileMRU(intCnt).Caption, 4)
                            frmMain.mnuFileMRU(intFound).Visible = frmMain.mnuFileMRU(intCnt).Visible
                            intFound = intFound + 1
                        End If
                    Next
                    For intCnt = intFound To 3
                        frmMain.mnuFileMRU(intCnt).Visible = False
                    Next intCnt
                End If
            End If
        End With
        .mnuFileMRUBar.Visible = frmMain.mnuFileMRU(0).Visible
    End With
    
    SaveMRU
End Sub


'从系统注册表中加载窗体位置、大小。
Public Sub LoadFormSetting(frmForm As Form)
    Dim strTitle As String, strFormName As String
    Dim intState As Integer
    
    On Error Resume Next
    strTitle = App.title
    strFormName = frmForm.Name
    With frmForm
      intState = GetSetting(strTitle, strFormName, "State", vbNormal)
      If intState <> vbNormal Then
         If intState = vbMinimized Then
           .WindowState = vbMaximized
         Else
           .WindowState = intState
         End If
      Else
        .Move GetSetting(strTitle, strFormName, "Left", .Left), GetSetting(strTitle, strFormName, "Top", .top) _
              , GetSetting(strTitle, strFormName, "Width", .width), GetSetting(strTitle, strFormName, "Height", .Height)
      End If
      If ((.Left + .width) < 0 Or .Left > Screen.width) Then
           .Left = 300
      End If
    End With
End Sub

'把窗体位置、大小存储到系统注册表中。
Public Sub SaveFormSetting(frmForm As Form)
    Dim strTitle As String, strFormName As String
    
    strTitle = App.title
    strFormName = frmForm.Name
    With frmForm
      SaveSetting strTitle, strFormName, "State", .WindowState
      'If Not .WindowState = vbMaximized Then
      If .WindowState = vbNormal Then
        SaveSetting strTitle, strFormName, "Left", .Left
        SaveSetting strTitle, strFormName, "Top", .top
        SaveSetting strTitle, strFormName, "Width", .width
        SaveSetting strTitle, strFormName, "Height", .Height
      End If
    End With
End Sub


'
'资源管理
'

'加载窗体内控件的图片资源
Public Sub LoadFormResPicture(ByVal frmForm As Form)
    Dim ctlControl As Control
    Dim strControlType As String
    Dim strResID As String
    
    On Error GoTo Error_Handle
    
    Set frmForm.Icon = GetFormResPicture(139, vbResIcon)
    For Each ctlControl In frmForm.Controls
        strControlType = TypeName(ctlControl)
        strResID = ctlControl.Tag
        
        If strResID > "0" And strResID < "32767" And UCase(strControlType) <> UCase("ListText") Then
            If strResID > "1000" And strResID < "2000" Then
                Set ctlControl.Picture = GetFormResPicture(CLng(strResID), vbResBitmap)
            ElseIf strResID > "2000" And strResID < "3000" Then
                Select Case strControlType
                Case ""
                Case Else
                     Set ctlControl.MouseIcon = GetFormResPicture(CLng(strResID), vbResCursor)
                End Select
            Else
                Select Case strControlType
                Case "CommandButton"
                    Set ctlControl.Picture = GetFormResPicture(CInt(strResID), vbResBitmap)
                Case "MSFlexGrid"