`RGB.CLS
Option Explicit

Private mlngColor As Long

`~~~Color
Property Let Color(lngColor As Long)
    mlngColor = lngColor
End Property
`~~~Red
Property Get Red() As Byte
    Red = mlngColor And &HFF
End Property

`~~~Green
Property Get Green() As Byte
    Green = (mlngColor \ &H100) And &HFF
End Property

`~~~Blue
Property Get Blue() As Byte
    Blue = (mlngColor \ &H10000) And &HFF
End Property

Option Explicit

Private Sub Form_Click()
    Dim rgbTest As New RGB
    Dim lColor As Long
    'Combine R,G,and B to create a known color value
    lColor = RGB(17, 53, 220)
    Print "Color:", lColor
    'Use RGB object to extract component colors
    rgbTest.Color = lColor
    Print "Red:", rgbTest.Red
    Print "Green:", rgbTest.Green
    Print "Blue:", rgbTest.Blue
End Sub

`HSV.CLS
Option Explicit

`RGB color properties
Private mintRed As Integer
Private mintGreen As Integer
Private mintBlue As Integer

`HSV color properties
Private msngHue As Single
Private msngSaturation As Single
Private msngValue As Single

`Keep track of implied conversion
Private mintCalc As Integer
Private Const RGB2HSV = 1
Private Const HSV2RGB = 2

`~~~ Hue
Property Let Hue(intHue As Integer)
    msngHue = intHue
    mintCalc = HSV2RGB
End Property

Property Get Hue() As Integer
    If mintCalc = RGB2HSV Then CalcHSV
    Hue = msngHue
End Property

`~~~ Saturation
Property Let Saturation(intSaturation As Integer)
    msngSaturation = intSaturation
    mintCalc = HSV2RGB
End Property

Property Get Saturation() As Integer
    If mintCalc = RGB2HSV Then CalcHSV
    Saturation = msngSaturation
End Property

`~~~ Value
Property Let Value(intValue As Integer)
    msngValue = intValue
    mintCalc = HSV2RGB
End Property

Property Get Value() As Integer
    If mintCalc = RGB2HSV Then CalcHSV
    Value = msngValue
End Property

`~~~ Red
Property Let Red(intRed As Integer)
    mintRed = intRed
    mintCalc = RGB2HSV
End Property

Property Get Red() As Integer
    If mintCalc = HSV2RGB Then CalcRGB
    Red = mintRed
End Property

`~~~ Green
Property Let Green(intGreen As Integer)
    mintGreen = intGreen
    mintCalc = RGB2HSV
End Property

Property Get Green() As Integer
    If mintCalc = HSV2RGB Then CalcRGB
    Green = mintGreen
End Property

`~~~ Blue
Property Let Blue(intBlue As Integer)
    mintBlue = intBlue
    mintCalc = RGB2HSV
End Property

Property Get Blue() As Integer
    If mintCalc = HSV2RGB Then CalcRGB
    Blue = mintBlue
End Property

`Converts RGB to HSV
Private Sub CalcHSV()
    Dim sngRed As Single
    Dim sngGreen As Single
    Dim sngBlue As Single
    Dim sngMx As Single
    Dim sngMn As Single
    Dim sngDelta As Single
    Dim sngVa As Single
    Dim sngSa As Single
    Dim sngRc As Single
    Dim sngGc As Single
    Dim sngBc As Single
    sngRed = mintRed / 255
    sngGreen = mintGreen / 255
    sngBlue = mintBlue / 255
    sngMx = sngRed
    If sngGreen > sngMx Then sngMx = sngGreen
    If sngBlue > sngMx Then sngMx = sngBlue
    sngMn = sngRed
    If sngGreen < sngMn Then sngMn = sngGreen
    If sngBlue < sngMn Then sngMn = sngBlue
    sngDelta = sngMx - sngMn
    sngVa = sngMx
    If sngMx Then
        sngSa = sngDelta / sngMx
    Else
        sngSa = 0
    End If
    If sngSa = 0 Then
        msngHue = 0
    Else
        sngRc = (sngMx - sngRed) / sngDelta
        sngGc = (sngMx - sngGreen) / sngDelta
        sngBc = (sngMx - sngBlue) / sngDelta
        Select Case sngMx
        Case sngRed
            msngHue = sngBc - sngGc
        Case sngGreen
            msngHue = 2 + sngRc - sngBc
        Case sngBlue
            msngHue = 4 + sngGc - sngRc
        End Select
        msngHue = msngHue * 60
        If msngHue < 0 Then msngHue = msngHue + 360
    End If
    msngSaturation = sngSa * 100
    msngValue = sngVa * 100
    mintCalc = 0
End Sub

