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

Visual Basic Form | 1997-01-03 | 14.3 KB | 455 lines

VERSION 4.00
Begin VB.Form AverageForm
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Average"
   ClientHeight    =   5700
   ClientLeft      =   1875
   ClientTop       =   825
   ClientWidth     =   5925
   Height          =   6390
   Left            =   1815
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   380
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   395
   Top             =   195
   Width           =   6045
   Begin VB.PictureBox Pict
      AutoRedraw      =   -1  'True
      Height          =   2775
      Index           =   3
      Left            =   3000
      Picture         =   "AVERAGE.frx":0000
      ScaleHeight     =   2715
      ScaleWidth      =   2835
      TabIndex        =   3
      Top             =   2880
      Width           =   2895
   End
   Begin VB.PictureBox Pict
      AutoRedraw      =   -1  'True
      Height          =   2775
      Index           =   2
      Left            =   0
      Picture         =   "AVERAGE.frx":0446
      ScaleHeight     =   2715
      ScaleWidth      =   2835
      TabIndex        =   2
      Top             =   2880
      Width           =   2895
   End
   Begin VB.PictureBox Pict
      AutoRedraw      =   -1  'True
      Height          =   2775
      Index           =   1
      Left            =   3000
      ScaleHeight     =   2715
      ScaleWidth      =   2835
      TabIndex        =   1
      Top             =   0
      Width           =   2895
   End
   Begin VB.PictureBox Pict
      AutoRedraw      =   -1  'True
      Height          =   2775
      Index           =   0
      Left            =   0
      ScaleHeight     =   2715
      ScaleWidth      =   2835
      TabIndex        =   0
      Top             =   0
      Width           =   2895
   End
   Begin MSComDlg.CommonDialog FileDialog
      Left            =   2760
      Top             =   360
      _Version        =   65536
      _ExtentX        =   847
      _ExtentY        =   847
      _StockProps     =   0
      CancelError     =   -1  'True
   End
   Begin VB.Menu mnuFile
      Caption         =   "&File"
      Begin VB.Menu mnuFileLoad
         Caption         =   "Load Image &1..."
         Index           =   0
      End
      Begin VB.Menu mnuFileLoad
         Caption         =   "Load Image &2..."
         Index           =   1
      End
      Begin VB.Menu mnuFileLoad
         Caption         =   "Load Image &3..."
         Index           =   2
      End
      Begin VB.Menu mnuFileSep2
         Caption         =   "-"
      End
      Begin VB.Menu mnuFileExit
         Caption         =   "E&xit"
      End
   End
   Begin VB.Menu mnuOp
      Caption         =   "&Operation"
      Begin VB.Menu mnuOpAverage
         Caption         =   "&Average"
         Enabled         =   0   'False
      End
      Begin VB.Menu mnuOpVote
         Caption         =   "&Vote"
         Enabled         =   0   'False
      End
   End
Attribute VB_Name = "AverageForm"
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 bytes0() As Byte
Dim bytes1() As Byte
Dim bytes2() As Byte
Dim bytes3() As Byte
Dim wid(0 To 3) As Long
Dim hgt(0 To 3) As Long
Dim PictLoaded(0 To 2) As Boolean
Dim dgray As Single
' ************************************************
' Return the value of the indicated non-static
' palette entry (assuming the non-static colors
' are a gray scale created by MatchGrayPalette).
' ************************************************
Function NonstaticGrayValue(ByVal Index As Integer) As Integer
    NonstaticGrayValue = (Index - StaticColor1 - 1) * dgray
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 indicated file and prepare to work
' with its palette.
' ***********************************************
Sub LoadPict(Index As Integer, fname As String)
Dim i As Integer
    On Error GoTo LoadFileError
    Pict(Index).Picture = LoadPicture(fname)
    On Error GoTo 0
    Select Case Index
        Case 0
            MatchGrayPalette Index, Pict(Index), bytes0
        Case 1
            MatchGrayPalette Index, Pict(Index), bytes1
        Case 2
            MatchGrayPalette Index, Pict(Index), bytes2
    End Select
    PictLoaded(Index) = True
    If PictLoaded(0) And PictLoaded(1) And _
        PictLoaded(1) Then
            mnuOpAverage.Enabled = True
            mnuOpVote.Enabled = True
    End If
    Exit Sub
