Visual Basic Graphics Programming (2nd Edition)/Visual Basic Graphics Programming 2nd Edition.iso/OldSrc/CH4/SRC/COLORBAL.FRM

Visual Basic Form | 1997-01-03 | 22.7 KB | 728 lines

VERSION 4.00
Begin VB.Form ColorBalForm
   Caption         =   "Color Balance"
   ClientHeight    =   5235
   ClientLeft      =   1380
   ClientTop       =   915
   ClientWidth     =   4695
   Height          =   5925
   Left            =   1320
   LinkTopic       =   "Form1"
   ScaleHeight     =   349
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   313
   Top             =   285
   Width           =   4815
   Begin VB.PictureBox BalPict
      BorderStyle     =   0  'None
      Height          =   975
      Left            =   0
      ScaleHeight     =   975
      ScaleWidth      =   4695
      TabIndex        =   4
      Top             =   4200
      Width           =   4695
      Begin VB.HScrollBar ScrollBlue
         Enabled         =   0   'False
         Height          =   255
         LargeChange     =   10
         Left            =   860
         Max             =   100
         Min             =   -100
         TabIndex        =   9
         Top             =   720
         Width           =   3855
      End
      Begin VB.HScrollBar ScrollGreen
         Enabled         =   0   'False
         Height          =   255
         LargeChange     =   10
         Left            =   860
         Max             =   100
         Min             =   -100
         TabIndex        =   7
         Top             =   360
         Width           =   3855
      End
      Begin VB.HScrollBar ScrollRed
         Enabled         =   0   'False
         Height          =   255
         LargeChange     =   10
         Left            =   860
         Max             =   100
         Min             =   -100
         TabIndex        =   5
         Top             =   0
         Width           =   3855
      End
      Begin VB.Label ValueBlue
         BorderStyle     =   1  'Fixed Single
         Caption         =   "0"
         Height          =   255
         Left            =   480
         TabIndex        =   13
         Top             =   720
         Width           =   375
      End
      Begin VB.Label ValueRed
         BorderStyle     =   1  'Fixed Single
         Caption         =   "0"
         Height          =   255
         Left            =   480
         TabIndex        =   12
         Top             =   0
         Width           =   375
      End
      Begin VB.Label ValueGreen
         BorderStyle     =   1  'Fixed Single
         Caption         =   "0"
         Height          =   255
         Left            =   480
         TabIndex        =   11
         Top             =   360
         Width           =   375
      End
      Begin VB.Label Label1
         Caption         =   "Blue"
         Height          =   255
         Index           =   2
         Left            =   0
         TabIndex        =   10
         Top             =   720
         Width           =   495
      End
      Begin VB.Label Label1
         Caption         =   "Green"
         Height          =   255
         Index           =   1
         Left            =   0
         TabIndex        =   8
         Top             =   360
         Width           =   495
      End
      Begin VB.Label Label1
         Caption         =   "Red"
         Height          =   255
         Index           =   0
         Left            =   0
         TabIndex        =   6
         Top             =   0
         Width           =   495
      End
   End
   Begin VB.PictureBox FromSwin
      Height          =   3855
      Left            =   0
      ScaleHeight     =   253
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   293
      TabIndex        =   2
      Top             =   0
      Width           =   4455
      Begin VB.PictureBox FromPict
         AutoRedraw      =   -1  'True
         AutoSize        =   -1  'True
         Height          =   1905
         Left            =   0
         ScaleHeight     =   123
         ScaleMode       =   3  'Pixel
         ScaleWidth      =   88
         TabIndex        =   3
         Top             =   0
         Width           =   1380
      End
   End
   Begin VB.HScrollBar FromHBar
      Enabled         =   0   'False
      Height          =   255
      Left            =   0
      TabIndex        =   1
      Top             =   3840
      Width           =   4485
   End
   Begin VB.VScrollBar FromVBar
      Enabled         =   0   'False
      Height          =   3855
      Left            =   4440
      TabIndex        =   0
      Top             =   0
      Width           =   255
   End
   Begin MSComDlg.CommonDialog FileDialog
      Left            =   4200
      Top             =   3600
      _Version        =   65536
      _ExtentX        =   847
      _ExtentY        =   847
      _StockProps     =   0
      CancelError     =   -1  'True
   End
   Begin VB.Menu mnuFile
      Caption         =   "&File"
      Begin VB.Menu mnuFileLoad
         Caption         =   "&Load..."
         Shortcut        =   ^L
      End
      Begin VB.Menu mnuFileSep2
         Caption         =   "-"
      End
      Begin VB.Menu mnuFileExit
         Caption         =   "E&xit"
      End
   End