`Converts HSV to RGB
Private Sub CalcRGB()
    Dim sngSaturation As Single
    Dim sngValue As Single
    Dim sngHue As Single
    Dim intI As Integer
    Dim sngF As Single
    Dim sngP As Single
    Dim sngQ As Single
    Dim sngT As Single
    Dim sngRed As Single
    Dim sngGreen As Single
    Dim sngBlue As Single
    sngSaturation = msngSaturation / 100
    sngValue = msngValue / 100
    If msngSaturation = 0 Then
        sngRed = sngValue
        sngGreen = sngValue
        sngBlue = sngValue
    Else
        sngHue = msngHue / 60
        If sngHue = 6 Then sngHue = 0
        intI = Int(sngHue)
        sngF = sngHue - intI
        sngP = sngValue * (1! - sngSaturation)
        sngQ = sngValue * (1! - (sngSaturation * sngF))
        sngT = sngValue * (1! - (sngSaturation * (1! - sngF)))
        Select Case intI
        Case 0
            sngRed = sngValue
            sngGreen = sngT
            sngBlue = sngP
        Case 1
            sngRed = sngQ
            sngGreen = sngValue
            sngBlue = sngP
        Case 2
            sngRed = sngP
            sngGreen = sngValue
            sngBlue = sngT

        Case 3
            sngRed = sngP
            sngGreen = sngQ
            sngBlue = sngValue
        Case 4
            sngRed = sngT
            sngGreen = sngP
            sngBlue = sngValue
        Case 5
            sngRed = sngValue
            sngGreen = sngP
            sngBlue = sngQ
        End Select
    End If

    mintRed = Int(255.9999 * sngRed)
    mintGreen = Int(255.9999 * sngGreen)
    mintBlue = Int(255.9999 * sngBlue)
    mintCalc = 0
End Sub

`HSL.CLS
Option Explicit

`RGB color properties
Private mintRed As Integer
Private mintGreen As Integer
Private mintBlue As Integer

`HSL color properties
Private msngHue As Single
Private msngSaturation As Single
Private msngLuminosity As Single
`Keep track of implied conversion
Private mintCalc As Integer
Private Const RGB2HSL = 1
Private Const HSL2RGB = 2

`~~~ Hue
Property Let Hue(intHue As Integer)
    msngHue = (intHue / 240!) * 360!
    mintCalc = HSL2RGB
End Property
Property Get Hue() As Integer
    If mintCalc = RGB2HSL Then CalcHSL
    Hue = (msngHue / 360!) * 240!
End Property

`~~~ Saturation
Property Let Saturation(intSaturation As Integer)
    msngSaturation = intSaturation / 240!
    mintCalc = HSL2RGB
End Property

Property Get Saturation() As Integer
    If mintCalc = RGB2HSL Then CalcHSL
    Saturation = msngSaturation * 240!
End Property

`~~~ Luminosity
Property Let Luminosity(intLuminosity As Integer)
    msngLuminosity = intLuminosity / 240!
    mintCalc = HSL2RGB
End Property

Property Get Luminosity() As Integer
    If mintCalc = RGB2HSL Then CalcHSL
    Luminosity = msngLuminosity * 240!
End Property

`~~~ Red
Property Let Red(intRed As Integer)
    mintRed = intRed
    mintCalc = RGB2HSL
End Property

Property Get Red() As Integer
    If mintCalc = HSL2RGB Then CalcRGB
    Red = mintRed
End Property

`~~~ Green
Property Let Green(intGreen As Integer)
    mintGreen = intGreen
    mintCalc = RGB2HSL
End Property

Property Get Green() As Integer
    If mintCalc = HSL2RGB Then CalcRGB
    Green = mintGreen
End Property

