vbalprogressbar.ctl

使用vb寫出完美網頁遊戲外掛的原始碼分享

Dim hBr As Long
Dim hRgn As Long
Dim fPercent As Double
Dim bDrawText As Boolean
Dim hFntOld As Long
Dim iFnt As IFont
Dim i As Long
Dim lSegmentWidth As Long, lSegmentSpacing As Long
Dim bDrawnXpStyle As Boolean
Dim hTheme As Long
Dim hR As Long
Dim bDrawn As Boolean
Dim bDoDefault As Boolean
   
   GetClientRect m_hWnd, tR
   lWidth = Abs(tR.Right - tR.Left)
   lHeight = Abs(tR.Bottom - tR.Top)

   lhDCU = UserControl.hdc
   lHDC = m_cMemDC.hdc(lWidth, lHeight)
   If lHDC = 0 Then
      lHDC = lhDCU
   Else
      bMem = True
   End If
   
   bDoDefault = True
   RaiseEvent Draw(lHDC, tR.Left, tR.Top, lWidth, lHeight, bDoDefault)
   If bDoDefault Then
   
      ' Draw background:
      If pbPic(picBack) Then
         If m_eBackPictureMode = epbpTile Then
            TileArea lHDC, 0, 0, lWidth, lHeight, picBack.hdc, picBack.ScaleWidth \ Screen.TwipsPerPixelX, picBack.ScaleHeight \ Screen.TwipsPerPixelY, 0, 0
         Else
            StretchBlt lHDC, 0, 0, lWidth, lHeight, picBack.hdc, 0, 0, picBack.ScaleWidth \ Screen.TwipsPerPixelX, picBack.ScaleHeight \ Screen.TwipsPerPixelY, vbSrcCopy
         End If
      Else
         If (m_bXpStyle) Then
            On Error Resume Next
            hTheme = OpenThemeData(hwnd, StrPtr("Progress"))
            On Error GoTo 0
            If (hTheme <> 0) Then
               hR = GetThemeInt(hTheme, 0, 0, PROGRESSCHUNKSIZE, lSegmentWidth)
               If (hR = S_OK) Then
                  hR = GetThemeInt(hTheme, 0, 0, PROGRESSSPACESIZE, lSegmentSpacing)
                  If (hR = S_OK) Then
                     lSegmentWidth = lSegmentWidth + lSegmentSpacing
                     If (Width > Height) Then
                        hR = DrawThemeBackground(hTheme, lHDC, 1, 0, tR, tR)
                     Else
                        hR = DrawThemeBackground(hTheme, lHDC, 2, 0, tR, tR)
                     End If
                     If (hR = S_OK) Then
                        bDrawn = True
                     End If
                  End If
               End If
            End If
         End If
         
         If Not (bDrawn) Then
            lColor = UserControl.BackColor
            If lColor And &H80000000 Then
               hBr = GetSysColorBrush(lColor And &H1F&)
            Else
               hBr = CreateSolidBrush(lColor)
            End If
            FillRect lHDC, tR, hBr
            DeleteObject hBr
         End If
      End If
         
      If (m_bSegments) And Not (bDrawn) Then
         lSegmentWidth = 8
         lSegmentSpacing = 2
      End If
   
         
      LSet tWR = tR
      If m_eBorderStyle > epbsNone Then
         If bDrawn Then
            InflateRect tR, -1, -1
         Else
            If m_eAppearance = epba3D Then
               InflateRect tR, -2, -2
            Else
               InflateRect tR, -1, -1
            End If
         End If
      End If
      
      If (m_bShowText) And Len(m_sText) > 0 Then
         bDrawText = True
      End If
      If (bDrawText) And Not (bDrawn) Then
         Set iFnt = UserControl.Font
         hFntOld = SelectObject(lHDC, iFnt.hFont)
         SetBkMode lHDC, TRANSPARENT
         SetTextColor lHDC, TranslateColor(m_oForeColor)
         DrawText lHDC, " " & m_sText & " ", -1, tR, DT_SINGLELINE Or m_eTextAlignX Or m_eTextAlignY * 4
         SelectObject lHDC, hFntOld
      End If
      
      ' Draw bar:
      ' Get the bar rectangle:
      LSet tBR = tR
      fPercent = (m_lValue - m_lMin) / (m_lMax - m_lMin)
      If fPercent > 1# Then fPercent = 1#
      If fPercent < 0# Then fPercent = 0#
      If Width > Height Then
         tBR.Right = tR.Left + (tR.Right - tR.Left) * fPercent
         If (m_bSegments Or bDrawn) Then
            ' Quantise bar:
            tBR.Right = tBR.Right - ((tBR.Right - tBR.Left) Mod (lSegmentWidth + lSegmentSpacing))
            'Debug.Assert ((tBR.Right - tBR.Left) Mod (lSegmentWidth + lSegmentSpacing) = 0)
            If tBR.Right < tR.Left Then
               tBR.Right = tR.Left
            End If
         End If
      Else
         fPercent = 1# - fPercent
         tBR.Top = tR.Top + (tR.Bottom - tR.Top) * fPercent
         If (m_bSegments Or bDrawn) Then
            ' Quantise bar:
            tBR.Top = tBR.Top - ((tBR.Top - tBR.Bottom) Mod (lSegmentWidth + lSegmentSpacing))
            If tBR.Top > tR.Bottom Then
               tBR.Top = tR.Bottom
            End If
         End If
      End If
      
      If Not bDrawn Then
         hRgn = CreateRectRgnIndirect(tBR)
         SelectClipRgn lHDC, hRgn
      End If
      
      If pbPic(picBar) Then
         If m_eBarPictureMode = epbpTile Then
            TileArea lHDC, 0, tBR.Top, tBR.Right - tBR.Left, tBR.Bottom - tBR.Top, picBar.hdc, picBar.ScaleWidth \ Screen.TwipsPerPixelX, picBar.ScaleHeight \ Screen.TwipsPerPixelY, 0, 0
         Else
            StretchBlt lHDC, 0, 0, lWidth, lHeight, picBar.hdc, 0, 0, picBar.ScaleWidth \ Screen.TwipsPerPixelX, picBar.ScaleHeight \ Screen.TwipsPerPixelY, vbSrcCopy
         End If
      Else
         If bDrawn Then
            LSet tXPR = tBR
            InflateRect tXPR, -2, -2
            tXPR.Right = tXPR.Right + 1
            tXPR.Bottom = tXPR.Bottom + 1
            If (Width > Height) Then
               hR = DrawThemeBackground(hTheme, lHDC, 3, 0, tXPR, tXPR)
            Else
               hR = DrawThemeBackground(hTheme, lHDC, 4, 0, tXPR, tXPR)
            End If
         Else
            lColor = m_oBarColor
            If lColor And &H80000000 Then
               hBr = GetSysColorBrush(lColor And &H1F&)
            Else
               hBr = CreateSolidBrush(lColor)
            End If
            FillRect lHDC, tBR, hBr
            DeleteObject hBr
         End If
      End If
      
      If m_bSegments And Not bDrawn Then
         lColor = UserControl.BackColor
         If lColor And &H80000000 Then
            hBr = GetSysColorBrush(lColor And &H1F&)
         Else
            hBr = CreateSolidBrush(lColor)
         End If
         LSet tSR = tR
         If Width > Height Then
            For i = tBR.Left + lSegmentWidth To tBR.Right Step lSegmentWidth + lSegmentSpacing
               tSR.Left = i
               tSR.Right = i + lSegmentSpacing
               FillRect lHDC, tSR, hBr
            Next i
         Else
            For i = tBR.Bottom To tBR.Top + lSegmentWidth Step -(lSegmentWidth + lSegmentSpacing)
               tSR.Top = i
               tSR.Bottom = i + lSegmentSpacing
               FillRect lHDC, tSR, hBr
            Next i
         End If
         DeleteObject hBr
      End If
         
      If bDrawText Then
         Set iFnt = UserControl.Font
         hFntOld = SelectObject(lHDC, iFnt.hFont)
         If (bDrawn) Then
            Dim rcContent As RECT
            hR = GetThemeBackgroundContentRect(hTheme, _
                   lHDC, 0, 0, tR, rcContent)
            hR = DrawThemeText(hTheme, lHDC, 0, 0, _
               StrPtr(m_sText), -1, _
               DT_SINGLELINE Or m_eTextAlignX Or m_eTextAlignY * 4, _
               0, rcContent)
         Else
            SetBkMode lHDC, TRANSPARENT
            SetTextColor lHDC, TranslateColor(m_oBarForeColor)
            DrawText lHDC, " " & m_sText & " ", -1, _
               tR, DT_SINGLELINE Or m_eTextAlignX Or m_eTextAlignY * 4
         End If
         SelectObject lHDC, hFntOld
      End If
         
      If Not bDrawn Then
         SelectClipRgn lHDC, 0
         DeleteObject hRgn
         
         ' Draw border:
         Select Case m_eBorderStyle
         Case epbsRaised
            Select Case m_eAppearance
            Case epbaFlat
               Border lHDC, epbaFlat, tWR, True
            Case epba3DThin
               Border lHDC, epba3DThin, tR, True
            Case epba3D
               Border lHDC, epba3D, tWR, True
            End Select
         Case epbsInset
            Select Case m_eAppearance
            Case epbaFlat
               Border lHDC, epbaFlat, tWR, False
            Case epba3DThin
               Border lHDC, epba3DThin, tWR, False
            Case epba3D
               Border lHDC, epba3D, tWR, False
            End Select
         End Select
      End If
   
   End If
   
   ' Swap memdc<->Screen
   If bMem Then
      m_cMemDC.Draw lhDCU, 0, 0, lWidth, lHeight
   End If
   
   If (hTheme) Then
      CloseThemeData hTheme
   End If

