isbutton.ctl

为个人用户开发的车险秘书系统

Private Sub zPatchRel(ByVal nAddr As Long, ByVal nOffset As Long, ByVal nTargetAddr As Long)

  Call RtlMoveMemory(ByVal nAddr + nOffset, nTargetAddr - nAddr - nOffset - 4, 4)

End Sub

'Patch the machine code buffer at the indicated offset with the passed value
Private Sub zPatchVal(ByVal nAddr As Long, ByVal nOffset As Long, ByVal nValue As Long)

  Call RtlMoveMemory(ByVal nAddr + nOffset, nValue, 4)
  
End Sub

'Worker function for Subclass_InIDE
Private Function zSetTrue(ByRef bValue As Boolean) As Boolean

  zSetTrue = True
  bValue = True
  
End Function


'*************************************************************
'
'   Private Auxiliar Subs
'
'*************************************************************

'draw a Line Using API call's
Private Sub APILine(X1 As Long, Y1 As Long, X2 As Long, Y2 As Long, lcolor As Long)

    'Use the API LineTo for Fast Drawing
    Dim pt As POINT
    Dim hPen As Long, hPenOld As Long
    hPen = CreatePen(0, 1, lcolor)
    hPenOld = SelectObject(UserControl.hdc, hPen)
    MoveToEx UserControl.hdc, X1, Y1, pt
    LineTo UserControl.hdc, X2, Y2
    SelectObject UserControl.hdc, hPenOld
    DeleteObject hPen
    
End Sub

' full version of APILine
Private Sub APILineEx(lhdcEx As Long, X1 As Long, Y1 As Long, X2 As Long, Y2 As Long, lcolor As Long)

    'Use the API LineTo for Fast Drawing
    Dim pt As POINT
    Dim hPen As Long, hPenOld As Long
    hPen = CreatePen(0, 1, lcolor)
    hPenOld = SelectObject(lhdcEx, hPen)
    MoveToEx lhdcEx, X1, Y1, pt
    LineTo lhdcEx, X2, Y2
    SelectObject lhdcEx, hPenOld
    DeleteObject hPen
    
End Sub

Private Sub APIFillRect(hdc As Long, rc As RECT, Color As Long)

  Dim OldBrush As Long
  Dim NewBrush As Long
  NewBrush& = CreateSolidBrush(Color&)
  Call FillRect(hdc&, rc, NewBrush&)
  Call DeleteObject(NewBrush&)
  
End Sub

Private Sub APIFillRectByCoords(hdc As Long, ByVal x As Long, ByVal Y As Long, ByVal w As Long, ByVal h As Long, Color As Long)
  
  Dim OldBrush As Long
  Dim NewBrush As Long
  Dim tmprect As RECT
  NewBrush& = CreateSolidBrush(Color&)
  SetRect tmprect, x, Y, x + w, Y + h
  Call FillRect(hdc&, tmprect, NewBrush&)
  Call DeleteObject(NewBrush&)
  
End Sub

Private Function APIRectangle(ByVal hdc As Long, ByVal x As Long, ByVal Y As Long, ByVal w As Long, ByVal h As Long, Optional lcolor As OLE_COLOR = -1) As Long
    
    Dim hPen As Long, hPenOld As Long
    Dim r
    Dim pt As POINT
    hPen = CreatePen(0, 1, lcolor)
    hPenOld = SelectObject(hdc, hPen)
    MoveToEx hdc, x, Y, pt
    LineTo hdc, x + w, Y
    LineTo hdc, x + w, Y + h
    LineTo hdc, x, Y + h
    LineTo hdc, x, Y
    SelectObject hdc, hPenOld
    DeleteObject hPen
    
End Function

Private Sub DrawCtlEdgeByRect(hdc As Long, rt As RECT, Optional Style As Long = EDGE_RAISED, Optional Flags As Long = BF_RECT)
 
 DrawEdge hdc, rt, Style, Flags
 
End Sub

Private Sub DrawCtlEdge(hdc As Long, ByVal x As Single, ByVal Y As Single, ByVal w As Single, ByVal h As Single, Optional Style As Long = EDGE_RAISED, Optional ByVal Flags As Long = BF_RECT)
 
 Dim r As RECT
 With r
  .Left = x
  .Top = Y
  .Right = x + w
  .bottom = Y + h
 End With
 DrawEdge hdc, r, Style, Flags
 
End Sub

'Blend two colors
Private Function BlendColors(ByVal lcolor1 As Long, ByVal lcolor2 As Long)

    BlendColors = RGB(((lcolor1 And &HFF) + (lcolor2 And &HFF)) / 2, (((lcolor1 \ &H100) And &HFF) + ((lcolor2 \ &H100) And &HFF)) / 2, (((lcolor1 \ &H10000) And &HFF) + ((lcolor2 \ &H10000) And &HFF)) / 2)

End Function

'System color code to long rgb
Private Function TranslateColor(ByVal lcolor As Long) As Long

    If OleTranslateColor(lcolor, 0, TranslateColor) Then
          TranslateColor = -1
    End If
    