`~~~ Blue
Property Let Blue(intBlue As Integer)
    mintBlue = intBlue
    mintCalc = RGB2HSL
End Property
Property Get Blue() As Integer
    If mintCalc = HSL2RGB Then CalcRGB
    Blue = mintBlue
End Property

Private Sub CalcHSL()
    Dim sngMx As Single
    Dim sngMn As Single
    Dim sngDelta As Single
    Dim sngPctRed As Single
    Dim sngPctGrn As Single
    Dim sngPctBlu As Single
    sngPctRed = mintRed / 255
    sngPctGrn = mintGreen / 255
    sngPctBlu = mintBlue / 255
    sngMx = sngMaxOf(sngMaxOf(sngPctRed, sngPctGrn), sngPctBlu)
    sngMn = sngMinOf(sngMinOf(sngPctRed, sngPctGrn), sngPctBlu)
    sngDelta = sngMx - sngMn
    msngLuminosity = (sngMx + sngMn) / 2
    If sngMx = sngMn Then
        msngSaturation = 0
    Else
        msngSaturation = 1
    End If
    If msngLuminosity <= 0.5 Then
        If msngSaturation > 0 Then
            msngSaturation = sngDelta / (sngMx + sngMn)
        End If
    Else
        If msngSaturation > 0 Then
            msngSaturation = sngDelta / (2 - sngMx - sngMn)
        End If
    End If

    If msngSaturation Then
        If sngPctRed = sngMx Then
            msngHue = (sngPctGrn - sngPctBlu) / sngDelta
        End If
        If sngPctGrn = sngMx Then
            msngHue = 2 + (sngPctBlu - sngPctRed) / sngDelta
        End If
        If sngPctBlu = sngMx Then
            msngHue = 4 + (sngPctRed - sngPctGrn) / sngDelta
        End If
        msngHue = msngHue * 60
    End If
    If msngHue < 0 Then msngHue = msngHue + 360
    mintCalc = 0
End Sub

Private Sub CalcRGB()
    Dim sngM1 As Single
    Dim sngM2 As Single
    Dim sngPctRed As Single
    Dim sngPctGrn As Single
    Dim sngPctBlu As Single
    If msngLuminosity <= 0.5 Then
        sngM2 = msngLuminosity * (1! + msngSaturation)
    Else
        sngM2 = (msngLuminosity + msngSaturation) _
            - (msngLuminosity * msngSaturation)
    End If
    sngM1 = 2! * msngLuminosity - sngM2
    If msngSaturation = 0! Then
        sngPctRed = msngLuminosity
        sngPctGrn = msngLuminosity
        sngPctBlu = msngLuminosity
    Else
        sngPctRed = rgbVal(sngM1, sngM2, msngHue + 120!)
        sngPctGrn = rgbVal(sngM1, sngM2, msngHue)
        sngPctBlu = rgbVal(sngM1, sngM2, msngHue - 120!)
    End If
    mintRed = Int(255.9999 * sngPctRed)
    mintGreen = Int(255.9999 * sngPctGrn)
    mintBlue = Int(255.9999 * sngPctBlu)
    mintCalc = 0
End Sub

Private Function rgbVal(sngN1 As Single, sngN2 As Single, _
sngHue As Single) As Single
   If sngHue > 360 Then
      sngHue = sngHue - 360
   ElseIf sngHue < 0 Then
      sngHue = sngHue + 360
   End If
   If sngHue < 60 Then
      rgbVal = sngN1 + (sngN2 - sngN1) * sngHue / 60
   ElseIf sngHue < 180 Then
      rgbVal = sngN2
   ElseIf sngHue < 240 Then
      rgbVal = sngN1 + (sngN2 - sngN1) * (240 - sngHue) / 60
   Else
      rgbVal = sngN1
   End If
End Function

Private Function sngMaxOf(sngV1 As Single, sngV2 As Single) As Single
    sngMaxOf = IIf(sngV1 > sngV2, sngV1, sngV2)
End Function

Private Function sngMinOf(sngV1 As Single, sngV2 As Single) As Single
   sngMinOf = IIf(sngV1 < sngV2, sngV1, sngV2)
End Function

Option Explicit

Private Sub Form_Paint()
    Dim lngY As Long
    Dim lngScaleHeight As Long
    Dim lngScaleWidth As Long
    ScaleMode = vbPixels
    lngScaleHeight = ScaleHeight
    lngScaleWidth = ScaleWidth
    DrawStyle = vbInvisible
    FillStyle = vbFSSolid
    For lngY = 0 To lngScaleHeight
        FillColor = RGB(0, 0, 255 - (lngY * 255) \ lngScaleHeight)
        Line (-1, lngY - 1)-(lngScaleWidth, lngY + 1), , B
    Next lngY
End Sub

Option Explicit

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

Private Declare Function DrawFocusRect _
Lib "user32" ( _
    ByVal hdc As Long, _
    lpRect As RECT _
) As Long

Private FocusRec As RECT
Private sngX1 As Single
Private sngY1 As Single
Private sngX2 As Single
Private sngY2 As Single

Private Sub Form_Load()
    `Use units expected by the API function
    Me.ScaleMode = vbPixels
End Sub

Private Sub Form_MouseDown( _
    Button As Integer, _
    Shift As Integer, _
    X As Single, _
    Y As Single _
)
    `Be sure left mouse button is used
    If (Button And vbLeftButton) = 0 Then Exit Sub
    `Set starting corner of box
    sngX1 = X
    sngY1 = Y
End Sub

Private Sub Form_MouseMove( _
    Button As Integer, _
    Shift As Integer, _
    X As Single, _
    Y As Single _
)
    `Be sure left mouse button is pressed
    If (Button And vbLeftButton) = 0 Then Exit Sub
    `Erase focus rectangle if it exists
    If (sngX2 <> 0) Or (sngY2 <> 0) Then
        DrawFocusRect Me.hdc, FocusRec
    End If


    `Update coordinates
    sngX2 = X
    sngY2 = Y
    `Update rectangle
    FocusRec.Left = sngX1
    FocusRec.Top = sngY1
    FocusRec.Right = sngX2
    FocusRec.Bottom = sngY2
    `Adjust rectangle if reversed
    If sngY2 < sngY1 Then Swap FocusRec.Top, FocusRec.Bottom
    If sngX2 < sngX1 Then Swap FocusRec.Left, FocusRec.Right
    `Draw focus rectangle
    DrawFocusRect Me.hdc, FocusRec
    Refresh