Attribute VB_Name = "ColorBalForm"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
Dim SysPalSize As Integer
Dim NumStaticColors As Integer
Dim StaticColor1 As Integer
Dim StaticColor2 As Integer
Dim bytes() As Byte
Dim wid As Long
Dim hgt As Long
Dim LogPal As Integer
Dim origpal(0 To 255) As PALETTEENTRY
Dim newpal(0 To 255) As PALETTEENTRY
Dim SettingValues As Boolean
' ***********************************************
' Load the control's palette so the non-static
' colors are grays. Map the logical palette to
' match the system palette. Convert the image to
' use the non-static grays.
' Set the following module global variables.
'   LogPal      Image logical palette handle.
'   origpal()  Image logical palette entries.
'   wid         Width of image.
'   hgt         Height of image.
'   bytes(1 To wid, 1 To hgt)
'               Image pixel values.
' ***********************************************
Sub MatchGrayPalette(pic As Control)
Dim sys(0 To 255) As PALETTEENTRY
Dim i As Integer
Dim bm As BITMAP
Dim hbm As Integer
Dim status As Long
Dim X As Integer
Dim Y As Integer
Dim gray As Single
Dim dgray As Single
Dim c As Integer
Dim clr As Integer
    ' Make sure pic has the foreground palette.
    pic.ZOrder
    i = RealizePalette(pic.hdc)
    DoEvents
    ' Get the system palette entries.
    i = GetSystemPaletteEntries(pic.hdc, 0, SysPalSize, sys(0))

    ' Get the image pixels.
    hbm = pic.Image
    status = GetObject(hbm, BITMAP_SIZE, bm)
    wid = bm.bmWidthBytes
    hgt = bm.bmHeight
    ReDim bytes(1 To wid, 1 To hgt)
    status = GetBitmapBits(hbm, wid * hgt, bytes(1, 1))
    ' Make the logical palette as big as possible.
    LogPal = pic.Picture.hPal
    If ResizePalette(LogPal, SysPalSize) = 0 Then
        Beep
        MsgBox "Error resizing logical palette.", _
            vbExclamation
        Exit Sub
    End If
    ' Blank the non-static colors.
    For i = 0 To StaticColor1
        origpal(i) = sys(i)
    Next i
    For i = StaticColor1 + 1 To StaticColor2 - 1
        With origpal(i)
            .peRed = 0
            .peGreen = 0
            .peBlue = 0
            .peFlags = PC_NOCOLLAPSE
        End With
    Next i
    For i = StaticColor2 To 255
        origpal(i) = sys(i)
    Next i
    i = SetPaletteEntries(LogPal, 0, SysPalSize, origpal(0))
    ' Insert the non-static grays.
    gray = 0
    dgray = 255 / (StaticColor2 - StaticColor1 - 2)
    For i = StaticColor1 + 1 To StaticColor2 - 1
        c = gray
        gray = gray + dgray
        With origpal(i)
            .peRed = c
            .peGreen = c
            .peBlue = c
        End With
    Next i
    i = SetPaletteEntries(LogPal, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, origpal(StaticColor1 + 1))
    ' Recreate the image using the new colors.
    For Y = 1 To hgt
        For X = 1 To wid
            clr = bytes(X, Y)
            With sys(clr)
                c = (CInt(.peRed) + .peGreen + .peBlue) / 3
            End With
            bytes(X, Y) = NearestNonstaticGray(c)
        Next X
    Next Y
    status = SetBitmapBits(hbm, wid * hgt, bytes(1, 1))
    ' Realize the gray palette.
    i = RealizePalette(pic.hdc)
    pic.Refresh
End Sub
' ************************************************
' Return the index of the nonstatic color closest
' to the given color value.
' ************************************************
Function NearestNonstaticColor(ByVal r As Integer, ByVal g As Integer, ByVal b As Integer) As Integer
Dim best_i As Integer
Dim best_dist As Long
Dim dist As Long
Dim dr As Long
Dim dg As Long
Dim db As Long
Dim i As Integer
    best_dist = 1000000
    For i = StaticColor1 + 1 To StaticColor2 - 1
        With origpal(i)
            dr = r - .peRed
            dg = g - .peGreen
            db = b - .peBlue
            dist = dr * dr + dg * dg + db * db
        End With
        If best_dist > dist Then
            best_i = i
            best_dist = dist
        End If
    Next i
    NearestNonstaticColor = best_i