LoadFileError:
    Beep
    MsgBox "Error loading file " & fname & "." & _
        vbCrLf & Error$
    Exit Sub
End Sub
Private Sub Form_Unload(Cancel As Integer)
    End
End Sub
' ************************************************
' Compute a voting average for the input images.
' ************************************************
Private Sub mnuOpVote_Click()
Dim x As Integer
Dim y As Integer
Dim maxx As Long
Dim maxy As Long
Dim c0 As Integer
Dim c1 As Integer
Dim c2 As Integer
Dim status As Long
    WaitStart
    ' Get bounds for the new image.
    maxx = wid(0)
    If maxx > wid(1) Then maxx = wid(1)
    If maxx > wid(2) Then maxx = wid(2)
    maxy = hgt(0)
    If maxy > hgt(1) Then maxy = hgt(1)
    If maxy > hgt(2) Then maxy = hgt(2)
    ' Size the result array.
    ReDim bytes3(1 To maxx, 1 To maxy)
    ' Create the result.
    For y = 1 To maxy
        For x = 1 To maxx
            c0 = NonstaticGrayValue(bytes0(x, y))
            c1 = NonstaticGrayValue(bytes1(x, y))
            c2 = NonstaticGrayValue(bytes2(x, y))
            If c0 = c1 Then
                bytes3(x, y) = _
                    NearestNonstaticGray(c0)
            ElseIf c1 = c2 Then
                bytes3(x, y) = _
                    NearestNonstaticGray(c1)
            ElseIf c2 = c1 Then
                bytes3(x, y) = _
                    NearestNonstaticGray(c2)
            Else
                bytes3(x, y) = _
                    NearestNonstaticGray((c0 + c1 + c2) / 3)
            End If
        Next x
    Next y
    ' Display the result.
    status = SetBitmapBits(Pict(3).Image, CLng(maxx) * maxy, bytes3(1, 1))
    Pict(3).Refresh
    WaitEnd
End Sub
' ************************************************
' Average the three input images.
' ************************************************
Private Sub mnuOpAverage_Click()
Dim x As Integer
Dim y As Integer
Dim maxx As Long
Dim maxy As Long
Dim c0 As Integer
Dim c1 As Integer
Dim c2 As Integer
Dim status As Long
    WaitStart
    ' Get bounds for the new image.
    maxx = wid(0)
    If maxx > wid(1) Then maxx = wid(1)
    If maxx > wid(2) Then maxx = wid(2)
    maxy = hgt(0)
    If maxy > hgt(1) Then maxy = hgt(1)
    If maxy > hgt(2) Then maxy = hgt(2)
    ' Size the result array.
    ReDim bytes3(1 To maxx, 1 To maxy)
    ' Create the result.
    For y = 1 To maxy
        For x = 1 To maxx
            c0 = NonstaticGrayValue(bytes0(x, y))
            c1 = NonstaticGrayValue(bytes1(x, y))
            c2 = NonstaticGrayValue(bytes2(x, y))
            bytes3(x, y) = _
                NearestNonstaticGray((c0 + c1 + c2) / 3)
        Next x
    Next y
    ' Display the result.
    status = SetBitmapBits(Pict(3).Image, CLng(maxx) * maxy, bytes3(1, 1))
    Pict(3).Refresh
    WaitEnd
