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

Visual Basic Form | 1997-01-03 | 21.5 KB | 690 lines

VERSION 4.00
Begin VB.Form ResizeForm
   Caption         =   "Resize"
   ClientHeight    =   5430
   ClientLeft      =   1275
   ClientTop       =   1065
   ClientWidth     =   6885
   Height          =   6120
   Left            =   1215
   LinkTopic       =   "Form1"
   ScaleHeight     =   362
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   459
   Top             =   435
   Width           =   7005
   Begin VB.HScrollBar HBar
      Enabled         =   0   'False
      Height          =   255
      Index           =   1
      Left            =   3480
      SmallChange     =   10
      TabIndex        =   9
      Top             =   5160
      Width           =   3135
   End
   Begin VB.VScrollBar VBar
      Enabled         =   0   'False
      Height          =   4455
      Index           =   1
      Left            =   6600
      SmallChange     =   10
      TabIndex        =   8
      Top             =   720
      Width           =   255
   End
   Begin VB.PictureBox Swin
      Height          =   4455
      Index           =   1
      Left            =   3480
      ScaleHeight     =   293
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   205
      TabIndex        =   7
      Top             =   720
      Width           =   3135
      Begin VB.PictureBox Pict
         AutoRedraw      =   -1  'True
         BorderStyle     =   0  'None
         Height          =   1950
         Index           =   1
         Left            =   0
         Picture         =   "RESIZEF.frx":0000
         ScaleHeight     =   130
         ScaleMode       =   3  'Pixel
         ScaleWidth      =   154
         TabIndex        =   10
         Top             =   0
         Width           =   2310
      End
   End
   Begin VB.HScrollBar HBar
      Enabled         =   0   'False
      Height          =   255
      Index           =   0
      Left            =   0
      SmallChange     =   10
      TabIndex        =   6
      Top             =   5160
      Width           =   3135
   End
   Begin VB.VScrollBar VBar
      Enabled         =   0   'False
      Height          =   4455
      Index           =   0
      Left            =   3120
      SmallChange     =   10
      TabIndex        =   5
      Top             =   720
      Width           =   255
   End
   Begin VB.PictureBox Swin
      Height          =   4455
      Index           =   0
      Left            =   0
      ScaleHeight     =   293
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   205
      TabIndex        =   3
      Top             =   720
      Width           =   3135
      Begin VB.PictureBox Pict
         AutoRedraw      =   -1  'True
         AutoSize        =   -1  'True
         BorderStyle     =   0  'None
         Height          =   15
         Index           =   0
         Left            =   0
         Picture         =   "RESIZEF.frx":0446
         ScaleHeight     =   1
         ScaleMode       =   3  'Pixel
         ScaleWidth      =   1
         TabIndex        =   4
         Top             =   0
         Width           =   15
      End
   End
   Begin VB.CommandButton CmdGo
      Caption         =   "Go"
      Default         =   -1  'True
      Enabled         =   0   'False
      Height          =   375
      Left            =   1200
      TabIndex        =   2
      Top             =   0
      Width           =   615
   End
   Begin VB.TextBox ScaleText
      Height          =   285
      Left            =   480
      TabIndex        =   1
      Text            =   "1.0"
      Top             =   0
      Width           =   615
   End
   Begin VB.Label SizeLabel
      Alignment       =   2  'Center
      Height          =   255
      Index           =   1
      Left            =   3480
      TabIndex        =   12
      Top             =   420
      Width           =   3135
   End
   Begin VB.Label SizeLabel
      Alignment       =   2  'Center
      Height          =   255
      Index           =   0
      Left            =   0
      TabIndex        =   11
      Top             =   420
      Width           =   3135
   End
   Begin VB.Label Label2
      Caption         =   "Scale"
      Height          =   255
      Left            =   0
      TabIndex        =   0
      Top             =   0
      Width           =   495
   End
   Begin MSComDlg.CommonDialog FileDialog
      Left            =   1920
      Top             =   -120
      _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 mnuFileSaveAs
         Caption         =   "Save As..."
         Shortcut        =   ^A
      End
      Begin VB.Menu mnuFileSep
         Caption         =   "-"
      End
      Begin VB.Menu mnuFileExit
         Caption         =   "E&xit"
      End
   End