End Sub

Private Sub Form_MouseUp( _
    Button As Integer, _
    Shift As Integer, _
    X As Single, _
    Y As Single _
)
    `Be sure left mouse button is pressed
    If (Button And vbLeftButton) = 0 Then Exit Sub
    `Erase focus rectangle if it exists
    If FocusRec.Right Or FocusRec.Bottom Then
        DrawFocusRect Me.hdc, FocusRec
    End If
    `Draw indicated rectangle in red
    Line (sngX1, sngY1)-(sngX2, sngY2), vbRed, B
    `Zero the rectangle coordinates
    sngX1 = 0
    sngY1 = 0
    sngX2 = 0
    sngY2 = 0
End Sub

Private Sub Swap(vntA As Variant, vntB As Variant)
    Dim vntT As Variant
    vntT = vntA
    vntA = vntB
    vntB = vntT
End Sub

Option Explicit

Private Sub imgAfrica_Click()
    lblHotSpots.Caption = "Africa"
End Sub

Private Sub imgEurope_Click()
    lblHotSpots.Caption = "Europe"
End Sub

Private Sub imgEurope_Click()
    lblHotSpots.Caption = "North America"
End Sub

Private Sub imgEurope_Click()
    lblHotSpots.Caption = "South America"
End Sub

Private Sub imgEurope_Click()
    lblHotSpots.Caption = "The World"
End Sub

`POLYGON.CLS
Option Explicit

Private Type POINTAPI
    x As Long
    y As Long
End Type

Private Declare Function Polygon _
Lib "gdi32" ( _
    ByVal hdc As Long, _
    lpPoint As POINTAPI, _
    ByVal nCount As Long _
) As Long

`Module-level private variables
Private mobjDevice As Object
Private msngSX1 As Single
Private msngSY1 As Single
Private msngXRatio As Single
Private msngYRatio As Single
Private maPointArray() As POINTAPI

`~~~Device
Property Set Device(objDevice As Object)
    Dim sngSX2 As Single
    Dim sngSY2 As Single
    Dim sngPX2 As Single
    Dim sngPY2 As Single
    Dim intScaleMode As Integer
    Set mobjDevice = objDevice
    With mobjDevice
        `Grab current scaling parameters
        intScaleMode = .ScaleMode
        msngSX1 = .ScaleLeft
        msngSY1 = .ScaleTop
        sngSX2 = msngSX1 + .ScaleWidth
        sngSY2 = msngSY1 + .ScaleHeight
        `Temporarily set pixels mode
        .ScaleMode = vbPixels
        `Grab pixel scaling parameters
        sngPX2 = .ScaleWidth
        sngPY2 = .ScaleHeight
        `Reset user's original scale
        If intScaleMode = 0 Then
            mobjDevice.Scale (msngSX1, msngSY1)-(sngSX2, sngSY2)
        Else
            mobjDevice.ScaleMode = intScaleMode
        End If
        `Calculate scaling ratios just once
        msngXRatio = sngPX2 / (sngSX2 - msngSX1)
        msngYRatio = sngPY2 / (sngSY2 - msngSY1)
    End With
End Property

`~~~Point X,Y
Public Sub Point(sngX As Single, sngY As Single)
    Dim lngN As Long
    lngN = UBound(maPointArray) + 1
    ReDim Preserve maPointArray(lngN)
    maPointArray(lngN).x = XtoP(sngX)
    maPointArray(lngN).y = YtoP(sngY)
End Sub

`~~~Draw
Public Sub Draw()
    Polygon mobjDevice.hdc, maPointArray(1), UBound(maPointArray)
    ReDim maPointArray(0)
End Sub

`Scales X value to pixel location
Private Function XtoP(sngX As Single) As Long
    XtoP = (sngX - msngSX1) * msngXRatio
End Function

`Scales Y value to pixel location
Private Function YtoP(sngY As Single) As Long
    YtoP = (sngY - msngSY1) * msngYRatio
End Function
`Initialization
Private Sub Class_Initialize()
    ReDim maPointArray(0)
End Sub

`POLYTEST.FRM
Option Explicit

Dim polyTest As New Polygon

Private Sub Form_Load()
    `Create unique polygon each time
    Randomize

    `Use any desired units and graphics settings
    With picTest
        .Move 0, 0, ScaleWidth, ScaleHeight
        .ScaleMode = vbInches
        .FillStyle = vbSolid
    End With
End Sub
Private Sub picTest_Click()
    Dim intI As Integer
    `Connect picture box as polygon output device
    Set polyTest.Device = picTest
    With picTest
        `Clear output with each click
        .Cls
        `Build 17-point random polygon
        For intI = 1 To 17
            polyTest.Point Rnd * .ScaleWidth, Rnd * .ScaleHeight
        Next intI
        `Create unique fill color each time
        .FillColor = RGB(Rnd * 256, Rnd * 256, Rnd * 256)
        `Draw polygon, filling the interior
        polyTest.Draw
    End With
End Sub

`ELLIPSE.CLS
Option Explicit