End Sub
' ***********************************************
' 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 parameters.
'   wid(Index)  Width of image.
'   hgt(Index)  Height of image.
'   bytes(1 To wid, 1 To hgt)
'               Image pixel values.
' ***********************************************
Sub MatchGrayPalette(Index As Integer, pic As Control, bytes() As Byte)
Dim hPal As Integer
Dim sysentry(0 To 255) As PALETTEENTRY
Dim logentry(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, sysentry(0))

    ' Get the image pixels.
    hbm = pic.Image
    status = GetObject(hbm, BITMAP_SIZE, bm)
    wid(Index) = bm.bmWidthBytes
    hgt(Index) = bm.bmHeight
    ReDim bytes(1 To wid(Index), 1 To hgt(Index))
    status = GetBitmapBits(hbm, wid(Index) * hgt(Index), bytes(1, 1))
    ' Make the logical palette as big as possible.
    hPal = pic.Picture.hPal
    If ResizePalette(hPal, SysPalSize) = 0 Then
        Beep
        MsgBox "Error resizing logical palette.", _
            vbExclamation
        Exit Sub
    End If
    ' Blank the non-static colors.
    For i = 0 To StaticColor1
        logentry(i) = sysentry(i)
    Next i
    For i = StaticColor1 + 1 To StaticColor2 - 1
        With logentry(i)
            .peRed = 0
            .peGreen = 0
            .peBlue = 0
            .peFlags = PC_NOCOLLAPSE
        End With
    Next i
    For i = StaticColor2 To 255
        logentry(i) = sysentry(i)
    Next i
    i = SetPaletteEntries(hPal, 0, SysPalSize, logentry(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 logentry(i)
            .peRed = c
            .peGreen = c
            .peBlue = c
        End With
    Next i
    i = SetPaletteEntries(hPal, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, logentry(StaticColor1 + 1))
    ' Recreate the image using the new colors.
    For y = 1 To hgt(Index)
        For x = 1 To wid(Index)
            clr = bytes(x, y)
            With sysentry(clr)
                c = (CInt(.peRed) + .peGreen + .peBlue) / 3
            End With
            bytes(x, y) = NearestNonstaticGray(c)
        Next x
    Next y
    status = SetBitmapBits(hbm, wid(Index) * hgt(Index), bytes(1, 1))
    ' Realize the gray palette.
    i = RealizePalette(pic.hdc)
    pic.Refresh
End Sub
' ***********************************************
' Give the form and all the picture boxes an
' hourglass cursor.
' ***********************************************
Sub WaitStart()
Dim i As Integer
    MousePointer = vbHourglass
    For i = 0 To 2
        Pict(i).MousePointer = vbHourglass
    Next i
    DoEvents
End Sub
' ***********************************************
' Restore the mouse pointers for the form and all
' the picture boxes.
' ***********************************************
Sub WaitEnd()
Dim i As Integer
    MousePointer = vbDefault
    For i = 0 To 2
        Pict(i).MousePointer = vbDefault
    Next i
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
    dgray = 255 / (StaticColor2 - StaticColor1 - 2)
    ' Fill the result picture's palette with grays.
    MatchGrayPalette 3, Pict(3), bytes3
End Sub
' ***********************************************
' Make the picture as large as possible.
' ***********************************************
Private Sub Form_Resize()
Const GAP = 2
Dim wid As Single
Dim hgt As Single
    If WindowState = vbMinimized Then Exit Sub

    wid = (ScaleWidth - GAP - 1) / 2
    hgt = (ScaleHeight - GAP - 1) / 2
    Pict(0).Move 0, 0, wid, hgt
    Pict(1).Move Pict(0).Left + Pict(0).Width + GAP, _
        0, wid, hgt
    Pict(2).Move 0, Pict(1).Top + Pict(1).Height + GAP, _
        wid, hgt
    Pict(3).Move Pict(2).Left + Pict(2).Width + GAP, _
        Pict(2).Top, wid, hgt
End Sub
' ***********************************************
' Load a new image file.
' ***********************************************
Private Sub mnuFileLoad_Click(Index As Integer)
Dim fname As String
Dim i As Integer
    ' 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
    LoadPict Index, fname

    ' Move each picture to the top so each can get
    ' its color palette updated.
    For i = 0 To 2
        Pict(i).ZOrder
        DoEvents
    Next i
    WaitEnd
End Sub
' ***********************************************
' End the application. (See also the QueryUnload
' event.)
' ***********************************************
Private Sub mnuFileExit_Click()
    Unload Me
End Sub