Attribute VB_Name = "ResizeForm"
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 LogPal As Integer
Dim palentry(0 To 255) As PALETTEENTRY
Dim wid As Long
Dim hgt As Long
Dim bytes() As Byte
Dim ScaleFactor As Single
' ************************************************
' Draw the resized image at the proper scale.
' ************************************************
Sub DrawImages()
Dim wid As Single
Dim hgt As Single
    WaitStart
    ScaleFactor = CSng(ScaleText.Text)
    ' Resize using ShrinkPicture or EnlargePicture.
    wid = Pict(0).ScaleWidth * ScaleFactor
    hgt = Pict(0).ScaleHeight * ScaleFactor
    Pict(1).Width = wid
    Pict(1).Height = hgt
    Pict(1).Cls
    SizeLabel(1).Caption = _
        Format$(Pict(1).ScaleWidth) & " x " & _
        Format$(Pict(1).ScaleHeight)
    If ScaleFactor > 1 Then
        EnlargePicture Pict(0), Pict(1), _
            0, 0, Pict(0).ScaleWidth - 2, Pict(0).ScaleHeight - 2, _
            0, 0, wid - 1, hgt - 1
    Else
        ShrinkPicture Pict(0), Pict(1), _
            0, 0, Pict(0).ScaleWidth - 1, Pict(0).ScaleHeight - 1, _
            0, 0, wid - 1, hgt - 1
    End If
    DoEvents
    ' Let each image repair its palette if needed.
    Pict(0).ZOrder
    DoEvents
    Pict(1).ZOrder
    DoEvents
    HBar(1).Value = 0
    VBar(1).Value = 0
    wid = Pict(1).Width - Swin(1).ScaleWidth
    If wid > 0 Then
        HBar(1).Max = wid
        HBar(1).Enabled = True
    Else
        HBar(1).Enabled = False
    End If
    hgt = Pict(1).Height - Swin(1).ScaleHeight
    If hgt > 0 Then
        VBar(1).Max = hgt
        VBar(1).Enabled = True
    Else
        VBar(1).Enabled = False
    End If
    WaitEnd
End Sub
' ************************************************
' Enlarge the picture in from_pic and place it
' in to_pic.
' ************************************************
Sub EnlargePicture( _
    ByVal from_pic As Control, ByVal to_pic As Control, _
    ByVal fx1 As Integer, ByVal fy1 As Integer, _
    ByVal fx2 As Integer, ByVal fy2 As Integer, _
    ByVal tx1 As Integer, ByVal ty1 As Integer, _
    ByVal tx2 As Integer, ByVal ty2 As Integer)
Dim bm As BITMAP
Dim hbm As Integer
Dim status As Long
Dim from_bytes() As Byte
Dim to_bytes() As Byte
Dim from_wid As Long
Dim from_hgt As Long
Dim to_wid As Long
Dim to_hgt As Long
Dim xscale As Single
Dim yscale As Single
Dim tx As Integer
Dim ty As Integer
Dim fx As Single
Dim fy As Single
Dim ifx As Single
Dim ify As Single
Dim dx As Single
Dim dy As Single
Dim c1 As Integer
Dim c2 As Integer
Dim c3 As Integer
Dim c4 As Integer
Dim i1 As Integer
Dim i2 As Integer
Dim clr As Integer
    ' Compute the scaling parameters.
    xscale = (tx2 - tx1) / (fx2 - fx1)
    yscale = (ty2 - ty1) / (fy2 - fy1)
    ' Get from_pic's pixels.
    hbm = from_pic.Image
    status = GetObject(hbm, BITMAP_SIZE, bm)
    from_wid = bm.bmWidthBytes
    from_hgt = bm.bmHeight
    ReDim from_bytes(0 To from_wid - 1, 0 To from_hgt - 1)
    status = GetBitmapBits(hbm, from_wid * from_hgt, from_bytes(0, 0))
    ' Get to_pic's pixels.
    hbm = to_pic.Image
    status = GetObject(hbm, BITMAP_SIZE, bm)
    to_wid = bm.bmWidthBytes
    to_hgt = bm.bmHeight
    ReDim to_bytes(0 To to_wid - 1, 0 To to_hgt - 1)
    status = GetBitmapBits(hbm, to_wid * to_hgt, to_bytes(0, 0))

    ' Perform the enlargement.
    For ty = ty1 To ty2
        fy = (ty - ty1) / yscale + fy1
        ify = Int(fy)
        dy = fy - ify
        For tx = tx1 To tx2
            fx = (tx - tx1) / xscale + fx1
            ifx = Int(fx)
            dx = fx - ifx
            ' Interpolate using the four nearest
            ' pixels in from_pic.
            c1 = palentry(from_bytes(ifx, ify)).peRed
            c2 = palentry(from_bytes(ifx + 1, ify)).peRed
            c3 = palentry(from_bytes(ifx, ify + 1)).peRed
            c4 = palentry(from_bytes(ifx + 1, ify + 1)).peRed
            ' Interpolate in the Y direction.
            i1 = c1 * (1 - dy) + c3 * dy
            i2 = c2 * (1 - dy) + c4 * dy
            ' Interpolate the results in the X direction.
            clr = i1 * (1 - dx) + i2 * dx
            to_bytes(tx, ty) = NearestNonstaticGray(clr)
        Next tx
    Next ty
    ' Update from_pic.
    status = SetBitmapBits(hbm, to_wid * to_hgt, to_bytes(0, 0))
    to_pic.Refresh