Private Declare Function Ellipse _
Lib "gdi32" ( _
    ByVal hdc As Long, _
    ByVal X1 As Long, _
    ByVal Y1 As Long, _
    ByVal X2 As Long, _
    ByVal Y2 As Long _
) As Long

`Module-level private variables
Private mobjDevice As Object
Private msngSX1 As Single
Private msngSY1 As Single
Private msngXRatio As Single
Private msngYRatio As Single


`~~~Device
Property Set Device(objDevice As Object)
    Dim sngSX2 As Single
    Dim sngSY2 As Single
    Dim sngPX2 As Single
    Dim sngPY2 As Single
    Dim sngScaleMode As Integer
    Set mobjDevice = objDevice
    With mobjDevice
        `Grab current scaling parameters
        sngScaleMode = .ScaleMode
        msngSX1 = .ScaleLeft
        msngSY1 = .ScaleTop
        sngSX2 = msngSX1 + .ScaleWidth
        sngSY2 = msngSY1 + .ScaleHeight
        `Temporarily set pixels mode
        .ScaleMode = vbPixels
        `Grab pixel scaling parameters
        sngPX2 = .ScaleWidth
        sngPY2 = .ScaleHeight
        `Reset user's original scale
        If sngScaleMode = 0 Then
            mobjDevice.Scale (msngSX1, msngSY1)-(sngSX2, sngSY2)
        Else
            mobjDevice.ScaleMode = sngScaleMode
        End If
        `Calculate scaling ratios just once
        msngXRatio = sngPX2 / (sngSX2 - msngSX1)
        msngYRatio = sngPY2 / (sngSY2 - msngSY1)
    End With
End Property

`~~~Draw X1,Y1,X2,Y2
Public Sub Draw( _
    sngX1 As Single, _
    sngY1 As Single, _
    sngX2 As Single, _
    sngY2 As Single _
)
    Ellipse mobjDevice.hdc, XtoP(sngX1), YtoP(sngY1), _
        XtoP(sngX2), YtoP(sngY2)
End Sub

`Scales X value to pixel location
Private Function XtoP(sngX As Single) As Long
    XtoP = (sngX - msngSX1) * msngXRatio
End Function
`Scales Y value to pixel location
Private Function YtoP(sngY As Single) As Long
    YtoP = (sngY - msngSY1) * msngYRatio
End Function

`ELLITEST
Option Explicit

Dim ellipseTest As New Ellipse

Private Sub picTest_Click()
    picTest.ScaleMode = vbCentimeters
    Set ellipseTest.Device = picTest
    ellipseTest.Draw 1, 1, 7, 4
    ellipseTest.Draw 2, 1, 6, 4
    ellipseTest.Draw 2, 2, 6, 3
End Sub

`PAINT.CLS
Option Explicit



Private Declare Function FloodFill _
Lib "gdi32" ( _
    ByVal hdc As Long, _
    ByVal x As Long, _
    ByVal y As Long, _
    ByVal crColor As Long _
) As Long

`Module-level private variables
Private mobjDevice As Object
Private msngSX1 As Single
Private msngSY1 As Single
Private msngXRatio As Single
Private msngYRatio As Single

Property Set Device(objDevice As Object)
    Dim sngSX2 As Single
    Dim sngSY2 As Single
    Dim sngPX2 As Single
    Dim sngPY2 As Single
    Dim nScaleMode As Integer
    Set mobjDevice = objDevice
    With mobjDevice
        `Grab current scaling parameters
        nScaleMode = .ScaleMode
        msngSX1 = .ScaleLeft
        msngSY1 = .ScaleTop
        sngSX2 = msngSX1 + .ScaleWidth
        sngSY2 = msngSY1 + .ScaleHeight
        `Temporarily set pixels mode
        .ScaleMode = vbPixels
        `Grab pixel scaling parameters
        sngPX2 = .ScaleWidth
        sngPY2 = .ScaleHeight
        `Reset user's original scale
        If nScaleMode = 0 Then
            mobjDevice.Scale (msngSX1, msngSY1)-(sngSX2, sngSY2)
        Else
            mobjDevice.ScaleMode = nScaleMode
        End If
        `Calculate scaling ratios just once
        msngXRatio = sngPX2 / (sngSX2 - msngSX1)
        msngYRatio = sngPY2 / (sngSY2 - msngSY1)
    End With
End Property

`~~~Flood x,y
Public Sub Flood(sngX As Single, sngY As Single)
    FloodFill mobjDevice.hdc, XtoP(sngX), YtoP(sngY), _
        mobjDevice.ForeColor
End Sub

`Scales X value to pixel location
Private Function XtoP(sngX As Single) As Long
    XtoP = (sngX - msngSX1) * msngXRatio