End Function

'Make Soft a color
Private Function SoftColor(lcolor As OLE_COLOR) As OLE_COLOR

    Dim lRed As OLE_COLOR
    Dim lGreen As OLE_COLOR
    Dim lBlue As OLE_COLOR
    Dim lr As OLE_COLOR, lg As OLE_COLOR, lb As OLE_COLOR
    lr = (lcolor And &HFF)
    lg = ((lcolor And 65280) \ 256)
    lb = ((lcolor) And 16711680) \ 65536
    lRed = (76 - Int(((lcolor And &HFF) + 32) \ 64) * 19)
    lGreen = (76 - Int((((lcolor And 65280) \ 256) + 32) \ 64) * 19)
    lBlue = (76 - Int((((lcolor And &HFF0000) \ &H10000) + 32) / 64) * 19)
    SoftColor = RGB(lr + lRed, lg + lGreen, lb + lBlue)
    
End Function

Private Function MSOXPShiftColor(ByVal theColor As Long, Optional ByVal Base As Long = &HB0) As Long

    Dim Red As Long, Blue As Long, Green As Long
    Dim Delta As Long
    
    Blue = ((theColor \ &H10000) Mod &H100)
    Green = ((theColor \ &H100) Mod &H100)
    Red = (theColor And &HFF)
    Delta = &HFF - Base
    
    Blue = Base + Blue * Delta \ &HFF
    Green = Base + Green * Delta \ &HFF
    Red = Base + Red * Delta \ &HFF
    
    If Red > 255 Then Red = 255
    If Green > 255 Then Green = 255
    If Blue > 255 Then Blue = 255
    
    MSOXPShiftColor = Red + 256& * Green + 65536 * Blue

End Function


Private Function msSoftColor(lcolor As Long) As Long

    Dim lRed As Long
    Dim lGreen As Long
    Dim lBlue As Long
    Dim lr As Long, lg As Long, lb As Long
    lr = (lcolor And &HFF)
    lg = ((lcolor And 65280) \ 256)
    lb = ((lcolor) And 16711680) \ 65536
    lRed = (76 - Int(((lcolor And &HFF) + 32) \ 64) * 19)
    lGreen = (76 - Int((((lcolor And 65280) \ 256) + 32) \ 64) * 19)
    lBlue = (76 - Int((((lcolor And &HFF0000) \ &H10000) + 32) / 64) * 19)
    msSoftColor = RGB(lr + lRed, lg + lGreen, lb + lBlue)
    
End Function

'Offset a color
Private Function OffsetColor(lcolor As OLE_COLOR, lOffset As Long) As OLE_COLOR

    Dim lRed As OLE_COLOR
    Dim lGreen As OLE_COLOR
    Dim lBlue As OLE_COLOR
    Dim lr As OLE_COLOR, lg As OLE_COLOR, lb As OLE_COLOR
    lr = (lcolor And &HFF)
    lg = ((lcolor And 65280) \ 256)
    lb = ((lcolor) And 16711680) \ 65536
    lRed = (lOffset + lr)
    lGreen = (lOffset + lg)
    lBlue = (lOffset + lb)
    If lRed > 255 Then lRed = 255
    If lRed < 0 Then lRed = 0
    If lGreen > 255 Then lGreen = 255
    If lGreen < 0 Then lGreen = 0
    If lBlue > 255 Then lBlue = 255
    If lBlue < 0 Then lBlue = 0
    OffsetColor = RGB(lRed, lGreen, lBlue)
    
End Function

Private Sub DrawCaption()

    Dim lcolor As Long, ltmpColor As Long
    If Not m_bUseCustomColors Then
        If m_iState <> statedisabled Then
            lcolor = GetSysColor(COLOR_BTNTEXT)
        Else
            lcolor = TranslateColor(vbGrayText)
        End If
    Else
        Select Case m_iState
            Case statenormal
                lcolor = m_lFontColor
            Case statedisabled
                lcolor = TranslateColor(vbGrayText)
            Case Else
                lcolor = m_lFontHighlightColor
        End Select
    End If
    ltmpColor = UserControl.ForeColor
    UserControl.ForeColor = lcolor
    DrawText UserControl.hdc, m_sCaption, -1, m_txtRect, lwFontAlign
    UserControl.ForeColor = ltmpColor
    
End Sub


Private Sub fPaintPicture(ByRef m_Picture As StdPicture, ByVal x As Long, ByVal Y As Long, ByVal w As Long, ByVal h As Long)
    
    Dim memDC As Long, memDC1 As Long
    Dim membitmap As Long
    Dim oldW As Long, oldH As Long
    'setup w,h vars
    oldW = m_Picture.Width: oldH = m_Picture.Height
    'create compatible DC
    memDC = CreateCompatibleDC(UserControl.hdc)
    'create the copy on the
    membitmap = SelectObject(memDC, m_Picture.Handle)
    'BitBlt memDC, 0, 0, oldW, oldH, vbSrcCopy
    StretchBlt