utility.bas

金算盘软件代码

                    Set ctlControl.MouseIcon = GetFormResPicture(CInt(strResID), vbResCursor)
                End Select
            End If
        End If
    Next
    Exit Sub
Error_Handle:
End Sub

'卸载窗体内控件的图片资源
Public Sub UnLoadFormResPicture(ByVal frmForm As Form)
    Dim ctlControl As Control
    Dim strControlType As String
    Dim strResID As String
    
    On Error GoTo Error_Handle
    
    RemoveFormResPicture 139
    
    For Each ctlControl In frmForm.Controls
        strControlType = TypeName(ctlControl)
        strResID = ctlControl.Tag
        
        If strResID > "0" And strResID < "32767" Then
            If strResID > "1000" And strResID < "2000" Then
                ctlControl.Picture = Nothing
                RemoveFormResPicture Int(strResID)
            ElseIf strResID > "2000" And strResID < "3000" Then
                Select Case strControlType
                Case ""
                Case Else
                    ctlControl.MouseIcon = Nothing
                End Select
                RemoveFormResPicture Int(strResID)
            End If
        End If
    Next
    Exit Sub
Error_Handle:
End Sub

'复制菜单项目
Public Sub CloneMenu(ByVal mnuSource As Menu, ByVal mnuTraget As Menu)
    On Error Resume Next
    With mnuTraget
        .Checked = False
        .Enabled = True
        .Caption = mnuSource.Caption
        .Enabled = mnuSource.Enabled
        .Checked = mnuSource.Checked
        .HelpContextID = mnuSource.HelpContextID
        .Tag = mnuSource.Tag
        .Visible = mnuSource.Visible
    End With
End Sub

'初始化日期段下拉列表
Public Sub InitDate(objControl As Object)
  Dim intPeriod As Integer, intYear As Integer
  
  intYear = gclsBase.FYearOfDate(gclsBase.BeginDate, , , intPeriod)
  
  If TypeOf objControl Is ComboBox Then
        With objControl
             .Clear
             .AddItem "所有"
             .AddItem "今天"
             .AddItem "本周"
             .AddItem "本周至今日"
             .AddItem "本期"
             .AddItem "本期至今日"
             .AddItem "本月"
             .AddItem "本月至今日"
             .AddItem "本季度"
             .AddItem "本季至今日"
             .AddItem "本年"
             .AddItem "本年至今日"
             .AddItem "上周"
             If Not (intYear = gclsBase.AccountYear And intPeriod = gclsBase.Period) Then
                .AddItem "上期"
             End If
             .AddItem "上月"
             .AddItem "上季度"
             '.AddItem "去年"
             .AddItem "自定义"
             .ListIndex = 0
        End With
  End If
  
  If TypeOf objControl Is ListText Then
        With objControl
             .SeekCol = "-1,1"
             .ClearRefer
             .AddRefer "所有"
             .AddRefer "今天"
             .AddRefer "本周"
             .AddRefer "本周至今日"
             .AddRefer "本期"
             .AddRefer "本期至今日"
             .AddRefer "本月"
             .AddRefer "本月至今日"
             .AddRefer "本季度"
             .AddRefer "本季至今日"
             .AddRefer "本年"
             .AddRefer "本年至今日"
             .AddRefer "上周"
             If Not (intYear = gclsBase.AccountYear And intPeriod = gclsBase.Period) Then
                .AddRefer "上期"
             End If
             .AddRefer "上月"
             .AddRefer "上季度"
             .AddRefer "去年"
             .AddRefer "自定义"
             .ReferRow = 0
        End With
  End If
End Sub