End Sub
' ************************************************
' Shrink the picture in from_pic and place it
' in to_pic.
' ************************************************
Sub ShrinkPicture( _
    ByVal from_pic As Control, ByVal to_pic As Control, _
    ByVal fx1 As Integer, ByVal fy1 As Integer, _
    ByVal fx2 As Integer, ByVal fy2 As Integer, _
    ByVal tx1 As Integer, ByVal ty1 As Integer, _
    ByVal tx2 As Integer, ByVal ty2 As Integer)
Dim bm As BITMAP
Dim hbm As Integer
Dim status As Long
Dim from_bytes() As Byte
Dim to_bytes() As Byte
Dim from_wid As Long
Dim from_hgt As Long
Dim to_wid As Long
Dim to_hgt As Long
Dim xscale As Single
Dim yscale As Single
Dim tx As Integer
Dim ty As Integer
Dim x1 As Integer
Dim y1 As Integer
Dim x2 As Integer
Dim y2 As Integer
Dim X As Integer
Dim Y As Integer
Dim clr As Integer
    ' Compute the scaling parameters.
    xscale = (tx2 - tx1) / (fx2 - fx1)
    yscale = (ty2 - ty1) / (fy2 - fy1)
    ' Get from_pic's pixels.
    hbm = from_pic.Image
    status = GetObject(hbm, BITMAP_SIZE, bm)
    from_wid = bm.bmWidthBytes
    from_hgt = bm.bmHeight
    ReDim from_bytes(0 To from_wid - 1, 0 To from_hgt - 1)
    status = GetBitmapBits(hbm, from_wid * from_hgt, from_bytes(0, 0))
    ' Get to_pic's pixels.
    hbm = to_pic.Image
    status = GetObject(hbm, BITMAP_SIZE, bm)
    to_wid = bm.bmWidthBytes
    to_hgt = bm.bmHeight
    ReDim to_bytes(0 To to_wid - 1, 0 To to_hgt - 1)
    status = GetBitmapBits(hbm, to_wid * to_hgt, to_bytes(0, 0))

    ' Skrink the image.
    For ty = ty1 To ty2 - 1
        y1 = Int((ty - ty1) / yscale + fy1)
        y2 = Int((ty + 1 - ty1) / yscale + fy1) - 1
        For tx = tx1 To tx2 - 1
            x1 = Int((tx - tx1) / xscale + fx1)
            x2 = Int((tx + 1 - tx1) / xscale + fx1) - 1
            ' Average the values within the
            ' from_pic box (x1, y1) - (x2, y2).
            clr = 0
            For Y = y1 To y2
                For X = x1 To x2
                    clr = clr + palentry(from_bytes(X, Y)).peRed
                Next X
            Next Y
            clr = clr / (x2 - x1 + 1) / (y2 - y1 + 1)
            to_bytes(tx, ty) = NearestNonstaticGray(clr)
        Next tx
    Next ty
    ' Update from_pic.
    status = SetBitmapBits(hbm, to_wid * to_hgt, to_bytes(0, 0))
    to_pic.Refresh
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 module global variables.
'   LogPal      Image logical palette handle.
'   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(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
        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
        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 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
Private Sub CmdGo_Click()
    DrawImages
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
    ' Make the pictures all use gray palettes.
    ScaleFactor = 1
    Me.Show
    WaitStart
    MatchGrayPalette Pict(0)
    MatchGrayPalette Pict(1)
    DoEvents
    ' Let each image repair its palette if needed.
    Pict(0).ZOrder
    DoEvents
    Pict(1).ZOrder
    DoEvents
    WaitEnd
End Sub
' ***********************************************
' Reset the cursors for the form and all the
' picture boxes.
' ***********************************************
Sub WaitEnd()
    MousePointer = vbDefault