End Function

`Scales Y value to pixel location
Private Function YtoP(sngY As Single) As Long
    YtoP = (sngY - msngSY1) * msngYRatio
End Function

Option Explicit

Dim paintTest As New Paint

Private Sub picTest_Click()
    picTest.ScaleMode = vbInches
    `Draw overlapping box and circle in red
    picTest.Line (0.5, 0.5)-(2, 2), vbRed, B
    picTest.Circle (2, 1), 0.7, vbRed
    `Prepare to paint the overlapping area
    picTest.FillStyle = vbFSSolid    `Paint style
    picTest.FillColor = vbGreen      `Paint color
    picTest.ForeColor = vbRed        `Paint boundary color
    Set paintTest.Device = picTest
    paintTest.Flood 1.7, 0.9
    `Reset fill style to default
    picTest.FillStyle = vbFSTransparent
End Sub

Option Explicit

Const PI = 3.14159265358979
Const ANGLE = 45

Private Sub cmdRotate_Click()
    Dim intX As Integer
    Dim intY As Integer
    Dim intX1 As Integer
    Dim intY1 As Integer
    Dim dblX2 As Double
    Dim dblY2 As Double
    Dim dblX3 As Double
    Dim dblY3 As Double
    Dim dblThetaDeg As Double
    Dim dblThetaRad As Double
    `Initialize rotation angle
    dblThetaDeg = ANGLE
    `Compute angle in radians
    dblThetaRad = dblThetaDeg * PI / 180
    `Set scale modes to pixels
    picOne.ScaleMode = vbPixels
    picTwo.ScaleMode = vbPixels
    For intX = 0 To picTwo.ScaleWidth
        intX1 = intX - picTwo.ScaleWidth \ 2
        For intY = 0 To picTwo.ScaleHeight
            intY1 = intY - picTwo.ScaleHeight \ 2
            `Rotate picture by dblThetaRad
            dblX2 = intX1 * Cos(-dblThetaRad) + _
                intY1 * Sin(-dblThetaRad)
            dblY2 = intY1 * Cos(-dblThetaRad) - _
                intX1 * Sin(-dblThetaRad)
            `Translate to center of picture box
            dblX3 = dblX2 + picOne.ScaleWidth \ 2
            dblY3 = dblY2 + picOne.ScaleHeight \ 2
            `If data point is in picOne, set its color in picTwo
            If dblX3 > 0 And dblX3 < picOne.ScaleWidth - 1 _
                And dblY3 > 0 And dblY3 < picOne.ScaleHeight - 1 Then
                picTwo.PSet (intX, intY), picOne.Point(dblX3, dblY3)
            End If
        Next intY
    Next intX
End Sub

SavePicture picTwo.Image, "C:\FINISHROT.BMP"

Option Explicit

Private Sub Form_Load()
    hsbScroll.Max = picOne.ScaleWidth - picTwo.ScaleWidth
    hsbScroll.LargeChange = hsbScroll.Max \ 10
    hsbScroll.SmallChange = hsbScroll.Max \ 25
    vsbScroll.Max = picOne.ScaleHeight - picTwo.ScaleHeight
    vsbScroll.LargeChange = vsbScroll.Max \ 10
    vsbScroll.SmallChange = vsbScroll.Max \ 25
End Sub

Private Sub hsbScroll_Change()
    UpdatePicTwo
End Sub

Private Sub hsbScroll_Scroll()
    hsbScroll_Change
End Sub

Private Sub vsbScroll_Change()
    UpdatePicTwo
End Sub

Private Sub vsbScroll_Scroll()
    vsbScroll_Change
End Sub

Private Sub UpdatePicTwo()
    picTwo.PaintPicture picOne.Picture, 0, 0, _
        picTwo.ScaleWidth, picTwo.ScaleHeight, _
        hsbScroll.Value, vsbScroll.Value, _
        picTwo.ScaleWidth, picTwo.ScaleHeight, _
        vbSrcCopy
End Sub

`BITBLT
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 Sub cmdAnimate_Click()
    Static lngX As Long
    Static lngY As Long
    Static lngW As Long
    Static lngH As Long
    Static blnBackSaved As Boolean
    Dim lngRtn As Long
    `Display hourglass pointer while busy
    Screen.MousePointer = vbHourglass
    `Provide starting location
    lngX = -picUfo.ScaleWidth
    lngY = picClouds.ScaleHeight
    `Save sizes in local variables once for speed
    lngW = picUfo.ScaleWidth
    lngH = picUfo.ScaleHeight
    `Loop to animate the UFO
    Do
        `Restore background unless this is first time object is drawn
        If blnBackSaved = True Then
            lngRtn = BitBlt(picClouds.hDC, lngX, lngY, lngW, lngH, _
                picBack.hDC, 0, 0, vbSrcCopy)
            `Stop UFO's motion when it gets to the edges
            If lngX > picClouds.ScaleWidth Then
                blnBackSaved = False
                
                picClouds.Refresh
                Exit Do
            End If
        End If
        `Move UFO to a new location
        lngX = lngX + 1
            If lngX < 0.5 * picClouds.ScaleWidth _
                Or lngX > 0.8 * picClouds.ScaleWidth Then
                lngY = lngY - 1
        Else
            lngY = lngY + 1
        End If
        `Save background at new location
        lngRtn = BitBlt(picBack.hDC, 0, 0, lngW, lngH, _
            picClouds.hDC, lngX, lngY, vbSrcCopy)
        blnBackSaved = True
        `Apply mask
        lngRtn = BitBlt(picClouds.hDC, lngX, lngY, lngW, lngH, _
            picUfoMask.hDC, 0, 0, vbSrcAnd)
        `Draw UFO
        lngRtn = BitBlt(picClouds.hDC, lngX, lngY, lngW, lngH, _
            picUfo.hDC, 0, 0, vbSrcPaint)
        picClouds.Refresh
    Loop
    `Restore pointer
    Screen.MousePointer = vbDefault
End Sub

Option Explicit

Const NUMFRAMES = 15
Dim picArray(1 To NUMFRAMES) As Picture

Private Sub Form_Load()
    Dim strFile As String
    Dim intI As Integer
    For intI = 1 To NUMFRAMES
        strFile = App.Path & "\GLOBE" & _
            Format(intI) & ".BMP"
        Set picArray(intI) = LoadPicture(strFile)
    Next intI
End Sub

Private Sub tmrAnimate_Timer()
    Static intN As Integer
    intN = (intN Mod NUMFRAMES) + 1
    picTest.Picture = picArray(intN)
End Sub

Option Explicit

Private Sub Form_Load()
    anmOne.Open App.Path & "\SEARCH.AVI"
    anmOne.Play
    anmTwo.Open App.Path & "\FILENUKE.AVI"
    anmTwo.Play
End Sub

Option Explicit

Private Sub Form_Resize()
    Dim intX As Integer
    Dim intY As Integer
    Dim strA As String
    `Reposition the picture box
    picTest.Move 0, 0, ScaleWidth, ScaleHeight
    `Erase previous contents of picture box
    picTest.Cls
    `Determine center of picture box
    intX = picTest.ScaleWidth \ 2
    intY = picTest.ScaleHeight \ 2
    `Draw circle at center for reference
    picTest.Circle (intX, intY), 700
    `Print string centered in picture box
    strA = "CENTER"
    picTest.CurrentX = intX - picTest.TextWidth(strA) \ 2
    picTest.CurrentY = intY - picTest.TextHeight(strA) \ 2
    picTest.Print strA
    `Determine lower-right corner of picture box
    intX = picTest.ScaleWidth
    intY = picTest.ScaleHeight
    `Print string at lower-right corner
    strA = "Lower-right cornerDear John, How Do I... "
    picTest.CurrentX = intX - picTest.TextWidth(strA)
    picTest.CurrentY = intY - picTest.TextHeight(strA)
    picTest.Print strA
