utility.bas

金算盘软件代码

    End If
'画方框
    hPen = CreatePen(PS_SOLID, 1, lngColor)
    hSavePen = SelectObject(hdc, hPen)
    MoveToEx hdc, x1, y1, Point
    LineTo hdc, x1, y2
    LineTo hdc, x2, y2
    LineTo hdc, x2, y1
    LineTo hdc, x1, y1
    SelectObject hdc, hSavePen
    DeleteObject hPen
    
 '   ReleaseDC hwnd, hdc
End Sub
'画下拉按纽
Public Sub DrawAButton(ByVal hdc As Long, ByVal Left As Long, _
                       ByVal top As Long, _
                       Optional ByVal width As Long = 180, _
                       Optional ByVal Height As Long = 240, _
                       Optional ByVal Color As Long = 0, _
                       Optional ByVal BackColor As Long = 12632256, _
                       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 hdc As Long
    Dim hPen As Long, hSavePen As Long
    Dim hSolidPen As Long, hSaveSolidPen As Long
    Dim Point(6) As POINTAPI
    Dim xPoint As Integer
    Dim yPoint As Integer
    Dim x1 As Long, y1 As Long
    Dim blnDraw As Boolean

    If cL = -1 And cT = -1 And cR = -1 And cB = -1 Then
        blnDraw = True
    Else
        blnDraw = False
    End If
    
    width = width - Screen.TwipsPerPixelX
    top = top + 1 * Screen.TwipsPerPixelY
    Height = Height - 2 * Screen.TwipsPerPixelY
    
    xPoint = 6
    yPoint = 3
    'hdc = GetDC(hwnd)
    x1 = Left / Screen.TwipsPerPixelX
    y1 = top / Screen.TwipsPerPixelY
    width = width / Screen.TwipsPerPixelX
    Height = Height / Screen.TwipsPerPixelY
    
    If blnDraw = False Then
        If (x1 >= cL And x1 <= cR) Or (x1 + width >= cL And x1 + width <= cR) And _
           (y1 >= cT And y1 <= cB) Or (y1 + Height >= cT And y1 + Height <= cB) Then
                blnDraw = True
        End If
    End If
    If blnDraw = False Then
        Exit Sub
    End If
    
    '画外框
    Point(0).x = x1 + 0
    Point(0).y = y1 + 0
    Point(1).x = x1 + width
    Point(1).y = y1 + 0
    Point(2).x = x1 + width
    Point(2).y = y1 + Height
    Point(3).x = x1 + 0
    Point(3).y = y1 + Height
    hSolidPen = CreateSolidBrush(BackColor)
    hSaveSolidPen = SelectObject(hdc, hSolidPen)
    Polygon hdc, Point(0), 4
    SelectObject hdc, hSaveSolidPen
    DeleteObject hSolidPen
    
    '画线
    hPen = CreatePen(PS_SOLID, 1, BackColor)
    hSavePen = SelectObject(hdc, hPen)
    MoveToEx hdc, x1 + width - 1, y1, Point(0)
    LineTo hdc, x1, y1
    LineTo hdc, x1, y1 + Height
    SelectObject hdc, hSavePen
    DeleteObject hPen
    
    x1 = x1 + 1
    width = width - 2
    y1 = y1 + 1
    Height = Height - 2
    hPen = CreatePen(PS_SOLID, 1, RGB(225, 225, 225))
    hSavePen = SelectObject(hdc, hPen)
    MoveToEx hdc, x1 + width - 1, y1, Point(0)
    LineTo hdc, x1, y1
    LineTo hdc, x1, y1 + Height
    SelectObject hdc, hSavePen
    DeleteObject hPen
    
    hPen = CreatePen(PS_SOLID, 1, RGB(100, 100, 100))
    hSavePen = SelectObject(hdc, hPen)
    MoveToEx hdc, x1, y1 + Height, Point(0)
    LineTo hdc, x1 + width, y1 + Height
    LineTo hdc, x1 + width, y1 - 1
    SelectObject hdc, hSavePen
    DeleteObject hPen
    
    '画三角型
    x1 = x1 + (width - xPoint) / 2
    y1 = y1 + (Height - yPoint) / 2
    Point(0).x = x1 + 0
    Point(0).y = y1
    Point(1).x = x1 + xPoint
    Point(1).y = y1
    Point(2).x = x1 + 1 / 2 * xPoint
    Point(2).y = y1 + 1 * yPoint
    
    hSolidPen = CreateSolidBrush(Color)
    hSaveSolidPen = SelectObject(hdc, hSolidPen)
    hPen = CreatePen(PS_SOLID, 1, Color)
    hSavePen = SelectObject(hdc, hPen)
    Polygon hdc, Point(0), 3
    SelectObject hdc, hSavePen
    SelectObject hdc, hSaveSolidPen
    DeleteObject hPen
    DeleteObject hSolidPen
    
   ' ReleaseDC hwnd, hdc
End Sub
'画下箭头
Public Sub DrawArrow(ByVal hwnd As Long, ByVal x1 As Long, ByVal y1 As Long)
    Dim hdc As Long
    Dim hPen As Long, hSavePen As Long
    Dim lLog As LOGBRUSH
    Dim Point(6) As POINTAPI
    Dim xPoint As Integer
    Dim yPoint As Integer
    xPoint = 8
    yPoint = 8
    hdc = GetDC(hwnd)
    lLog.lbColor = RGB(198, 198, 198)
    'llog.lbHatch =
    lLog.lbStyle = BS_SOLID
    x1 = x1 / Screen.TwipsPerPixelX
    y1 = y1 / Screen.TwipsPerPixelX
    Point(0).x = x1 + 1 / 3 * xPoint
    Point(0).y = y1
    Point(1).x = x1 + 2 / 3 * xPoint
    Point(1).y = y1
    
    Point(2).x = x1 + 2 / 3 * xPoint
    Point(2).y = y1 + 2 / 4 * yPoint
    Point(3).x = x1 + 3 / 3 * xPoint
    Point(3).y = y1 + 2 / 4 * yPoint
    
    Point(4).x = x1 + 2 / 4 * xPoint
    Point(4).y = y1 + 1 * yPoint
    
    Point(5).x = x1 + 0
    Point(5).y = y1 + 2 / 4 * yPoint
    
    Point(6).x = x1 + 1 / 3 * xPoint
    Point(6).y = y1 + 2 / 4 * yPoint

    hPen = CreateSolidBrush(RGB(0, 0, 0))
    hSavePen = SelectObject(hdc, hPen)
    Polygon hdc, Point(0), 7
    SelectObject hdc, hSavePen
    DeleteObject hPen
    
    hPen = CreatePen(PS_SOLID, 1, RGB(0, 0, 0))
    hSavePen = SelectObject(hdc, hPen)
    MoveToEx hdc, x1, y1 + yPoint + 2, Point(0)
    LineTo hdc, x1 + xPoint + 1, y1 + yPoint + 2
    SelectObject hdc, hSavePen
    DeleteObject hPen
    
    ReleaseDC hwnd, hdc
End Sub

Public Function LoadRes(ByVal tID As Long, ByVal tType As Byte) As Object
    Select Case tType
     '位图
     Case vbResBitmap
        Set LoadRes = gclsRes.GetBitmap(tID)
     '图标
     Case vbResIcon
        Set LoadRes = gclsRes.GetIcon(tID)
     Case vbResCursor
        Set LoadRes = LoadResPicture(tID, vbResCursor)
     End Select
End Function

'得到窗体内控件的图片资源
Public Function GetFormResPicture(ByVal lrtType As Long, ByVal bytResType As Byte)
'    Dim intCount As Integer, intLoc As Integer
'    Dim blnIsFinded As Boolean, blnIsEmpty As Boolean
'    blnIsFinded = False
'    '第一次调用时，对数组初始化
'    If ArrIsEmpty(arrResPictureID) Then
'        ReDim arrResPicture(0)
'        ReDim arrResPictureID(0)
'        ReDim arrResPictureCount(0)
'        ReDim arrResPictureType(0)
'        Set arrResPicture(0) = LoadRes(lrtType, bytResType)
'        arrResPictureID(0) = lrtType
'        arrResPictureCount(0) = 1
'        arrResPictureType(0) = bytResType
'        Set GetFormResPicture = arrResPicture(0)
'        Exit Function
'    End If
'
'    '寻找资源ID号
'    For intCount = 0 To UBound(arrResPictureID)
'        If arrResPictureID(intCount) = lrtType And arrResPictureType(intCount) = bytResType Then
'            blnIsFinded = True
'            Exit For
'        End If
'    Next intCount
'
'    If blnIsFinded Then
'        arrResPictureCount(intCount) = arrResPictureCount(intCount) + 1
'        Set GetFormResPicture = arrResPicture(intCount)
'    Else
'        '寻找空缺位置
'        For intLoc = 0 To UBound(arrResPictureID)
'            If arrResPictureID(intLoc) = -1 Then
'                blnIsEmpty = True
'                Exit For
'            End If
'        Next intLoc
'
'        If Not blnIsEmpty Then
'            intLoc = UBound(arrResPictureID) + 1
'            ReDim Preserve arrResPicture(intLoc)
'            ReDim Preserve arrResPictureID(intLoc)
'            ReDim Preserve arrResPictureCount(intLoc)
'            ReDim Preserve arrResPictureType(intLoc)
'        End If
        '装载资源
        Set GetFormResPicture = LoadRes(lrtType, bytResType)
'        Set arrResPicture(intLoc) = LoadRes(lrtType, bytResType)
'        arrResPictureID(intLoc) = lrtType
'        arrResPictureCount(intLoc) = 1
'        arrResPictureType(0) = bytResType
'        Set GetFormResPicture = arrResPicture(intLoc)
'    End If
End Function

'卸载窗体内控件的图片资源
Public Sub RemoveFormResPicture(ByVal lrtType As Long)
'    Dim intCount As Integer
'    Dim blnIsFinded As Boolean
'    blnIsFinded = False
'    '寻找资源ID号
'    If ArrIsEmpty(arrResPictureID) Then Exit Sub
'    For intCount = 0 To UBound(arrResPictureID)
'        If arrResPictureID(intCount) = lrtType Then
'            blnIsFinded = True
'            Exit For
'        End If
'    Next intCount
'
'    If blnIsFinded Then
'        arrResPictureCount(intCount) = arrResPictureCount(intCount) - 1
'        If arrResPictureCount(intCount) = 0 Then
'            Set arrResPicture(intCount) = Nothing
'            gclsRes.ReleaseBitmapID arrResPictureID(intCount)
            gclsRes.ReleaseBitmap lrtType
'            arrResPictureID(intCount) = -1
'        End If
'    Else
'    End If
End Sub

'刷新相应列表的记录集资源
Public Sub RecordSetRefresh(ByVal msgNewMessage As Message)
Dim intLoc As Integer
   Select Case msgNewMessage
   Case msgBusinessAddress              '企业发货地址
        intLoc = FindRecLoc(lrtBusinessAddress)
        If intLoc = -1 Then Exit Sub
        Set arrListRecSet(intLoc) = LoadResRecordSet(lrtBusinessAddress)
   Case Message.msgBusinessBank         ''企业开户银行
        intLoc = FindRecLoc(lrtBusinessBank)
        If intLoc = -1 Then Exit Sub
        Set arrListRecSet(intLoc) = LoadResRecordSet(lrtBusinessBank)
   Case msgAccount                      '科目
        intLoc = FindRecLoc(lrtAccount)
        If intLoc = -1 Then Exit Sub
        Set arrListRecSet(intLoc) = LoadResRecordSet(lrtAccount)
   Case msgCustomer                     '单位
        intLoc = FindRecLoc(lrtCustomer)
        If intLoc = -1 Then Exit Sub
        Set arrListRecSet(intLoc) = LoadResRecordSet(lrtCustomer)
   Case msgDepartment                   '部门
        intLoc = FindRecLoc(lrtDepartment)
        If intLoc = -1 Then Exit Sub
        Set arrListRecSet(intLoc) = LoadResRecordSet(lrtDepartment)
   Case msgEmployee                     '员工
        intLoc = FindRecLoc(lrtEmployee)
        If intLoc = -1 Then Exit Sub
        Set arrListRecSet(intLoc) = LoadResRecordSet(lrtEmployee)
   Case msgClass                        '统计
        intLoc = FindRecLoc(lrtClass1)
        If intLoc = -1 Then Exit Sub
        Set arrListRecSet(intLoc) = LoadResRecordSet(lrtClass1)
        intLoc = FindRecLoc(lrtClass2)
        If intLoc = -1 Then Exit Sub
        Set arrListRecSet(intLoc) = LoadResRecordSet(lrtClass2)
        
   Case msgJob                          '工程
        intLoc = FindRecLoc(lrtJob)
        If intLoc = -1 Then Exit Sub
        Set arrListRecSet(intLoc) = LoadResRecordSet(lrtJob)
   Case msgItem                         '商品
        intLoc = FindRecLoc(lrtItem)
        If intLoc = -1 Then Exit Sub
        Set arrListRecSet(intLoc) = LoadResRecordSet(lrtItem)
   Case msgPosition                      '货位
        intLoc = FindRecLoc(lrtPosition)
        If intLoc = -1 Then Exit Sub
        Set arrListRecSet(intLoc) = LoadResRecordSet(lrtPosition)
   Case msgTerm                         '付款条件
        intLoc = FindRecLoc(lrtTerm)
        If intLoc = -1 Then Exit Sub
        Set arrListRecSet(intLoc) = LoadResRecordSet(lrtTerm)
   Case msgRemark                       '摘要
        intLoc = FindRecLoc(lrtRemark)
        If intLoc = -1 Then Exit Sub
        Set arrListRecSet(intLoc) = LoadResRecordSet(lrtRemark)
   
   Case msgVoucherType                  '凭证类别
        intLoc = FindRecLoc(lrtVoucherType)
        If intLoc = -1 Then Exit Sub
        Set arrListRecSet(intLoc) = LoadResRecordSet(lrtVoucherType)
   Case msgCustom1                     '自定项目0
        intLoc = FindRecLoc(lrtCustom0)
        If intLoc = -1 Then Exit Sub
        Set arrListRecSet(intLoc) = LoadResRecordSet(lrtCustom0)
   Case msgCustom2                      '自定项目1
        intLoc = FindRecLoc(lrtCustom1)
        If intLoc = -1 Then Exit Sub
        Set arrListRecSet(intLoc) = LoadResRecordSet(lrtCustom1)
   Case msgCustom3                      '自定项目2
        intLoc = FindRecLoc(lrtCustom2)
        If intLoc = -1 Then Exit Sub
        Set arrListRecSet(intLoc) = LoadResRecordSet(lrtCustom2)
   Case msgCustom4                      '自定项目3
        intLoc = FindRecLoc(lrtCustom3)
        If intLoc = -1 Then Exit Sub
        Set arrListRecSet(intLoc) = LoadResRecordSet(lrtCustom3)
   Case msgCustom5                      '自定项目4
        intLoc = FindRecLoc(lrtCustom4)
        If intLoc = -1 Then Exit Sub
        Set arrListRecSet(intLoc) = LoadResRecordSet(lrtCustom4)
   Case msgCustom6                      '自定项目5
        intLoc = FindRecLoc(lrtCustom5)
        If intLoc = -1 Then Exit Sub
        Set arrListRecSet(intLoc) = LoadResRecordSet(lrtCustom5)
   Case msgPaymentMethod                '付款方式
        intLoc = FindRecLoc(lrtPaymentMethod)
        If intLoc = -1 Then Exit Sub
        Set arrListRecSet(intLoc) = LoadResRecordSet(lrtPaymentMethod)
    Case msgClass2      '项目
        intLoc = FindRecLoc(lrtClass2)
        If intLoc = -1 Then Exit Sub
        Set arrListRecSet(intLoc) = LoadResRecordSet(lrtClass2)
   End Select
End Sub