End Function
' ************************************************
' Return the index of the nonstatic gray closest
' to the given value (assuming the non-static
' colors are a gray scale created by
' MatchGrayPalette).
' ************************************************
Function NearestNonstaticGray(c As Integer) As Integer
Dim dgray As Single
    If c < 0 Then
        c = 0
    ElseIf c > 255 Then
        c = 255
    End If
    dgray = 255 / (StaticColor2 - StaticColor1 - 2)
    NearestNonstaticGray = c / dgray + StaticColor1 + 1
End Function
' ***********************************************
' Load the control's palette so it matches the
' the system palette. Remap any of the image's
' pixels that use static colors to non-static
' colors.
' Set the following module global variables.
'   LogPal      Image logical palette handle.
'   origpal()  Image logical palette entries.
'   wid         Width of image.
'   hgt         Height of image.
'   bytes(1 To wid, 1 To hgt)
'               Image pixel values.
' ***********************************************
Sub MatchColorPalette(pic As Control)
Dim sys(0 To 255) As PALETTEENTRY
Dim i As Integer
Dim bm As BITMAP
Dim hbm As Integer
Dim status As Long
Dim X As Integer
Dim Y As Integer
Dim clr As Integer
    ' Make sure pic has the foreground palette.
    pic.ZOrder
    i = RealizePalette(pic.hdc)
    DoEvents
    ' Get the system palette entries.
    i = GetSystemPaletteEntries(pic.hdc, 0, SysPalSize, sys(0))

    ' Make the logical palette as big as possible.
    LogPal = pic.Picture.hPal
    If ResizePalette(LogPal, SysPalSize) = 0 Then
        Beep
        MsgBox "Error resizing logical palette.", _
            vbExclamation
        Exit Sub
    End If
    ' Blank the non-static colors.
    For i = 0 To StaticColor1
        origpal(i) = sys(i)
    Next i
    For i = StaticColor1 + 1 To StaticColor2 - 1
        With origpal(i)
            .peRed = 0
            .peGreen = 0
            .peBlue = 0
            .peFlags = PC_NOCOLLAPSE
        End With
    Next i
    For i = StaticColor2 To 255
        origpal(i) = sys(i)
    Next i
    i = SetPaletteEntries(LogPal, 0, SysPalSize, origpal(0))
    ' Insert the non-static colors.
    For i = StaticColor1 + 1 To StaticColor2 - 1
        origpal(i) = sys(i)
        origpal(i).peFlags = PC_NOCOLLAPSE
    Next i
    i = SetPaletteEntries(LogPal, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, origpal(StaticColor1 + 1))
    ' Realize the new palette.
    i = RealizePalette(pic.hdc)
    ' Get the image pixels.
    hbm = pic.Image
    status = GetObject(hbm, BITMAP_SIZE, bm)
    wid = bm.bmWidthBytes
    hgt = bm.bmHeight
    ReDim bytes(1 To wid, 1 To hgt)
    status = GetBitmapBits(hbm, wid * hgt, bytes(1, 1))
    ' Remap any pixels using static colors.
    For Y = 1 To hgt
        For X = 1 To wid
            clr = bytes(X, Y)
            If clr <= StaticColor1 Or clr >= StaticColor2 Then
                With sys(clr)
                    bytes(X, Y) = _
                        NearestNonstaticColor( _
                        .peRed, .peGreen, .peBlue)
                End With
            End If
        Next X
    Next Y
    ' Update the image's pixel values.
    status = SetBitmapBits(hbm, wid * hgt, bytes(1, 1))
    pic.Refresh
End Sub
' ***********************************************
' Load the indicated file and prepare to work
' with its palette.
' ***********************************************
Sub LoadFromPict(fname As String)
Dim status As Long
Dim i As Integer
    On Error GoTo LoadFileError
    FromPict.Picture = LoadPicture(fname)
    On Error GoTo 0

    FromHBar.Enabled = False
    FromVBar.Enabled = False
    ScrollRed.Enabled = False
    ScrollGreen.Enabled = False
    ScrollBlue.Enabled = False
    DoEvents
    MatchColorPalette FromPict
    For i = 0 To SysPalSize - 1
        newpal(i) = origpal(i)
    Next i
    FromPict.Move 0, 0
    ResetScrollBars
    ScrollRed.Enabled = True
    ScrollGreen.Enabled = True
    ScrollBlue.Enabled = True
    SettingValues = True
    ScrollRed.Value = 0
    ScrollGreen.Value = 0
    ScrollBlue.Value = 0
    SettingValues = False

    Caption = "Color Balance [" & fname & "]"
    Exit Sub