End Sub

Private Function pbPic(ByVal picThis As PictureBox) As Boolean
   If Not (picThis.Picture Is Nothing) Then
      If Not picThis.Picture.handle = 0 Then
         pbPic = True
      End If
   End If
End Function
Private Sub Border( _
      ByVal lHDC As Long, _
      ByVal lStyle As Long, _
      ByRef tR As RECT, _
      ByVal bRaised As Boolean _
   )
Dim hPenDark As Long, hPenLight As Long, hPenBlack As Long
Dim hPenOld As Long
Dim tJunk As POINTAPI

   Select Case lStyle
   Case 0
      hPenBlack = CreatePen(0, 1, 0)
      hPenOld = SelectObject(lHDC, hPenBlack)
      MoveToEx lHDC, tR.Left, tR.Top, tJunk
      LineTo lHDC, tR.Right - 1, tR.Top
      LineTo lHDC, tR.Right - 1, tR.Bottom - 1
      LineTo lHDC, tR.Left, tR.Bottom - 1
      LineTo lHDC, tR.Left, tR.Top
      SelectObject lHDC, hPenOld
      DeleteObject hPenBlack
   Case 1
      hPenDark = CreatePen(0, 1, GetSysColor(vbButtonShadow And &H1F&))
      hPenLight = CreatePen(0, 1, GetSysColor(vb3DHighlight And &H1F&))
      If bRaised Then
         MoveToEx lHDC, tR.Left, tR.Bottom - 2, tJunk
         hPenOld = SelectObject(lHDC, hPenLight)
         LineTo lHDC, tR.Left, tR.Top
         LineTo lHDC, tR.Right - 1, tR.Top
         SelectObject lHDC, hPenOld
         MoveToEx lHDC, tR.Right - 1, tR.Top, tJunk
         hPenOld = SelectObject(lHDC, hPenDark)
         LineTo lHDC, tR.Right - 1, tR.Bottom - 1
         LineTo lHDC, tR.Left - 1, tR.Bottom - 1
         SelectObject lHDC, hPenOld
      Else