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

Visual Basic Form | 1997-01-03 | 17.4 KB | 533 lines

VERSION 4.00
Begin VB.Form CompositeForm2
   Caption         =   "Composite2"
   ClientHeight    =   5895
   ClientLeft      =   1215
   ClientTop       =   585
   ClientWidth     =   6510
   Height          =   6300
   Left            =   1155
   LinkTopic       =   "Form1"
   ScaleHeight     =   393
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   434
   Top             =   240
   Width           =   6630
   Begin VB.PictureBox DestPict
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      Height          =   75
      Left            =   6120
      Picture         =   "COMPOSE2.frx":0000
      ScaleHeight     =   1
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   1
      TabIndex        =   7
      Top             =   1440
      Visible         =   0   'False
      Width           =   75
   End
   Begin VB.PictureBox Mask2Pict
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      Height          =   75
      Left            =   6120
      Picture         =   "COMPOSE2.frx":0446
      ScaleHeight     =   1
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   1
      TabIndex        =   6
      Top             =   960
      Visible         =   0   'False
      Width           =   75
   End
   Begin VB.PictureBox Mask1Pict
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      Height          =   75
      Left            =   6120
      Picture         =   "COMPOSE2.frx":088C
      ScaleHeight     =   1
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   1
      TabIndex        =   5
      Top             =   480
      Visible         =   0   'False
      Width           =   75
   End
   Begin VB.PictureBox SourcePict
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      Height          =   75
      Left            =   6120
      Picture         =   "COMPOSE2.frx":0CD2
      ScaleHeight     =   1
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   1
      TabIndex        =   4
      Top             =   0
      Visible         =   0   'False
      Width           =   75
   End
   Begin VB.PictureBox DisplaySwin
      Height          =   5655
      Left            =   0
      ScaleHeight     =   373
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   413
      TabIndex        =   2
      Top             =   0
      Width           =   6255
      Begin VB.PictureBox DisplayPict
         AutoRedraw      =   -1  'True
         Height          =   5535
         Left            =   0
         Picture         =   "COMPOSE2.frx":1118
         ScaleHeight     =   365
         ScaleMode       =   3  'Pixel
         ScaleWidth      =   405
         TabIndex        =   3
         Top             =   0
         Width           =   6135
      End
   End
   Begin VB.HScrollBar DisplayHBar
      Enabled         =   0   'False
      Height          =   255
      Left            =   0
      TabIndex        =   1
      Top             =   5640
      Width           =   6285
   End
   Begin VB.VScrollBar DisplayVBar
      Enabled         =   0   'False
      Height          =   5655
      Left            =   6240
      TabIndex        =   0
      Top             =   0
      Width           =   255
   End