LoadFileError:
    Beep
    MsgBox "Error loading file " & fname & "." & _
        vbCrLf & Error$
    Exit Sub
End Sub
' ***********************************************
' Set the Max and LargeChange properties for the
' image scroll bars.
' ***********************************************
Sub ResetScrollBars()
    ' FromHBar.
    FromHBar.Value = 0
    If FromSwin.ScaleWidth >= FromPict.Width Then
        FromHBar.Enabled = False
    Else
        FromHBar.Max = FromPict.Width - FromSwin.ScaleWidth
        FromHBar.LargeChange = FromSwin.ScaleWidth
        FromHBar.Enabled = True
    End If
    ' FromVBar.
    FromVBar.Value = 0
    If FromSwin.ScaleHeight >= FromPict.Height Then
        FromVBar.Enabled = False
    Else
        FromVBar.Max = FromPict.Height - FromSwin.ScaleHeight
        FromVBar.LargeChange = FromSwin.ScaleHeight
        FromVBar.Enabled = True
    End If
End Sub
' ************************************************
' Adjust the colors using the current values of
' ScrollRed, ScrollGreen, and ScrollBlue.
' If -100 <= v <= 0, then subtract v percent of
' the corresponding color value.
' If 0 <= v <= 100, then add v percent of the
' difference between the corresponding color value
' and 255.
' Thus:
'   When v = -100, the color goes to 0.
'   When v =    0, the color is unchanged.
'   When v =  100, the color goes to 255.
' ************************************************
Sub UpdateColors()
Dim i As Integer
Dim vr As Single
Dim vg As Single
Dim vb As Single
Dim fr As Single
Dim fg As Single
Dim fb As Single
Dim r As Integer
Dim g As Integer
Dim b As Integer
    ' Get the scroll bar values.
    vr = ScrollRed.Value / 100#
    If vr < 0 Then
        fr = 1 + vr
    Else
        fr = vr
    End If
    vg = ScrollGreen.Value / 100#
    If vg < 0 Then
        fg = 1 + vg
    Else
        fg = vg
    End If
    vb = ScrollBlue.Value / 100#
    If vb < 0 Then
        fb = 1 + vb
    Else
        fb = vb
    End If
    ' Set the new palette entries.
    For i = StaticColor1 + 1 To StaticColor2 - 1
        With origpal(i)
            r = .peRed
            If vr < 0 Then
                r = r * fr
            Else
                r = r + (255 - r) * fr
            End If

            g = .peGreen
            If vg < 0 Then
                g = g * fg
            Else
                g = g + (255 - g) * fg
            End If

            b = .peBlue
            If vb < 0 Then
                b = b * fb
            Else
                b = b + (255 - b) * fb
            End If
        End With
        With newpal(i)
            .peRed = r
            .peGreen = g
            .peBlue = b
            .peFlags = PC_NOCOLLAPSE
        End With
    Next i
    i = SetPaletteEntries(LogPal, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, newpal(StaticColor1 + 1))
    i = RealizePalette(FromPict.hdc)
End Sub
' ***********************************************
' Give the form and all the picture boxes an
' hourglass cursor.
' ***********************************************
Sub WaitStart()
    MousePointer = vbHourglass
    FromPict.MousePointer = vbHourglass
    DoEvents
End Sub
' ***********************************************
' Restore the mouse pointers for the form and all
' the picture boxes.
' ***********************************************
Sub WaitEnd()
    MousePointer = vbDefault
    FromPict.MousePointer = vbDefault
End Sub
Private Sub Form_Load()
    ' Make sure the screen supports palettes.
    If Not GetDeviceCaps(hdc, RASTERCAPS) And RC_PALETTE Then
        Beep
        MsgBox "This monitor does not support palettes.", _
            vbCritical
        End
    End If
    ' Get system palette size and # static colors.
    SysPalSize = GetDeviceCaps(hdc, SIZEPALETTE)
    NumStaticColors = GetDeviceCaps(hdc, NUMRESERVED)
    StaticColor1 = NumStaticColors \ 2 - 1
    StaticColor2 = SysPalSize - NumStaticColors \ 2
    ' Remove the borders from FromPict.
    FromPict.BorderStyle = vbTransparent
    ' Make sure FromPict has control.
    FromPict.ZOrder
