VB进度条游戏血条控件

最新推荐文章于 2021-03-22 18:11:27 发布
TakiCN
最新推荐文章于 2021-03-22 18:11:27 发布
阅读量866
点赞数 1
文章标签： vb 游戏 user hex string
本文链接：https://blog.csdn.net/Taki_CN/article/details/2893541
版权
 
 在VB中直接添加一个用户控件,将以下代码COPY粘贴进去
  
  
Option Explicit
  
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal HDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal HDC As Long) As Long
Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Any) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal HDC As Long) As Long
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal HDC As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal HDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function FrameRect Lib "user32" (ByVal HDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function GradientFillRect Lib "msimg32" Alias "GradientFill" (ByVal HDC As Long, pVertex As TRIVERTEX, ByVal dwNumVertex As Long, pMesh As GRADIENT_RECT, ByVal dwNumMesh As Long, ByVal dwMode As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal HDC As Long, ByVal hObject As Long) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal HDC As Long, ByVal crColor As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal HDC As Long, ByVal nBkMode As Long) As Long
Private Declare Function SetPixelV Lib "gdi32" (ByVal HDC As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal HDC As Long, ByVal crColor As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
  
  
Const RGN_DIFF     As Long = 4
Const DT_SINGLELINE   As Long = 
Private Type RECT
  Left     As Long
  Top     As Long
  Right   As Long
  Bottom   As Long
End Type
Private Type TRIVERTEX
  X       As Long
  Y       As Long
  Red     As Integer
  Green   As Integer
  Blue     As Integer
  Alpha   As Integer
End Type
Private Type GRADIENT_RECT
  UPPERLEFT As Long
  LOWERRIGHT As Long
End Type
Private Type RGB
  R       As Integer
  G       As Integer
  B       As Integer
End Type
Public Enum cScrolling
  ccScrollingStandard = 0
  ccScrollingSmooth = 1
  ccScrollingSearch = 2
End Enum
  
Public Enum cOrientation
  ccOrientationHorizontal = 0
  ccOrientationVertical = 1
End Enum
  
Private m_Scrolling   As cScrolling
Private m_Orientation As cOrientation
  
Private m_Color     As OLE_COLOR
Private m_hDC     As Long
Private m_hWnd     As Long
Private m_Max     As Long
Private m_Min     As Long
Private m_Value     As Long
Private m_ShowText   As Boolean
Private m_ShowInTask As Boolean
  
  
Private m_MemDC   As Boolean
Private m_ThDC   As Long
Private m_hBmp   As Long
Private m_hBmpOld As Long
Private iFnt     As IFont
Private m_fnt     As IFont
Private hFntOld   As Long
Private m_lWidth   As Long
Private m_lHeight As Long
Private fPercent   As Double
Private TR       As RECT
Private TBR     As RECT
Private TSR     As RECT
Private lSegmentWidth   As Long
Private lSegmentSpacing As Long
Public Sub DrawProgressBar()
  
  GetClientRect m_hWnd, TR
  
  
  DrawFillRectangle TR, vbWhite, m_hDC
  
  CalcBarSize
  
  PBarDraw
  
  If m_Scrolling = 0 Then DrawDivisions
  
  DrawTexto
  
  pDrawBorder
  
  If m_MemDC Then
    With UserControl
        pDraw .HDC, 0, 0, .ScaleWidth, .ScaleHeight, .ScaleLeft, .ScaleTop
    End With
  End If
  
End Sub
Private Sub CalcBarSize()
  
  lSegmentWidth = 8
  lSegmentSpacing = 2
  
  LSet TBR = TR
  
  fPercent = (m_Value - m_Min) / (m_Max - m_Min)
  If fPercent > 1# Then fPercent = 1#
  If fPercent < 0# Then fPercent = 0#
  
  If m_Orientation = 0 Then
    TBR.Right = TR.Left + (TR.Right - TR.Left) * fPercent
    TBR.Right = TBR.Right - ((TBR.Right - TBR.Left) Mod (lSegmentWidth + lSegmentSpacing))
    If TBR.Right < TR.Left Then
        TBR.Right = TR.Left
    End If
    If TBR.Right < TR.Left Then TBR.Right = TR.Left
    
  Else
          fPercent = 1# - fPercent - 0.02
    TBR.Top = TR.Top + (TR.Bottom - TR.Top) * fPercent
    TBR.Top = TBR.Top - ((TBR.Top - TBR.Bottom) Mod (lSegmentWidth + lSegmentSpacing))
    If TBR.Top > TR.Bottom Then TBR.Top = TR.Bottom
    
    
    
  End If
  
End Sub
Private Sub DrawDivisions()
  Dim i As Long
  Dim hBR As Long
  
  hBR = CreateSolidBrush(vbWhite)
  
  LSet TSR = TR
  
  If m_Orientation = 0 Then
    
    For i = TBR.Left + lSegmentWidth To TBR.Right Step lSegmentWidth + lSegmentSpacing
        TSR.Left = i + 2
        TSR.Right = i + 2 + lSegmentSpacing
        FillRect m_hDC, TSR, hBR
    Next i
    
  Else
    For i = TBR.Bottom To TBR.Top + lSegmentWidth Step -(lSegmentWidth + lSegmentSpacing)
        TSR.Top = i - 2
        TSR.Bottom = i - 2 + lSegmentSpacing
        FillRect m_hDC, TSR, hBR
    Next i
    
  End If
  
  DeleteObject hBR
  
End Sub
Private Sub pDrawBorder()
  Dim RTemp As RECT
  
  Let RTemp = TR
  
  RTemp.Left = TR.Left + 1: RTemp.Top = TR.Top + 1
  DrawRectangle RTemp, GetLngColor(&HBEBEBE), m_hDC
  RTemp.Left = TR.Left + 1: RTemp.Top = TR.Top + 2: RTemp.Right = TR.Right - 1: RTemp.Bottom = TR.Bottom - 1
  DrawRectangle RTemp, GetLngColor(&HEFEFEF), m_hDC
  DrawRectangle TR, GetLngColor(&H686868), m_hDC
  
  Call SetPixelV(m_hDC, 1, 1, GetLngColor(&H686868))
  Call SetPixelV(m_hDC, TR.Right - 2, 1, GetLngColor(&H686868))
  Call SetPixelV(m_hDC, 1, TR.Bottom - 2, GetLngColor(&H686868))
  Call SetPixelV(m_hDC, TR.Right - 2, TR.Bottom - 2, GetLngColor(&H686868))
  
End Sub
Private Sub PBarDraw()
  Dim TempRect As RECT
  Dim ITemp   As Long
  
  If m_Orientation = 0 Then
    
    TempRect.Left = TBR.Right
    TempRect.Right = 2
    TempRect.Top = 8
    TempRect.Bottom = TR.Bottom - 6
    
    
    
    If m_Scrolling = ccScrollingSearch Then
        GoSub HorizontalSearch
    Else
        DrawGradient m_hDC, 2, 3, TBR.Right - 2, 6, GetRGBColors(ShiftColorXP(m_Color, 150)), GetRGBColors(m_Color)
        DrawFillRectangle TempRect, m_Color, m_hDC
        DrawGradient m_hDC, 2, TempRect.Bottom - 2, TBR.Right - 2, 6, GetRGBColors(m_Color), GetRGBColors(ShiftColorXP(m_Color, 150))
    End If
    
  Else
    
    TempRect.Left = 7
    TempRect.Right = TR.Right - 8
    TempRect.Top = TBR.Top
    TempRect.Bottom = TR.Bottom
    
    
    If m_Scrolling = ccScrollingSearch Then
        GoSub VerticalSearch
    Else
        DrawGradient m_hDC, 2, TBR.Top, 6, TR.Bottom, GetRGBColors(ShiftColorXP(m_Color, 150)), GetRGBColors(m_Color), 0
        DrawFillRectangle TempRect, m_Color, m_hDC
        DrawGradient m_hDC, TR.Right - 8, TBR.Top, 6, TR.Bottom, GetRGBColors(m_Color), GetRGBColors(ShiftColorXP(m_Color, 150)), 0
    End If
    
    
  End If
  
  Exit Sub
  
HorizontalSearch:
  
  
  For ITemp = 0 To 2
    
    With TempRect
        .Left = TBR.Right + ((lSegmentSpacing + 10) * ITemp)
        .Right = .Left + 10
        .Top = 8
        .Bottom = TR.Bottom - 6
        DrawGradient m_hDC, .Left, 3, 10, 6, GetRGBColors(ShiftColorXP(m_Color, 220 - (40 * ITemp))), GetRGBColors(ShiftColorXP(m_Color, 200 - (40 * ITemp)))
        DrawFillRectangle TempRect, ShiftColorXP(m_Color, 200 - (40 * ITemp)), m_hDC
        DrawGradient m_hDC, .Left, .Bottom - 2, 10, 6, GetRGBColors(ShiftColorXP(m_Color, 200 - (40 * ITemp))), GetRGBColors(ShiftColorXP(m_Color, 220 - (40 * ITemp)))
    End With
    
  Next ITemp
  
  Return
  
VerticalSearch:
  
  
  For ITemp = 0 To 2
    
    With TempRect
        .Left = 8
        .Right = TR.Right - 8
        .Top = TBR.Top + ((lSegmentSpacing + 10) * ITemp)
        .Bottom = .Top + 10
        DrawGradient m_hDC, 2, .Top, 6, 10, GetRGBColors(ShiftColorXP(m_Color, 220 - (40 * ITemp))), GetRGBColors(ShiftColorXP(m_Color, 200 - (40 * ITemp)))
        DrawFillRectangle TempRect, ShiftColorXP(m_Color, 200 - (40 * ITemp)), m_hDC
        DrawGradient m_hDC, .Right, .Top, 6, 10, GetRGBColors(ShiftColorXP(m_Color, 200 - (40 * ITemp))), GetRGBColors(ShiftColorXP(m_Color, 220 - (40 * ITemp)))
    End With
    
  Next ITemp
  
  Return
  
  
  
End Sub
Private Function DrawTexto()
  Dim ThisText As String
  
  If m_Scrolling = ccScrollingSearch Then
    ThisText = "帮助"
  Else
  ThisText = m_Value & "/" & m_Max
  End If
  
  If (m_ShowText) Then
    Set iFnt = Font
    hFntOld = SelectObject(m_hDC, iFnt.hFont)
    SetBkMode m_hDC, 1
    SetTextColor m_hDC, vbBlack
    DrawText m_hDC, ThisText, -1, TR, DT_SINGLELINE Or 1 Or 4
    SelectObject m_hDC, hFntOld
  End If
  
End Function
Private Function GetLngColor(Color As Long) As Long
  
  If (Color And &H80000000) Then
    GetLngColor = GetSysColor(Color And &H7FFFFFFF)
  Else
    GetLngColor = Color
  End If
End Function
Private Function GetRGBColors(Color As Long) As RGB
  
  Dim HexColor As String
  
  HexColor = String(6 - Len(Hex(Color)), "0") & Hex(Color)
  GetRGBColors.R = "&H" & Mid(HexColor, 5, 2) & "00"
  GetRGBColors.G = "&H" & Mid(HexColor, 3, 2) & "00"
  GetRGBColors.B = "&H" & Mid(HexColor, 1, 2) & "00"
End Function
Private Sub DrawRectangle(ByRef BRect As RECT, ByVal Color As Long, ByVal HDC As Long)
  
  Dim hBrush As Long
  
  hBrush = CreateSolidBrush(Color)
  FrameRect HDC, BRect, hBrush
  DeleteObject hBrush
  
End Sub
Private Function ShiftColorXP(ByVal MyColor As Long, ByVal Base As Long) As Long
  
  Dim R As Long, G As Long, B As Long, Delta As Long
  
  R = (MyColor And &HFF)
  G = ((MyColor / &H100) Mod &H100)
  B = ((MyColor / &H10000) Mod &H100)
  
  Delta = &HFF - Base
  
  B = Base + B * Delta / 
  G = Base + G * Delta / 
  R = Base + R * Delta / 
  
  If R > 255 Then R = 255
  If G > 255 Then G = 255
  If B > 255 Then B = 255
  
  ShiftColorXP = R + 256& * G + 65536 * B
  
End Function
Private Sub DrawGradient( _
  ByVal cHdc As Long, _
  ByVal X As Long, _
  ByVal Y As Long, _
  ByVal X2 As Long, _
  ByVal Y2 As Long, _
  ByRef Color1 As RGB, _
  ByRef Color2 As RGB, _
  Optional Direction = 1)
  
  Dim Vert(1) As TRIVERTEX
  Dim gRect   As GRADIENT_RECT
  
  With Vert(0)
    .X = X
    .Y = Y
    .Red = Color1.R
    .Green = Color1.G
    .Blue = Color1.B
    .Alpha = 0
  End With
  
  With Vert(1)
    .X = Vert(0).X + X2
    .Y = Vert(0).Y + Y2
    .Red = Color2.R
    .Green = Color2.G
    .Blue = Color2.B
    .Alpha = 0
  End With
  
  gRect.UPPERLEFT = 1
  gRect.LOWERRIGHT = 0
  
  GradientFillRect cHdc, Vert(0), 2, gRect, 1, Direction
  
End Sub
Private Sub DrawFillRectangle(ByRef hRect As RECT, ByVal Color As Long, ByVal MyHdc As Long)
  
  Dim hBrush As Long
  
  hBrush = CreateSolidBrush(GetLngColor(Color))
  FillRect MyHdc, hRect, hBrush
  DeleteObject hBrush
  
End Sub
Private Sub RoundCorners(ByRef RcItem As RECT, ByVal m_hWnd As Long)
  
  Dim rgn1 As Long, rgn2 As Long, rgnNorm As Long
  
  rgnNorm = CreateRectRgn(0, 0, RcItem.Right, RcItem.Bottom)
  rgn2 = CreateRectRgn(0, 0, 0, 0)
  
  rgn1 = CreateRectRgn(0, 0, 2, 1)
  CombineRgn rgn2, rgnNorm, rgn1, RGN_DIFF
  DeleteObject rgn1
  rgn1 = CreateRectRgn(0, RcItem.Bottom, 2, RcItem.Bottom - 1)
  CombineRgn rgnNorm, rgn2, rgn1, RGN_DIFF
  DeleteObject rgn1
  rgn1 = CreateRectRgn(RcItem.Right, 0, RcItem.Right - 2, 1)
  CombineRgn rgn2, rgnNorm, rgn1, RGN_DIFF
  DeleteObject rgn1
  rgn1 = CreateRectRgn(RcItem.Right, RcItem.Bottom, RcItem.Right - 2, RcItem.Bottom - 1)
  CombineRgn rgnNorm, rgn2, rgn1, RGN_DIFF
  DeleteObject rgn1
  rgn1 = CreateRectRgn(0, 1, 1, 2)
  CombineRgn rgn2, rgnNorm, rgn1, RGN_DIFF
  DeleteObject rgn1
  rgn1 = CreateRectRgn(0, RcItem.Bottom - 1, 1, RcItem.Bottom - 2)
  CombineRgn rgnNorm, rgn2, rgn1, RGN_DIFF
  DeleteObject rgn1
  rgn1 = CreateRectRgn(RcItem.Right, 1, RcItem.Right - 1, 2)
  CombineRgn rgn2, rgnNorm, rgn1, RGN_DIFF
  DeleteObject rgn1
  rgn1 = CreateRectRgn(RcItem.Right, RcItem.Bottom - 1, RcItem.Right - 1, RcItem.Bottom - 2)
  CombineRgn rgnNorm, rgn2, rgn1, RGN_DIFF
  
  DeleteObject rgn1
  DeleteObject rgn2
  SetWindowRgn m_hWnd, rgnNorm, True
  DeleteObject rgnNorm
End Sub
Private Function ThDC(Width As Long, Height As Long) As Long
  If m_ThDC = 0 Then
    If (Width > 0) And (Height > 0) Then
        pCreate Width, Height
    End If
  Else
    If Width > m_lWidth Or Height > m_lHeight Then
        pCreate Width, Height
    End If
  End If
  ThDC = m_ThDC
End Function
Private Sub pCreate(ByVal Width As Long, ByVal Height As Long)
  Dim lhDCC As Long
  pDestroy
  lhDCC = CreateDC("DISPLAY", "", "", ByVal 0&)
  If Not (lhDCC = 0) Then
    m_ThDC = CreateCompatibleDC(lhDCC)
    If Not (m_ThDC = 0) Then
        m_hBmp = CreateCompatibleBitmap(lhDCC, Width, Height)
        If Not (m_hBmp = 0) Then
          m_hBmpOld = SelectObject(m_ThDC, m_hBmp)
          If Not (m_hBmpOld = 0) Then
            m_lWidth = Width
            m_lHeight = Height
            DeleteDC lhDCC
            Exit Sub
          End If
        End If
    End If
    DeleteDC lhDCC
    pDestroy
  End If
End Sub
Public Sub pDraw( _
  ByVal HDC As Long, _
  Optional ByVal xSrc As Long = 0, Optional ByVal ySrc As Long = 0, _
  Optional ByVal WidthSrc As Long = 0, Optional ByVal HeightSrc As Long = 0, _
  Optional ByVal xDst As Long = 0, Optional ByVal yDst As Long = 0 _
  )
  If WidthSrc <= 0 Then WidthSrc = m_lWidth
  If HeightSrc <= 0 Then HeightSrc = m_lHeight
  BitBlt HDC, xDst, yDst, WidthSrc, HeightSrc, m_ThDC, xSrc, ySrc, vbSrcCopy
  
End Sub
Private Sub pDestroy()
  If Not m_hBmpOld = 0 Then
    SelectObject m_ThDC, m_hBmpOld
    m_hBmpOld = 0
  End If
  If Not m_hBmp = 0 Then
    DeleteObject m_hBmp
    m_hBmp = 0
  End If
  If Not m_ThDC = 0 Then
    DeleteDC m_ThDC
    m_ThDC = 0
  End If
  m_lWidth = 0
  m_lHeight = 0
End Sub
Private Sub UserControl_Initialize()
  
  
  Dim fnt As New StdFont
  fnt.Name = "Tahoma"
  fnt.Size = 8
  Set Font = fnt
  
  With UserControl
    .BackColor = vbWhite
    .ScaleMode = vbPixels
  End With
  
  HDC = UserControl.HDC
  hwnd = UserControl.hwnd
  m_Max = 100
  m_Min = 0
  m_Value = 0
  m_Orientation = ccOrientationHorizontal
  m_Scrolling = ccScrollingStandard
  m_Color = GetLngColor(vbHighlight)
  DrawProgressBar
  
End Sub
Private Sub UserControl_Paint()
  
  Dim cRect As RECT
  
  DrawProgressBar
  
  With UserControl
    GetClientRect .hwnd, cRect
    RoundCorners cRect, .hwnd
  End With
  
End Sub
Private Sub UserControl_Resize()
  HDC = UserControl.HDC
End Sub
Private Sub UserControl_Terminate()
  pDestroy
End Sub
Public Property Get Color() As OLE_COLOR
  Color = m_Color
End Property
Public Property Let Color(ByVal lColor As OLE_COLOR)
  m_Color = GetLngColor(lColor)
End Property
Public Property Get Font() As IFont
  Set Font = m_fnt
End Property
Public Property Set Font(ByRef fnt As IFont)
  Set m_fnt = fnt
End Property
Public Property Let Font(ByRef fnt As IFont)
  Set m_fnt = fnt
End Property
Public Property Get hwnd() As Long
  hwnd = m_hWnd
End Property
Public Property Let hwnd(ByVal chWnd As Long)
  m_hWnd = chWnd
End Property
Public Property Get HDC() As Long
  HDC = m_hDC
End Property
Public Property Let HDC(ByVal cHdc As Long)
  
  m_hDC = ThDC(UserControl.ScaleWidth, UserControl.ScaleHeight)
  
  If m_hDC = 0 Then
    m_hDC = UserControl.HDC
  Else
    m_MemDC = True
  End If
End Property
Public Property Get Min() As Long
  Min = m_Min
End Property
Public Property Let Min(ByVal cMin As Long)
  m_Min = cMin
End Property
Public Property Get Max() As Long
  Max = m_Max
End Property
Public Property Let Max(ByVal cMax As Long)
  m_Max = cMax
End Property
Public Property Get Orientation() As cOrientation
  Orientation = m_Orientation
End Property
Public Property Let Orientation(ByVal cOrientation As cOrientation)
  m_Orientation = cOrientation
End Property
Public Property Get Scrolling() As cScrolling
  Scrolling = m_Scrolling
End Property
Public Property Let Scrolling(ByVal lScrolling As cScrolling)
  m_Scrolling = lScrolling
End Property
Public Property Get ShowText() As Boolean
  ShowText = m_ShowText
End Property
Public Property Let ShowText(ByVal bShowText As Boolean)
  m_ShowText = bShowText
  DrawProgressBar
End Property
Public Property Get Value() As Long
  Value = m_Value
End Property
Public Property Let Value(ByVal cValue As Long)
  m_Value = cValue
  DrawProgressBar
End Property
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  
  Color = PropBag.ReadProperty("Color", vbHighlight)
  Max = PropBag.ReadProperty("Max", 100)
  Min = PropBag.ReadProperty("Min", 0)
  Orientation = PropBag.ReadProperty("Orientation", ccOrientationHorizontal)
  Scrolling = PropBag.ReadProperty("Scrolling", ccScrollingStandard)
  ShowText = PropBag.ReadProperty("ShowText", False)
  Value = PropBag.ReadProperty("Value", 0)
  
End Sub
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  
  Call PropBag.WriteProperty("Color", m_Color, vbHighlight)
  Call PropBag.WriteProperty("Max", m_Max, 100)
  Call PropBag.WriteProperty("Min", m_Min, 0)
  Call PropBag.WriteProperty("Orientation", m_Orientation, ccOrientationHorizontal)
  Call PropBag.WriteProperty("Scrolling", m_Scrolling, ccScrollingStandard)
  Call PropBag.WriteProperty("ShowText", m_ShowText, False)
  Call PropBag.WriteProperty("Value", m_Value, 0)
  
End Sub
 