Attribute VB_Name = "CompositeForm2"
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_source() As Byte
Dim bytes_dest() As Byte
Dim bytes_mask1() As Byte
Dim bytes_mask2() As Byte
Dim wid(0 To 3) As Long
Dim hgt(0 To 3) As Long
Dim palentry(0 To 255) As PALETTEENTRY
' ************************************************
' Create and display the composite image.
' ************************************************
Public Sub MakeComposite(xoff As Integer, yoff As Integer)
Dim bound As Integer
Dim mid_weight As Integer
Dim xmin As Integer
Dim ymin As Integer
Dim xmax As Integer
Dim ymax As Integer
Dim x As Integer
Dim y As Integer
Dim black As Integer
Dim white As Integer
Dim status As Long
Dim i As Integer
Dim j As Integer
Dim kernel() As Single
Dim wgt As Single
Dim bytes_mask1a() As Byte
Dim r1 As Integer
Dim r2 As Integer
Dim dest_factor As Single
    WaitStart
    SourcePict.Visible = False
    DestPict.Visible = False
    Mask1Pict.Visible = False
    Mask2Pict.Visible = False
    ' See where source and destination overlap.
    xmin = 1 + xoff
    If xmin < 1 Then xmin = 1
    ymin = 1 + yoff
    If ymin < 1 Then ymin = 1
    xmax = wid(0) + xoff
    If xmax > wid(1) Then xmax = wid(1)
    ymax = hgt(0) + yoff
    If ymax > hgt(1) Then ymax = hgt(1)
    ' Show the user what's going on.
    DisplayPict.Move 0, 0, Mask1Pict.Width, Mask1Pict.Height
    DoEvents
    status = SetBitmapBits(DisplayPict.Image, wid(2) * hgt(2), bytes_mask1(1, 1))
    DisplayPict.Refresh
    ' Step 0: Combine the two masks into one.
    white = StaticColor2 - 1
    black = StaticColor1 + 1
    For y = ymin To ymax
        For x = xmin To xmax
            If bytes_mask2(x, y) = black Then _
                bytes_mask1(x - xoff, y - yoff) = white
        Next x
    Next y
    ' Show the user what's going on.
    status = SetBitmapBits(DisplayPict.Image, wid(2) * hgt(2), bytes_mask1(1, 1))
    DisplayPict.Refresh
    ' Step 1: Low pass filter the source mask.
    ' Create a 3x3 low pass kernel.
    bound = 1
    mid_weight = 1
    ReDim kernel(-bound To bound, -bound To bound)
    For i = -bound To bound
        For j = -bound To bound
            kernel(i, j) = 1
        Next j
    Next i
    kernel(0, 0) = mid_weight
    wgt = (2 * bound + 1) * (2 * bound + 1) - 1 + mid_weight
    ' Apply the filter.
    ReDim bytes_mask1a(1 To wid(2), 1 To hgt(2))
    For y = bound + 1 To hgt(2) - bound
        For x = bound + 1 To wid(2) - bound
            r1 = 0
            For i = -bound To bound
                For j = -bound To bound
                    r1 = r1 + kernel(i, j) * palentry(bytes_mask1(x + i, y + j)).peRed
                Next j
            Next i
            r1 = r1 / wgt
            bytes_mask1a(x, y) = NearestNonstaticGray(r1)
        Next x
    Next y
    ' Blank the edges of the mask.
    For y = 1 To hgt(2)
        For x = 1 To bound
            bytes_mask1a(x, y) = white
            bytes_mask1a(wid(2) - x + 1, y) = white
        Next x
    Next y
    For x = 1 To wid(2)
        For y = 1 To bound
            bytes_mask1a(x, y) = white
            bytes_mask1a(x, hgt(2) - y + 1) = white
        Next y
    Next x
    ' Show the user what's going on.
    status = SetBitmapBits(DisplayPict.Image, wid(2) * hgt(2), bytes_mask1a(1, 1))
    DisplayPict.Refresh
    ' Take a weighted average of the two images
    ' using the mask.
    For y = ymin To ymax
        For x = xmin To xmax
            dest_factor = palentry(bytes_mask1a(x - xoff, y - yoff)).peRed / 255#
            r1 = palentry(bytes_source(x - xoff, y - yoff)).peRed
            r2 = palentry(bytes_dest(x, y)).peRed
            bytes_dest(x, y) = NearestNonstaticGray((1 - dest_factor) * r1 + dest_factor * r2)
        Next x
    Next y
    ' Display the result.
    status = SetBitmapBits(DisplayPict.Image, wid(1) * hgt(1), bytes_dest(1, 1))
    DisplayPict.Refresh
    DisplayPict.Picture = DisplayPict.Image
    ResetScrollBars
    WaitEnd
    ' This will definitely take a long time so
    ' wake the user.
    Beep
End Sub
' ************************************************
' 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. Return true if we cannot
' load the files.
' ***********************************************
Public Function LoadFiles(source_name As String, dest_name As String, mask1_name As String, mask2_name As String) As Boolean
Dim fname As String
Dim i As Integer
    WaitStart
    LoadFiles = False
    ' Create DisplayPict's palette.
    MatchGrayPalette 0, DisplayPict, bytes_source
    DoEvents    ' Don't be a total CPU hog.
    ' Load the source file.
    fname = source_name
    SourcePict.Move 0, 0
    SourcePict.Visible = True
    On Error GoTo LoadFileError
    SourcePict.Picture = LoadPicture(fname)
    On Error GoTo 0
    MatchGrayPalette 0, SourcePict, bytes_source
    DoEvents    ' Don't be a total CPU hog.
    ' Load the destination file.
    fname = dest_name
    DestPict.Move 0, 0
    DestPict.Visible = True
    On Error GoTo LoadFileError
    DestPict.Picture = LoadPicture(fname)
    On Error GoTo 0
    MatchGrayPalette 1, DestPict, bytes_dest
    DoEvents    ' Don't be a total CPU hog.
    ' Load mask1.
    fname = mask1_name
    Mask1Pict.Move 0, 0
    Mask1Pict.Visible = True
    On Error GoTo LoadFileError
    Mask1Pict.Picture = LoadPicture(fname)
    On Error GoTo 0
    MatchGrayPalette 2, Mask1Pict, bytes_mask1
    DoEvents    ' Don't be a total CPU hog.
    ' Load mask2.
    fname = mask2_name
    Mask2Pict.Move 0, 0
    Mask2Pict.Visible = True
    On Error GoTo LoadFileError
    Mask2Pict.Picture = LoadPicture(fname)
    On Error GoTo 0
    MatchGrayPalette 3, Mask2Pict, bytes_mask2
    DoEvents    ' Don't be a total CPU hog.
    ' Rerealize each palette.
    SourcePict.ZOrder
    DoEvents
    DestPict.ZOrder
    DoEvents
    Mask1Pict.ZOrder
    DoEvents
    Mask2Pict.ZOrder
    DoEvents
    WaitEnd
    Exit Function