End Sub
' ***********************************************
' Make the picture as large as possible.
' ***********************************************
Private Sub Form_Resize()
Const GAP = 4
Dim hgt As Single
Dim wid As Single
Dim lft As Single
    If WindowState = vbMinimized Then Exit Sub

    hgt = ScaleHeight - FromHBar.Height - 1 - _
        BalPict.Height - 2 * GAP
    wid = ScaleWidth - FromVBar.Width - 1
    ' Place FromSwin and its scroll bars.
    FromSwin.Move 0, 0, wid, hgt
    FromVBar.Move _
        FromSwin.Left + FromSwin.Width + 1, _
        0, FromVBar.Width, hgt
    FromHBar.Move _
        FromSwin.Left, FromSwin.Height + 1, _
        wid

    BalPict.Move 0, _
        FromHBar.Top + FromHBar.Height + GAP, _
        ScaleWidth
    ScrollRed.Width = BalPict.ScaleWidth - ScrollRed.Left
    ScrollGreen.Width = ScrollRed.Width
    ScrollBlue.Width = ScrollRed.Width
    ResetScrollBars
End Sub
Private Sub Form_Unload(Cancel As Integer)
    End
End Sub
' ***********************************************
' Move FromPict within FromSwin.
' ***********************************************
Private Sub FromHBar_Change()
    FromPict.Left = -FromHBar.Value
End Sub
' ***********************************************
' Move FromPict within FromSwin.
' ***********************************************
Private Sub FromHBar_Scroll()
    FromPict.Left = -FromHBar.Value
End Sub
' ************************************************
' Present a message indicating the pixel's palette
' index and color value.
' ************************************************
Private Sub FromPict_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If X > wid Or Y > hgt Then Exit Sub
    With newpal(bytes(X, Y))
        MsgBox "Palette index:" & Str$(bytes(X, Y)) & _
            vbCrLf & "Red:  " & Str$(.peRed) & _
            vbCrLf & "Green:" & Str$(.peGreen) & _
            vbCrLf & "Blue: " & Str$(.peBlue)
    End With
End Sub
' ***********************************************
' Load a new image file.
' ***********************************************
Private Sub mnuFileLoad_Click()
Dim fname As String
    ' Allow the user to pick a file.
    On Error Resume Next
    FileDialog.filename = "*.BMP;*.ICO;*.RLE;*.WMF;*.DIB"
    FileDialog.Flags = cdlOFNFileMustExist + cdlOFNHideReadOnly
    FileDialog.ShowOpen
    If Err.Number = cdlCancel Then
        Exit Sub
    ElseIf Err.Number <> 0 Then
        Beep
        MsgBox "Error selecting file.", , vbExclamation
        Exit Sub
    End If
    On Error GoTo 0
    fname = Trim$(FileDialog.filename)
    FileDialog.InitDir = Left$(fname, Len(fname) _
        - Len(FileDialog.FileTitle) - 1)
    ' Load the picture.
    WaitStart
    LoadFromPict fname
    WaitEnd
End Sub
' ***********************************************
' End the application. (See also the QueryUnload
' event.)
' ***********************************************
Private Sub mnuFileExit_Click()
    Unload Me
End Sub
' ***********************************************
' Move FromPict within FromSwin.
' ***********************************************
Private Sub FromVBar_Change()
    FromPict.Top = -FromVBar.Value
End Sub
' ***********************************************
' Move FromPict within FromSwin.
' ***********************************************
Private Sub FromVBar_Scroll()
    FromPict.Top = -FromVBar.Value
End Sub
' ************************************************
' Update the color balance.
' ************************************************
Private Sub ScrollBlue_Change()
    ValueBlue.Caption = Format$(ScrollBlue.Value)
    If SettingValues Then Exit Sub
    UpdateColors
End Sub
' ************************************************
' Update the color balance.
' ************************************************
Private Sub ScrollBlue_Scroll()
    ScrollBlue_Change
End Sub
' ************************************************
' Update the color balance.
' ************************************************
Private Sub ScrollGreen_Change()
    ValueGreen.Caption = Format$(ScrollGreen.Value)
    If SettingValues Then Exit Sub
    UpdateColors
End Sub
' ************************************************
' Update the color balance.
' ************************************************
Private Sub ScrollGreen_Scroll()
    ScrollGreen_Change
End Sub
' ************************************************
' Update the color balance.
' ************************************************
Private Sub ScrollRed_Change()
    ValueRed.Caption = Format$(ScrollRed.Value)
    If SettingValues Then Exit Sub
    UpdateColors
End Sub
' ************************************************
' Update the color balance.
' ************************************************
Private Sub ScrollRed_Scroll()
    ScrollRed_Change
End Sub