End Sub

Option Explicit

Private Sub Form_Click()
    Dim sngSize As Single
    sngSize = 1
    Do
        sngSize = sngSize * 1.2
        Me.Font = "Garamond"
        Me.Font.Size = sngSize
        Me.Print "Garamond - "; sngSize
    Loop Until sngSize > 100!
End Sub

`ROTATOR.CLS
Option Explicit

`API constants
Private Const LF_FACESIZE = 32
Private Const LOGPIXELSY = 90

Private Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As Byte
    lfUnderline As Byte
    lsngStrikeOut As Byte
    lfCharSet As Byte
    lfOutPrecision As Byte
    lfClipPrecision As Byte
    lfQuality As Byte
    lsngPitchAndFamily As Byte
    lfFaceName(LF_FACESIZE - 1) As Byte
End Type

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 CreateFontIndirect _
Lib "gdi32" Alias "CreateFontIndirectA" ( _
    lpLogFont As LOGFONT _
) As Long

Private Declare Function TextOut _
Lib "gdi32" Alias "TextOutA" ( _
    ByVal hdc As Long, _
    ByVal x As Long, _
    ByVal y As Long, _
    ByVal lpString As String, _
    ByVal nCount As Long _
) As Long

Private Declare Function GetDeviceCaps _
Lib "gdi32" ( _
    ByVal hdc As Long, _
    ByVal intIndex As Long _
) As Long

`Module-level private variables
Private mobjDevice As Object
Private msngSX1 As Single
Private msngSY1 As Single
Private msngXRatio As Single
Private msngYRatio As Single
Private mlfFont As LOGFONT
Private mintAngle As Integer

`~~~Angle
Property Let Angle(intAngle As Integer)
    mintAngle = intAngle
End Property
Property Get Angle() As Integer
    Angle = mintAngle
End Property

