vbAccelerator - Contents of code file: frmLeakyApp.frm

VERSION 5.00
Begin VB.Form frmLeakyApp 
   Caption         =   "Leaky GDI Application"
   ClientHeight    =   3300
   ClientLeft      =   5565
   ClientTop       =   3195
   ClientWidth     =   5475
   Icon            =   "frmLeakyApp.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   3300
   ScaleWidth      =   5475
   Begin VB.CheckBox chkStopLeaking 
      Caption         =   "&Stop the leak"
      BeginProperty Font 
         Name            =   "Tahoma"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   255
      Left            =   120
      TabIndex        =   2
      Top             =   720
      Width           =   5175
   End
   Begin VB.PictureBox picPaint 
      AutoRedraw      =   -1  'True
      BeginProperty Font 
         Name            =   "Tahoma"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   2175
      Left            =   60
      ScaleHeight     =   2115
      ScaleWidth      =   5235
      TabIndex        =   1
      Top             =   1020
      Width           =   5295
   End
   Begin VB.Label lblInfo 
      Caption         =   $"frmLeakyApp.frx":030A
      BeginProperty Font 
         Name            =   "Tahoma"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   615
      Left            =   120
      TabIndex        =   0
      Top             =   60
      Width           =   5175
   End
End
Attribute VB_Name = "frmLeakyApp"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Type POINTAPI
   x As Long
   y As Long
End Type
Private Type RECT
   left As Long
   top As Long
   right As Long
   bottom As Long
End Type
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long)
 As Long
' Pen functions:
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal
 nWidth As Long, ByVal crColor As Long) As Long
    Private Const PS_DASH = 1
    Private Const PS_DASHDOT = 3
    Private Const PS_DASHDOTDOT = 4
    Private Const PS_DOT = 2
    Private Const PS_SOLID = 0
    Private Const PS_NULL = 5
Private Declare Function GetSysColorBrush Lib "user32" (ByVal nIndex As Long)
 As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As
 Long, ByVal y As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As
 Long, ByVal y As Long, lpPoint As POINTAPI) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As
 RECT, ByVal hBrush As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal
 hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As
 Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect
 As RECT) As Long
Private Declare Function InflateRect Lib "user32" (lpRect As RECT, ByVal x As
 Long, ByVal y As Long) As Long


Private m_boxSize As Long

Private Sub Form_Load()
   
   m_boxSize = 48
      
End Sub

Private Sub RGBToHLS( _
     ByVal r As Long, ByVal g As Long, ByVal b As Long, _
     h As Single, s As Single, l As Single _
     )
 Dim Max As Single
 Dim Min As Single
 Dim delta As Single
 Dim rR As Single, rG As Single, rB As Single

     rR = r / 255: rG = g / 255: rB = b / 255

 '{Given: rgb each in [0,1].
 ' Desired: h in [0,360] and s in [0,1], except if s=0, then h=UNDEFINED.}
         Max = Maximum(rR, rG, rB)
         Min = Minimum(rR, rG, rB)
             l = (Max + Min) / 2 '{This is the lightness}
         '{Next calculate saturation}
         If Max = Min Then
             'begin {Acrhomatic case}
             s = 0
             h = 0
             'end {Acrhomatic case}
         Else
             'begin {Chromatic case}
                 '{First calculate the saturation.}
             If l <= 0.5 Then
                 s = (Max - Min) / (Max + Min)
             Else
                 s = (Max - Min) / (2 - Max - Min)
             End If
             '{Next calculate the hue.}
             delta = Max - Min
             If rR = Max Then
                     h = (rG - rB) / delta '{Resulting color is between yellow
                      and magenta}
             ElseIf rG = Max Then
                 h = 2 + (rB - rR) / delta '{Resulting color is between cyan
                  and yellow}
             ElseIf rB = Max Then
                 h = 4 + (rR - rG) / delta '{Resulting color is between magenta
                  and cyan}
             End If
         'end {Chromatic Case}
     End If
 End Sub

 Private Sub HLSToRGB( _
     ByVal h As Single, ByVal s As Single, ByVal l As Single, _
     r As Long, g As Long, b As Long _
     )
 Dim rR As Single, rG As Single, rB As Single
 Dim Min As Single, Max As Single

     If s = 0 Then
     ' Achromatic case:
     rR = l: rG = l: rB = l
     Else
     ' Chromatic case:
     ' delta = Max-Min
     If l <= 0.5 Then
         's = (Max - Min) / (Max + Min)
         ' Get Min value:
         Min = l * (1 - s)
     Else
         's = (Max - Min) / (2 - Max - Min)
         ' Get Min value:
         Min = l - s * (1 - l)
     End If
     ' Get the Max value:
     Max = 2 * l - Min
     
     ' Now depending on sector we can evaluate the h,l,s:
     If (h < 1) Then
         rR = Max
         If (h < 0) Then
             rG = Min
             rB = rG - h * (Max - Min)
         Else
             rB = Min
             rG = h * (Max - Min) + rB
         End If
     ElseIf (h < 3) Then
         rG = Max
         If (h < 2) Then
             rB = Min
             rR = rB - (h - 2) * (Max - Min)
         Else
             rR = Min
             rB = (h - 2) * (Max - Min) + rR
         End If
     Else
         rB = Max
         If (h < 4) Then
             rR = Min
             rG = rR - (h - 4) * (Max - Min)
         Else
             rG = Min
             rR = (h - 4) * (Max - Min) + rG
         End If
         
     End If
             
     End If
     r = rR * 255: g = rG * 255: b = rB * 255
 End Sub
 Private Function Maximum(rR As Single, rG As Single, rB As Single) As Single
     If (rR > rG) Then
     If (rR > rB) Then
         Maximum = rR
     Else
         Maximum = rB
     End If
     Else
     If (rB > rG) Then
         Maximum = rB
     Else
         Maximum = rG
     End If
     End If
 End Function
 Private Function Minimum(rR As Single, rG As Single, rB As Single) As Single
     If (rR < rG) Then
     If (rR < rB) Then
         Minimum = rR
     Else
         Minimum = rB
     End If
     Else
     If (rB < rG) Then
         Minimum = rB
     Else
         Minimum = rG
     End If
 End If
 End Function