End Sub
' ***********************************************
' Give the form and all the picture boxes an
' hourglass cursor.
' ***********************************************
Sub WaitStart()
    MousePointer = vbHourglass
    DoEvents
End Sub
Private Sub Form_Resize()
Const GAP = 5
Dim wid As Single
Dim status As Long
    If WindowState = 1 Then Exit Sub
    wid = (ScaleWidth - 2 * VBar(0).Width - 2 - GAP) / 2
    hgt = ScaleHeight - HBar(0).Height - Swin(0).Top - 1
    SizeLabel(0).Move 0, SizeLabel(0).Top, wid
    Swin(0).Move 0, Swin(0).Top, wid, hgt
    HBar(0).Move 0, Swin(0).Top + Swin(0).Height + 1, _
        wid
    VBar(0).Move Swin(0).Left + Swin(0).Width + 1, _
        Swin(0).Top, VBar(0).Width, hgt
    HBar(0).LargeChange = Swin(0).ScaleWidth
    VBar(0).LargeChange = Swin(0).ScaleHeight
    SizeLabel(1).Move VBar(0).Left + VBar(0).Width + GAP, _
        SizeLabel(1).Top, wid
    Swin(1).Move SizeLabel(1).Left, _
        Swin(1).Top, wid, hgt
    HBar(1).Move Swin(1).Left, Swin(1).Top + Swin(1).Height + 1, _
        wid
    VBar(1).Move Swin(1).Left + Swin(1).Width + 1, _
        Swin(1).Top, VBar(1).Width, hgt
    HBar(1).LargeChange = Swin(1).ScaleWidth
    VBar(1).LargeChange = Swin(1).ScaleHeight
    If HBar(0).Enabled Then
        HBar(0).Max = Pict(0).Width - Swin(0).ScaleWidth
        VBar(0).Max = Pict(0).Height - Swin(0).ScaleHeight
    End If
    If HBar(1).Enabled Then
        HBar(1).Max = Pict(1).Width - Swin(1).ScaleWidth
        VBar(1).Max = Pict(1).Height - Swin(1).ScaleHeight
    End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
    End
End Sub
Private Sub HBar_Change(Index As Integer)
    Pict(Index).Left = -HBar(Index).Value
End Sub
Private Sub HBar_Scroll(Index As Integer)
    HBar_Change Index
End Sub
Private Sub mnuFileExit_Click()
    Unload Me
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
' ***********************************************
' Load the indicated file and prepare to work
' with its palette.
' ***********************************************
Sub LoadFromPict(fname As String)
Dim status As Long
Dim wid As Integer
Dim hgt As Integer
    On Error GoTo LoadFileError
    Pict(0).Picture = LoadPicture(fname)
    On Error GoTo 0

    MatchGrayPalette Pict(0)
    CmdGo.Enabled = True
    HBar(0).Value = 0
    VBar(0).Value = 0
    HBar(0).Max = Pict(0).Width - Swin(0).ScaleWidth
    VBar(0).Max = Pict(0).Height - Swin(0).ScaleHeight
    wid = Pict(0).Width - Swin(0).ScaleWidth
    If wid > 0 Then
        HBar(0).Max = wid
        HBar(0).Enabled = True
    Else
        HBar(0).Enabled = False
    End If
    hgt = Pict(0).Height - Swin(0).ScaleHeight
    If hgt > 0 Then
        VBar(0).Max = hgt
        VBar(0).Enabled = True
    Else
        VBar(0).Enabled = False
    End If
    SizeLabel(0).Caption = Format$(Pict(0).ScaleWidth) & " x " & Format$(Pict(0).ScaleHeight)
    Caption = "Resize [" & fname & "]"
    Exit Sub
LoadFileError:
    Beep
    MsgBox "Error loading file " & fname & "." & _
        vbCrLf & Error$
    Exit Sub
End Sub
' ************************************************
' Allow the user to save the resized bitmap.
' ************************************************
Private Sub mnuFileSaveAs_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 = cdlOFNOverwritePrompt + cdlOFNHideReadOnly
    FileDialog.ShowSave
    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)
    ' Save the picture.
    WaitStart
    SavePicture Pict(1).Image, fname
    WaitEnd
End Sub
Private Sub VBar_Change(Index As Integer)
    Pict(Index).Top = -VBar(Index).Value
End Sub
Private Sub VBar_Scroll(Index As Integer)
    VBar_Change Index
End Sub