'取随机数
Public Function RandID() As String
    Randomize
    RandID = Format(Int(Rnd * 1000000000000#))
End Function

'画Frame类型边框
Public Sub FrameBox(ByVal hwnd, x1, y1, x2, y2 As Long)
    Dim hdc As Long
    Dim hPen1 As Long, hPen2 As Long, hSavePen As Long
    Dim Point As POINTAPI
    
    hdc = GetDC(hwnd)
    
    x1 = x1 / Screen.TwipsPerPixelX
    x2 = x2 / Screen.TwipsPerPixelX
    y1 = y1 / Screen.TwipsPerPixelY
    y2 = y2 / Screen.TwipsPerPixelY
    
    hPen1 = CreatePen(PS_SOLID, 1, RGB(128, 128, 128))
    hSavePen = SelectObject(hdc, hPen1)
    Rectangle hdc, x1, y1, x2, y2
    
    hPen2 = CreatePen(PS_SOLID, 1, RGB(255, 255, 255))
    SelectObject hdc, hPen2
    MoveToEx hdc, x1 + 1, y1 + 1, Point
    LineTo hdc, x2 - 1, y1 + 1
    MoveToEx hdc, x1 + 1, y1 + 1, Point
    LineTo hdc, x1 + 1, y2 - 1
    MoveToEx hdc, x1, y2, Point
    LineTo hdc, x2, y2
    MoveToEx hdc, x2, y1, Point
    LineTo hdc, x2, y2 + 1
    
    SelectObject hdc, hSavePen
    DeleteObject hPen1
    DeleteObject hPen2
    
    ReleaseDC hwnd, hdc
End Sub

'显示消息对话框
Public Function ShowMsg(ByVal hwnd As Long, ByVal lpText As String, ByVal wType As Long, Optional ByVal lpCaption As String = "") As Long
    If lpCaption = "" Then
        lpCaption = App.ProductName
    End If
    ShowMsg = MessageBox(hwnd, lpText, lpCaption, wType)
End Function

Public Function HiWord(ByVal l As Long) As Integer
    Dim intHiWord As Integer
    
    Call CopyMemory(intHiWord, ByVal VarPtr(l) + 2, 2)
    
    HiWord = intHiWord
End Function

Public Function LoWord(ByVal l As Long) As Integer
    Dim intLoWord As Integer
    
    Call CopyMemory(intLoWord, ByVal VarPtr(l), 2)
    
    LoWord = intLoWord
End Function

'画凹进线
Public Sub DrawInSertLine(ByVal hwnd As Long, ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long)
    Dim hdc As Long
    Dim hPen As Long, hSavePen As Long
    Dim Point As POINTAPI
    
    hdc = GetDC(hwnd)
    
    x1 = x1 / Screen.TwipsPerPixelX
    x2 = x2 / Screen.TwipsPerPixelX
    y1 = y1 / Screen.TwipsPerPixelY
    y2 = y2 / Screen.TwipsPerPixelY
    
    hPen = CreatePen(PS_SOLID, 1, RGB(0, 0, 0))
    hSavePen = SelectObject(hdc, hPen)
    MoveToEx hdc, x1, y1, Point
    LineTo hdc, x2, y2
    SelectObject hdc, hSavePen
    hPen = CreatePen(PS_SOLID, 1, RGB(255, 255, 255))
    hSavePen = SelectObject(hdc, hPen)
    MoveToEx hdc, x1, y1 + 1, Point
    LineTo hdc, x2, y2 + 1
    SelectObject hdc, hSavePen
    DeleteObject hPen
    
    ReleaseDC hwnd, hdc
End Sub
'画线
Public Sub DrawALine(ByVal hdc As Long, ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long, _
                    ByVal cL As Long, cT As Long, ByVal cR As Long, ByVal cB As Long, Optional ByVal lngColor As Long = 13027014)
'    Dim hdc As Long
    Dim hPen As Long, hSavePen As Long
    Dim Point As POINTAPI
    Dim blnIsVisible As Boolean
    Dim RectClip As RECT
    RectClip.Left = cL
    RectClip.top = cT
    RectClip.Right = cR
    RectClip.Bottom = cB
'    hdc = GetDC(hwnd)
    x1 = x1 / Screen.TwipsPerPixelX
    x2 = x2 / Screen.TwipsPerPixelX
    y1 = y1 / Screen.TwipsPerPixelY
    y2 = y2 / Screen.TwipsPerPixelY
        '裁减作图区域
    blnIsVisible = True
    With RectClip
        If x1 = x2 Then
            If (x1 < .Left Or x1 > .Right) Then
                blnIsVisible = False
            ElseIf y1 < .top And y2 < .top Then
                blnIsVisible = False
            ElseIf y1 > .Bottom And y2 > .Bottom Then
                blnIsVisible = False
            Else
                If y1 < .top Then y1 = .top
                If y2 > .Bottom Then y2 = .Bottom
            End If
        ElseIf y1 = y2 Then
            If (y1 < .top Or y1 > .Bottom) Then
                blnIsVisible = False
            ElseIf x1 < .Left And x2 < .Left Then
                blnIsVisible = False
            ElseIf x1 > .Right And x2 > .Right Then
                blnIsVisible = False
            Else
                If x1 < .Left Then x1 = .Left
                If x2 > .Right Then x2 = .Right
            End If
        End If
    End With
    
    If blnIsVisible Then
        hPen = CreatePen(PS_SOLID, 1, lngColor)
        hSavePen = SelectObject(hdc, hPen)
        MoveToEx hdc, x1, y1, Point
        LineTo hdc, x2, y2
        SelectObject hdc, hSavePen
        DeleteObject hPen
 '       ReleaseDC hwnd, hdc
    End If
End Sub
'不采用裁剪区画线
Public Sub DrawBLine(ByVal hdc As Long, ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long, Optional ByVal lngColor As Long = 13027014)
 '   Dim hdc As Long
    Dim hPen As Long, hSavePen As Long
    Dim Point As POINTAPI
    Dim blnIsVisible As Boolean
    
'    hdc = GetDC(hwnd)
    x1 = x1 / Screen.TwipsPerPixelX
    x2 = x2 / Screen.TwipsPerPixelX
    y1 = y1 / Screen.TwipsPerPixelY
    y2 = y2 / Screen.TwipsPerPixelY
        hPen = CreatePen(PS_SOLID, 1, lngColor)
        hSavePen = SelectObject(hdc, hPen)
        MoveToEx hdc, x1, y1, Point
        LineTo hdc, x2, y2
        SelectObject hdc, hSavePen
        DeleteObject hPen
'        ReleaseDC hwnd, hdc
End Sub

Public Sub WorkOver()
    Unload MsgForm
End Sub

'写字
Public Sub WriteAString(ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal strText As String, ByVal nMaxCharNo As Long, _
                        Optional ByVal lngColor As Long = 0, _
                        Optional ByVal lngFontHeight As Long = 12, _
                        Optional ByVal lngBkColor As Long = 16777215, _
                        Optional ByVal blnBkTransparent As Boolean = True)
'    Dim hdc As Long
    Dim hOldColor As Long
    Dim hOldBkColor As Long
    Dim Point As POINTAPI
    Dim hFont As Long, hSaveFont As Long
    Dim lngSaveBkMode As Long
    Dim strNew As String
    strNew = ReplaceString(strText, Chr(9))
'    hdc = GetDC(hwnd)
    x = x / Screen.TwipsPerPixelX
    y = (y + 30) / Screen.TwipsPerPixelY
    If lngFontHeight = 9 Or lngFontHeight = -9 Then
        hFont = CreateFont(-9, 5, 0, 0, 100, 0, 0, 0, 134, 3, 2, 1, 2, "宋体")
    ElseIf lngFontHeight = 10 Or lngFontHeight = -10 Then
        hFont = CreateFont(-10, 4, 0, 0, 500, 0, 0, 0, 134, 3, 2, 1, 2, "宋体")
    ElseIf lngFontHeight = 12 Or lngFontHeight = -12 Then
        hFont = CreateFont(-12, 0, 0, 0, 400, 0, 0, 0, 134, 3, 2, 1, 2, "宋体")
    Else
        hFont = CreateFont(-Abs(lngFontHeight), 0, 0, 0, 500, 0, 0, 0, 134, 3, 2, 1, 2, "宋体")
    End If

    If blnBkTransparent = False Then
        lngSaveBkMode = SetBkMode(hdc, OPAQUE)
        hOldBkColor = SetBkColor(hdc, lngBkColor)
    Else
        lngSaveBkMode = SetBkMode(hdc, TRANSPARENT)
    End If
    hSaveFont = SelectObject(hdc, hFont)
    hOldColor = SetTextColor(hdc, lngColor)
    If StrLen(strNew) > nMaxCharNo Then
        strNew = SubStr(strNew, 1, nMaxCharNo)
    ElseIf StrLen(strNew) < nMaxCharNo Then
        strNew = Space(nMaxCharNo - StrLen(strNew)) + strNew
    End If
    TextOut hdc, x, y, strNew, StrLen(strNew)
    SetTextColor hdc, hOldColor
    SelectObject hdc, hSaveFont
    If blnBkTransparent = False Then
        SetBkMode hdc, lngSaveBkMode
        SetBkColor hdc, hOldColor
    Else
        SetBkMode hdc, lngSaveBkMode
    End If
    DeleteObject hFont
 '   ReleaseDC hwnd, hdc
End Sub
'画方框
Public Sub DrawABox(ByVal hdc As Long, ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long, Optional ByVal lngColor As Long = 0, Optional ByVal blnFill As Boolean = False)
'    Dim hdc As Long
    Dim hPen As Long, hSavePen As Long
    Dim Point As POINTAPI
    Dim PointXY(3) As POINTAPI
'    hdc = GetDC(hwnd)
    
    x1 = x1 / Screen.TwipsPerPixelX
    x2 = x2 / Screen.TwipsPerPixelX
    y1 = y1 / Screen.TwipsPerPixelY
    y2 = y2 / Screen.TwipsPerPixelY
    If blnFill Then
        PointXY(0).x = x1
        PointXY(0).y = y1
        PointXY(1).x = x2
        PointXY(1).y = y1
        PointXY(2).x = x2
        PointXY(2).y = y2
        PointXY(3).x = x1
        PointXY(3).y = y2
    '画实心矩形
        hPen = CreateSolidBrush(lngColor)
        hSavePen = SelectObject(hdc, hPen)
        Polygon hdc, PointXY(0), 4
        SelectObject hdc, hSavePen
        DeleteObject hPen