LoadFileError:
    Beep
    MsgBox "Error loading file " & fname & "." & _
        vbCrLf & Error$
    WaitEnd
    LoadFiles = True
    Exit Function
End Function
' ***********************************************
' 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.
'   palentry()  Image logical palette entries.
'   wid         Width of image.
'   hgt         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 logpal As Integer
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(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.
    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
        palentry(i) = sys(i)
    Next i
    For i = StaticColor1 + 1 To StaticColor2 - 1
        With palentry(i)
            .peRed = 0
            .peGreen = 0
            .peBlue = 0
            .peFlags = PC_NOCOLLAPSE
        End With
    Next i
    For i = StaticColor2 To 255
        palentry(i) = sys(i)
    Next i
    i = SetPaletteEntries(logpal, 0, SysPalSize, palentry(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 palentry(i)
            .peRed = c
            .peGreen = c
            .peBlue = c
        End With
    Next i
    i = SetPaletteEntries(logpal, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, palentry(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 sys(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
' ***********************************************
' Set the Max and LargeChange properties for the
' image scroll bars.
' ***********************************************
Sub ResetScrollBars()
    ' DisplayHBar.
    DisplayHBar.Value = 0
    If DisplaySwin.ScaleWidth >= DisplayPict.Width Then
        DisplayHBar.Enabled = False
    Else
        DisplayHBar.Max = DisplayPict.Width - DisplaySwin.ScaleWidth
        DisplayHBar.LargeChange = DisplaySwin.ScaleWidth
        DisplayHBar.Enabled = True
    End If
    ' DisplayVBar.
    DisplayVBar.Value = 0
    If DisplaySwin.ScaleHeight >= DisplayPict.Height Then
        DisplayVBar.Enabled = False
    Else
        DisplayVBar.Max = DisplayPict.Height - DisplaySwin.ScaleHeight
        DisplayVBar.LargeChange = DisplaySwin.ScaleHeight
        DisplayVBar.Enabled = True
    End If
End Sub
' ***********************************************
' Give the form and all the picture boxes an
' hourglass cursor.
' ***********************************************
Sub WaitStart()
    MousePointer = vbHourglass
    DisplayPict.MousePointer = vbHourglass
    SourcePict.MousePointer = vbHourglass
    DestPict.MousePointer = vbHourglass
    Mask1Pict.MousePointer = vbHourglass
    Mask2Pict.MousePointer = vbHourglass
    DoEvents
End Sub
' ***********************************************
' Restore the mouse pointers for the form and all
' the picture boxes.
' ***********************************************
Sub WaitEnd()
    MousePointer = vbDefault
    DisplayPict.MousePointer = vbDefault
    SourcePict.MousePointer = vbDefault
    DestPict.MousePointer = vbDefault
    Mask1Pict.MousePointer = vbDefault
    Mask2Pict.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 DisplayPict.
    DisplayPict.BorderStyle = vbTransparent
    SourcePict.BorderStyle = vbTransparent
    DestPict.BorderStyle = vbTransparent
    Mask1Pict.BorderStyle = vbTransparent
    Mask2Pict.BorderStyle = vbTransparent
End Sub
' ***********************************************
' Make the picture as large as possible.
' ***********************************************
Private Sub Form_Resize()
Dim hgt As Single
Dim wid As Single
    If WindowState = vbMinimized Then Exit Sub

    hgt = ScaleHeight - DisplayHBar.Height - 1
    wid = ScaleWidth - DisplayVBar.Width - 1
    ' Place the controls.
    DisplaySwin.Move 0, 0, wid, hgt
    DisplayVBar.Move _
        DisplaySwin.Left + DisplaySwin.Width + 1, _
        0, DisplayVBar.Width, hgt
    DisplayHBar.Move _
        DisplaySwin.Left, DisplaySwin.Height + 1, _
        wid
    ' Set the scroll bar limits.
    ResetScrollBars
End Sub
' ***********************************************
' Move DisplayPict within DisplaySwin.
' ***********************************************
Private Sub DisplayHBar_Change()
    DisplayPict.Left = -DisplayHBar.Value
End Sub
' ***********************************************
' Move DisplayPict within DisplaySwin.
' ***********************************************
Private Sub DisplayHBar_Scroll()
    DisplayPict.Left = -DisplayHBar.Value
End Sub
' ***********************************************
' Move DisplayPict within DisplaySwin.
' ***********************************************
Private Sub DisplayVBar_Change()
    DisplayPict.Top = -DisplayVBar.Value
End Sub
' ***********************************************
' Move DisplayPict within DisplaySwin.
' ***********************************************
Private Sub DisplayVBar_Scroll()
    DisplayPict.Top = -DisplayVBar.Value
End Sub
Private Sub Form_Unload(Cancel As Integer)
    End
End Sub