Private Sub Form_Resize()
   On Error Resume Next
   picPaint.Move picPaint.left, picPaint.top, _
      Me.ScaleWidth - picPaint.left * 2, _
      Me.ScaleHeight - picPaint.top - 2 * Screen.TwipsPerPixelY
End Sub

Private Sub picPaint_Resize()
   
   Dim s As Single
   Dim h As Single
   Dim l As Single
   Dim x As Long
   Dim y As Long
   Dim xMax As Long
   Dim yMax As Long
   Dim lColor As Long
   Dim lLastColor As Long
   Dim hBr As Long
   Dim hPen As Long
   Dim hPenOld As Long
   Dim tR As RECT
   Dim lhDC As Long
   Dim xBoxes As Long
   Dim yBoxes As Long
   Dim numBoxes As Long
   Dim lumStep As Single
   Dim r As Long
   Dim b As Long
   Dim g As Long
   Dim tBoxR As RECT
   Dim tBoxOutR As RECT
   Dim tJunk As POINTAPI
   
   lhDC = picPaint.hdc
   
   GetClientRect picPaint.hwnd, tR
   xMax = tR.right - tR.left
   yMax = tR.bottom - tR.top
   
   ' Fill background with window:
   hBr = GetSysColorBrush((vbWindowBackground And &H1F&))
   FillRect lhDC, tR, hBr
   
   ' Get initial hue & saturation:
   RGBToHLS 37, 130, 156, h, s, l
   
   ' Draw a series of boxes of the colour:
   l = 0
   xBoxes = xMax \ m_boxSize
   yBoxes = yMax \ m_boxSize
   numBoxes = xBoxes * yBoxes + 1
   lumStep = 1# / numBoxes
   
   For x = 0 To xBoxes - 1
      tBoxR.left = x * m_boxSize
      tBoxR.right = tBoxR.left + m_boxSize
      For y = 0 To yBoxes - 1
         tBoxR.top = y * m_boxSize
         tBoxR.bottom = tBoxR.top + m_boxSize
         
         LSet tBoxOutR = tBoxR
         InflateRect tBoxOutR, -2, -2
         
         HLSToRGB h, s, l, r, g, b
         
         hBr = CreateSolidBrush(RGB(r, g, b))
         FillRect lhDC, tBoxOutR, hBr
         DeleteObject hBr
                           
         HLSToRGB h, s, (l * 0.95), r, g, b
         If (hPen) Then
            SelectObject lhDC, hPenOld
            DeleteObject hPen
         End If
         hPen = CreatePen(PS_SOLID, 1, RGB(r, g, b))
         hPenOld = SelectObject(lhDC, hPen)
         MoveToEx lhDC, tBoxOutR.left, tBoxOutR.top, tJunk
         LineTo lhDC, tBoxOutR.right - 1, tBoxOutR.top
         LineTo lhDC, tBoxOutR.right - 1, tBoxOutR.bottom - 1
         LineTo lhDC, tBoxOutR.left, tBoxOutR.bottom - 1
         LineTo lhDC, tBoxOutR.left, tBoxOutR.top
         
         l = l + lumStep
      Next y
   Next x
   
   If (chkStopLeaking.Value = Checked) Then
      ' ensure we clear up the last pen
      If (hPen) Then
         SelectObject lhDC, hPenOld
         DeleteObject hPen
      End If
   End If
   
   picPaint.Refresh
End Sub