linegs.cls

一款另类的彩色图形复选框控件源代码(CheckBox2009) (v3)

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "LineGS"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
Attribute VB_Ext_KEY = "Member0" ,"SmoothLineDIB"
'****************************************************************************
'人人为我，我为人人
'枕善居汉化收藏整理
'发布日期：2009/04/18
'描    述：彩色图形复选框(CheckBox2009) (v3)
'网    站：http://www.Mndsoft.com/  (VB6源码博客)
'网    站：http://www.VbDnet.com/   (VB.NET源码博客,主要基于.NET2005)
'e-mail  ：[e-mail]
'e-mail  ：[e-mail]
'OICQ    ：88382850
'          如果您有新的好的代码别忘记给枕善居哦!
'****************************************************************************
'
Option Explicit

'Original TMT Pascal/Asm code by Jonas Widarsson
'
'Implemented in Vb6 by Dana Seaman
'Send comments/bug reports to [e-mail]
'
Public Enum cThickness
   Thin
   Thick
End Enum
Private Type RGBQUAD
   Blue                 As Byte
   Green                As Byte
   Red                  As Byte
   Reserved             As Byte
End Type

Private Type BITMAPINFOHEADER
   biSize               As Long
   biWidth              As Long
   biHeight             As Long
   biPlanes             As Integer
   biBitCount           As Integer
   biCompression        As Long
   biSizeImage          As Long
   biXPelsPerMeter      As Long
   biYPelsPerMeter      As Long
   biClrUsed            As Long
   biClrImportant       As Long
End Type

Private Type BITMAPINFO
   bmiHeader            As BITMAPINFOHEADER
End Type

Private Type RECT
   Left     As Long
   Top      As Long
   Right    As Long
   Bottom   As Long
End Type

Private Const DIB_RGB_COLORS As Long = 0
Private Const Pi        As Single = 3.141592
Private Const HalfPi    As Single = Pi / 2
Private Const cThin     As Single = Pi * 0.34
Private Const cThick    As Single = Pi * 0.17
Private Const Rads      As Single = Pi / 180
Private Const PS_SOLID  As Long = 0

Private Binfo           As BITMAPINFO
Private buf()           As RGBQUAD
Private InDIBits        As Boolean
Private Red             As Long
Private Green           As Long
Private Blue            As Long
Private m_Color         As Long
Private m_hDC           As Long
Private m_W1            As Long
Private m_H1            As Long
Private m_Handle        As Long

Private Declare Function Arc Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long, ByVal X4 As Long, ByVal Y4 As Long) As Long
Private Declare Function OleTranslateColor Lib "OLEPRO32.DLL" (ByVal OLE_COLOR As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y 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 GetDIBits Lib "gdi32" (ByVal hdc As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function SetDIBits Lib "gdi32" (ByVal hdc As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long

'Public Sub Widget(rct As RECT)

'End Sub
Private Function TranslateColour(ByVal clr As OLE_COLOR, _
   Optional hPal As Long = 0) As Long
   If OleTranslateColor(clr, hPal, TranslateColour) Then
      TranslateColour = vbBlack 'CLR_INVALID
   End If
End Function

Public Sub DIB(ByVal hdc As Long, ByVal Handle As Long, ByVal W1 As Long, ByVal H1 As Long)
   m_hDC = hdc
   m_Handle = Handle
   m_W1 = W1
   m_H1 = H1
   Pic2Array
End Sub

Private Sub Pic2Array()
   ReDim buf(0 To (m_W1 - 1), m_H1 - 1) As RGBQUAD
   With Binfo.bmiHeader
      .biSize = 40
      .biWidth = m_W1
      .biHeight = -m_H1
      .biPlanes = 1
      .biBitCount = 32
      .biCompression = 0
      .biClrUsed = 0
      .biClrImportant = 0
      .biSizeImage = m_W1 * m_H1
   End With
   'Copy hDC to Array
   GetDIBits m_hDC, m_Handle, 0, m_H1, buf(0, 0), Binfo, DIB_RGB_COLORS
   'Set local flag
   InDIBits = True
End Sub

Public Sub CircleGP(ByVal hdc As Long, _
   ByVal X1 As Long, _
   ByVal Y1 As Long, _
   ByVal RadiusX As Long, _
   ByVal RadiusY As Long, _
   ByVal Color As OLE_COLOR, _
   Optional ByVal Thickness As cThickness = Thick)

   Dim Bbg              As Byte
   Dim Gbg              As Byte
   Dim Rbg              As Byte
   Dim savAlpha(1 To 4) As Byte
   Dim Bblend           As Long
   Dim Bgr              As Long
   Dim Cl               As Long
   Dim Gblend           As Long
   Dim Strength         As Long
   Dim StrengthI        As Long
   Dim Quadrant         As Long
   Dim Radius           As Long
   Dim Rblend           As Long
   Dim RX1              As Long
   Dim RX2              As Long
   Dim RY1              As Long
   Dim RY2              As Long
   Dim savX(1 To 4)     As Long
   Dim savY(1 To 4)     As Long
   Dim X4               As Long
   Dim Y4               As Long
   Dim NewColor         As Long
   Dim Ax               As Single
   Dim Ay               As Single
   Dim Bx               As Single
   Dim By               As Single
   Dim L1               As Single
   Dim L2               As Single
   Dim L3               As Single
   Dim L4               As Single
   Dim sngAngle         As Single
   Dim sngPointSpacing  As Single
   Dim X2               As Single
   Dim Xp5              As Single
   Dim Y2               As Single

   m_hDC = hdc

   SetRGBComponents Color

   Radius = RadiusX
   If RadiusY > RadiusX Then
      Radius = RadiusY
   End If

   sngPointSpacing = GetPointSpacing(Radius, Thickness)

   For sngAngle = 0 To HalfPi Step sngPointSpacing
      X2 = RadiusX * Cos(sngAngle)
      Y2 = RadiusY * Sin(sngAngle)
      'Prevents error when vb rounds .5 down
      If X2 = Int(X2) Then X2 = X2 + 0.001
      If Y2 = Int(Y2) Then Y2 = Y2 + 0.001
      For Quadrant = 0 To 3
         Select Case Quadrant
            Case 0 '0-90