home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 6_2008-2009.ISO / data / zips / Boring_ana2164141022009.psc / LineGS.cls < prev   
Text File  |  2009-09-29  |  8KB  |  250 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "LineGS"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
  15. Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
  16. Attribute VB_Ext_KEY = "Member0" ,"SmoothLineDIB"
  17. Option Explicit
  18.  
  19. 'Original TMT Pascal/Asm code by Jonas Widarsson
  20. '
  21. 'Implemented in Vb6 by Dana Seaman
  22. 'Send comments/bug reports to dseaman@ieg.com.br
  23. '
  24. 'REVISION HISTORY
  25. '26-Jan-2002 Created LineGP  Method
  26. '28-Jan-2002 Created LineDIB Method
  27. '........... Created Class
  28. '........... Optimized code
  29. '05-Apr-2002 First Release to PSC *(Deleted by Hacker)
  30. '09-Apr-2002 Improved speed, more comments and error handling
  31. '11-Apr-2002 Added 3D clock hands
  32. '12-Apr-2002 Improved clock timer event handler
  33. '14-Apr-2002 Added Circle/Ellipse draw
  34. '16-Apr-2002 Circle/Ellipse draw by Quadrants
  35. '19-Apr-2002 Changed to RGBQuad (easier to understand DIBits)
  36. '22-Apr-2002 Added circle thick/thin
  37. '26-Apr-2002 Pass hDC together with LineGP/CircleGp
  38. '........... Simplified blending code
  39. '........... Common SetRGBComponents Sub
  40. '28-Apr-2002 Added Arc drawing
  41. '........... Several tweaks/speedups
  42. '30-May-2002 Added Rounded Rectangle
  43. '01-Jun-2002 Bevel/3D Rounded Rectangle
  44. Public Enum cThickness
  45.    Thin
  46.    Thick
  47. End Enum
  48. Private Type RGBQUAD
  49.    Blue                 As Byte
  50.    Green                As Byte
  51.    Red                  As Byte
  52.    Reserved             As Byte
  53. End Type
  54.  
  55. Private Type BITMAPINFOHEADER
  56.    biSize               As Long
  57.    biWidth              As Long
  58.    biHeight             As Long
  59.    biPlanes             As Integer
  60.    biBitCount           As Integer
  61.    biCompression        As Long
  62.    biSizeImage          As Long
  63.    biXPelsPerMeter      As Long
  64.    biYPelsPerMeter      As Long
  65.    biClrUsed            As Long
  66.    biClrImportant       As Long
  67. End Type
  68.  
  69. Private Type BITMAPINFO
  70.    bmiHeader            As BITMAPINFOHEADER
  71. End Type
  72.  
  73. Private Type RECT
  74.    Left     As Long
  75.    Top      As Long
  76.    Right    As Long
  77.    Bottom   As Long
  78. End Type
  79.  
  80. Private Const DIB_RGB_COLORS As Long = 0
  81. Private Const Pi        As Single = 3.141592
  82. Private Const HalfPi    As Single = Pi / 2
  83. Private Const cThin     As Single = Pi * 0.34
  84. Private Const cThick    As Single = Pi * 0.17
  85. Private Const Rads      As Single = Pi / 180
  86. Private Const PS_SOLID  As Long = 0
  87.  
  88. Private Binfo           As BITMAPINFO
  89. Private buf()           As RGBQUAD
  90. Private InDIBits        As Boolean
  91. Private Red             As Long
  92. Private Green           As Long
  93. Private Blue            As Long
  94. Private m_Color         As Long
  95. Private m_hDC           As Long
  96. Private m_W1            As Long
  97. Private m_H1            As Long
  98. Private m_Handle        As Long
  99.  
  100. 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
  101. Private Declare Function OleTranslateColor Lib "olepro32.dll" (ByVal OLE_COLOR As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long
  102. Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
  103. Private Declare Function SetPixelV Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
  104. 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
  105. 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
  106.  
  107. 'Public Sub Widget(rct As RECT)
  108.  
  109. 'End Sub
  110. Private Function TranslateColour(ByVal clr As OLE_COLOR, _
  111.    Optional hPal As Long = 0) As Long
  112.    If OleTranslateColor(clr, hPal, TranslateColour) Then
  113.       TranslateColour = vbBlack 'CLR_INVALID
  114.    End If
  115. End Function
  116.  
  117. Public Sub DIB(ByVal hdc As Long, ByVal Handle As Long, ByVal W1 As Long, ByVal H1 As Long)
  118.    m_hDC = hdc
  119.    m_Handle = Handle
  120.    m_W1 = W1
  121.    m_H1 = H1
  122.    Pic2Array
  123. End Sub
  124.  
  125. Private Sub Pic2Array()
  126.    ReDim buf(0 To (m_W1 - 1), m_H1 - 1) As RGBQUAD
  127.    With Binfo.bmiHeader
  128.       .biSize = 40
  129.       .biWidth = m_W1
  130.       .biHeight = -m_H1
  131.       .biPlanes = 1
  132.       .biBitCount = 32
  133.       .biCompression = 0
  134.       .biClrUsed = 0
  135.       .biClrImportant = 0
  136.       .biSizeImage = m_W1 * m_H1
  137.    End With
  138.    'Copy hDC to Array
  139.    GetDIBits m_hDC, m_Handle, 0, m_H1, buf(0, 0), Binfo, DIB_RGB_COLORS
  140.    'Set local flag
  141.    InDIBits = True
  142. End Sub
  143.  
  144. Public Sub CircleGP(ByVal hdc As Long, _
  145.    ByVal X1 As Long, _
  146.    ByVal Y1 As Long, _
  147.    ByVal RadiusX As Long, _
  148.    ByVal RadiusY As Long, _
  149.    ByVal Color As OLE_COLOR, _
  150.    Optional ByVal Thickness As cThickness = Thick)
  151.  
  152.    Dim Bbg              As Byte
  153.    Dim Gbg              As Byte
  154.    Dim Rbg              As Byte
  155.    Dim savAlpha(1 To 4) As Byte
  156.    Dim Bblend           As Long
  157.    Dim Bgr              As Long
  158.    Dim Cl               As Long
  159.    Dim Gblend           As Long
  160.    Dim Strength         As Long
  161.    Dim StrengthI        As Long
  162.    Dim Quadrant         As Long
  163.    Dim Radius           As Long
  164.    Dim Rblend           As Long
  165.    Dim RX1              As Long
  166.    Dim RX2              As Long
  167.    Dim RY1              As Long
  168.    Dim RY2              As Long
  169.    Dim savX(1 To 4)     As Long
  170.    Dim savY(1 To 4)     As Long
  171.    Dim X4               As Long
  172.    Dim Y4               As Long
  173.    Dim NewColor         As Long
  174.    Dim Ax               As Single
  175.    Dim Ay               As Single
  176.    Dim Bx               As Single
  177.    Dim By               As Single
  178.    Dim L1               As Single
  179.    Dim L2               As Single
  180.    Dim L3               As Single
  181.    Dim L4               As Single
  182.    Dim sngAngle         As Single
  183.    Dim sngPointSpacing  As Single
  184.    Dim X2               As Single
  185.    Dim Xp5              As Single
  186.    Dim Y2               As Single
  187.  
  188.    m_hDC = hdc
  189.  
  190.    SetRGBComponents Color
  191.  
  192.    Radius = RadiusX
  193.    If RadiusY > RadiusX Then
  194.       Radius = RadiusY
  195.    End If
  196.  
  197.    sngPointSpacing = GetPointSpacing(Radius, Thickness)
  198.  
  199.    For sngAngle = 0 To HalfPi Step sngPointSpacing
  200.       X2 = RadiusX * Cos(sngAngle)
  201.       Y2 = RadiusY * Sin(sngAngle)
  202.       'Prevents error when vb rounds .5 down
  203.       If X2 = Int(X2) Then X2 = X2 + 0.001
  204.       If Y2 = Int(Y2) Then Y2 = Y2 + 0.001
  205.       For Quadrant = 0 To 3
  206.          Select Case Quadrant
  207.             Case 0 '0-90░
  208.                Ax = X2 + X1 - 0.5
  209.                Ay = -Y2 + Y1 - 0.5
  210.             Case 1 '90-180░
  211.                Ax = X2 + X1 - 0.5
  212.                Ay = Y2 + Y1 - 0.5
  213.             Case 2 '180-270░
  214.                Ax = -X2 + X1 - 0.5
  215.                Ay = Y2 + Y1 - 0.5
  216.             Case 3 '270-360░
  217.                Ax = -X2 + X1 - 0.5
  218.                Ay = -Y2 + Y1 - 0.5
  219.          End Select
  220.          Bx = Ax + 1
  221.          By = Ay + 1
  222.          RX1 = Ax
  223.          RX2 = RX1 + 1
  224.          Xp5 = RX1 + 0.5
  225.          RY1 = Ay
  226.          RY2 = By
  227.          L1 = RY1 + 0.5 - Ay
  228.          L2 = 256 * (Xp5 - Ax) - Xp5 + Ax
  229.          L3 = 255 - L2
  230.          L4 = By - RY2 + 0.5
  231.          savX(1) = RX1
  232.          savY(1) = RY1
  233.          savX(2) = RX2
  234.          savY(2) = RY1
  235.          savY(3) = RY2
  236.          savX(3) = RX1
  237.          savY(4) = RY2
  238.          savX(4) = RX2
  239.          savAlpha(1) = L1 * L2
  240.          savAlpha(2) = L1 * L3
  241.          savAlpha(3) = L4 * L2
  242.          savAlpha(4) = L4 * L3
  243.  
  244.          For Cl = 1 To 4
  245.             Strength = savAlpha(Cl)
  246.             X4 = savX(Cl)
  247.             Y4 = savY(Cl)
  248.             If Strength > 252 Then '> 99%
  249.                SetPixelV m_hDC, X4, Y4,res=ate Su- 0.5
  250.   el@Ls=ate Su-1