`~~~Label
Public Sub Label(sText As String)
    Dim lngFont As Long
    Dim lngOldFont As Long
    Dim lngRes As Long
    Dim bytBuf() As Byte
    Dim intI As Integer
    Dim strFontName As String
    `Prepare font name, decoding from Unicode
    strFontName = mobjDevice.Font.Name
    bytBuf = StrConv(strFontName & Chr$(0), vbFromUnicode)
    For intI = 0 To UBound(bytBuf)
        mlfFont.lfFaceName(intI) = bytBuf(intI)
    Next intI
    `Convert known font size to required units
    mlfFont.lfHeight = mobjDevice.Font.Size * _
        GetDeviceCaps(mobjDevice.hdc, LOGPIXELSY) \ 72
    `Set italic or not
    If mobjDevice.Font.Italic = True Then
        mlfFont.lfItalic = 1
    Else
        mlfFont.lfItalic = 0

    End If
    `Set underline or not
    If mobjDevice.Font.Underline = True Then
        mlfFont.lfUnderline = 1
    Else
        mlfFont.lfUnderline = 0
    End If
    `Set strikethrough or not
    If mobjDevice.Font.Strikethrough = True Then
        mlfFont.lsngStrikeOut = 1
    Else
        mlfFont.lsngStrikeOut = 0
    End If
    `Set bold or not (use font's weight)
    mlfFont.lfWeight = mobjDevice.Font.Weight
    `Set font rotation angle
    mlfFont.lfEscapement = CLng(mintAngle * 10#)
    mlfFont.lfOrientation = mlfFont.lfEscapement
    `Build temporary new font and output the string
    lngFont = CreateFontIndirect(mlfFont)
    lngOldFont = SelectObject(mobjDevice.hdc, lngFont)
    lngRes = TextOut(mobjDevice.hdc, XtoP(mobjDevice.CurrentX), _
        YtoP(mobjDevice.CurrentY), sText, Len(sText))
    lngFont = SelectObject(mobjDevice.hdc, lngOldFont)
    DeleteObject lngFont
End Sub

`~~~Device
Property Set Device(objDevice As Object)
    Dim sngSX2 As Single
    Dim sngSY2 As Single
    Dim sngPX2 As Single
    Dim sngPY2 As Single
    Dim intScaleMode As Integer
    Set mobjDevice = objDevice
    With mobjDevice
        `Grab current scaling parameters
        intScaleMode = .ScaleMode
        msngSX1 = .ScaleLeft
        msngSY1 = .ScaleTop
        sngSX2 = msngSX1 + .ScaleWidth
        sngSY2 = msngSY1 + .ScaleHeight
        `Temporarily set pixels mode
        .ScaleMode = vbPixels

        `Grab pixel scaling parameters
        sngPX2 = .ScaleWidth
        sngPY2 = .ScaleHeight
        `Reset user's original scale
        If intScaleMode = 0 Then
            mobjDevice.Scale (msngSX1, msngSY1)-(sngSX2, sngSY2)
        Else
            mobjDevice.ScaleMode = intScaleMode
        End If
        `Calculate scaling ratios just once
        msngXRatio = sngPX2 / (sngSX2 - msngSX1)
        msngYRatio = sngPY2 / (sngSY2 - msngSY1)
    End With
End Property

`Scales X value to pixel location
Private Function XtoP(sngX As Single) As Long
    XtoP = (sngX - msngSX1) * msngXRatio
End Function

`Scales Y value to pixel location
Private Function YtoP(sngY As Single) As Long
    YtoP = (sngY - msngSY1) * msngYRatio
End Function

Option Explicit

Dim rotTest As New Rotator
Private Sub picTest_Click()
    Dim intA As Integer
    `Prepare the font in the picture box
    picTest.Scale (-1, -1)-(1, 1)
    With picTest
        .CurrentX = 0
        .CurrentY = 0
        With .Font
            .Name = "Courier New"
            .Size = 11
            `.Bold = True
            `.Italic = True
            `.Strikethrough = True
            `.Underline = True
            `.Weight = 1000
        End With
    End With
    `Connect Rotator object to the picture box
    Set rotTest.Device = picTest
    `Label strings at a variety of angles
    For intA = 10 To 359 Step 15
        rotTest.Angle = intA
        rotTest.Label Space(4) & picTest.Font.Name & Str(intA)
    Next intA
End Sub

Option Explicit

Private Sub picTest_Click()
    picTest.Print "Default font properties"
    picTest.Font.Name = "WingDings"
    picTest.Font.Size = 18
    picTest.Print "WingDings"
    picTest.Font.Name = "Arial"
    picTest.Print "Arial"
    picTest.Font.Name = "Garamond"
    picTest.Print "Garamond"
    picTest.Font.Bold = True
    picTest.Font.Italic = True
    picTest.Font.Underline = True
    picTest.Font.Name = "Arial"
    picTest.Print "Bold, Italic, Underline, and so on"
End Sub