Visual Basic Graphics Programming (2nd Edition)/Visual Basic Graphics Programming 2nd Edition.iso/OldSrc/CH6/SRC/AALIAS3.FRM

Visual Basic Form | 1997-01-08 | 15.5 KB | 503 lines

VERSION 4.00
Begin VB.Form AntiAliasForm
   Caption         =   "Anti-Aliasing"
   ClientHeight    =   4485
   ClientLeft      =   1905
   ClientTop       =   1275
   ClientWidth     =   5835
   DrawMode        =   14  'Copy Pen
   Height          =   5175
   Left            =   1845
   LinkTopic       =   "Form1"
   ScaleHeight     =   299
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   389
   Top             =   645
   Width           =   5955
   Begin VB.CheckBox GrayCheck
      Caption         =   "Gray"
      Height          =   255
      Left            =   3120
      TabIndex        =   9
      Top             =   45
      Value           =   1  'Checked
      Width           =   735
   End
   Begin VB.CommandButton CmdGo
      Caption         =   "Go"
      Default         =   -1  'True
      Height          =   375
      Left            =   4080
      TabIndex        =   8
      Top             =   0
      Width           =   615
   End
   Begin VB.TextBox ScaleText
      Height          =   285
      Left            =   2520
      TabIndex        =   6
      Text            =   "2"
      Top             =   30
      Width           =   375
   End
   Begin VB.PictureBox EnlargedPic
      AutoRedraw      =   -1  'True
      BackColor       =   &H00C0C0C0&
      ForeColor       =   &H00000000&
      Height          =   3870
      Left            =   1965
      Picture         =   "AALIAS3.frx":0000
      ScaleHeight     =   254
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   254
      TabIndex        =   4
      Top             =   600
      Width           =   3870
   End
   Begin VB.PictureBox AntiAliasedPic
      AutoRedraw      =   -1  'True
      BackColor       =   &H00C0C0C0&
      ForeColor       =   &H00000000&
      Height          =   1935
      Left            =   0
      Picture         =   "AALIAS3.frx":0446
      ScaleHeight     =   125
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   125
      TabIndex        =   2
      Top             =   2520
      Width           =   1935
   End
   Begin VB.PictureBox AliasedPic
      AutoRedraw      =   -1  'True
      BackColor       =   &H00C0C0C0&
      BeginProperty Font
         name            =   "Times New Roman"
         charset         =   0
         weight          =   700
         size            =   15.75
         underline       =   0   'False
         italic          =   -1  'True
         strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00000000&
      Height          =   1935
      Left            =   0
      Picture         =   "AALIAS3.frx":088C
      ScaleHeight     =   125
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   125
      TabIndex        =   0
      Top             =   240
      Width           =   1935
   End
   Begin VB.Label Label1
      Caption         =   "Scale"
      Height          =   255
      Index           =   3
      Left            =   2040
      TabIndex        =   7
      Top             =   45
      Width           =   495
   End
   Begin VB.Label Label1
      Caption         =   "Enlarged"
      Height          =   255
      Index           =   2
      Left            =   1965
      TabIndex        =   5
      Top             =   360
      Width           =   735
   End
   Begin VB.Label Label1
      Caption         =   "Anti-Aliased"
      Height          =   255
      Index           =   1
      Left            =   0
      TabIndex        =   3
      Top             =   2280
      Width           =   975
   End
   Begin VB.Label Label1
      Caption         =   "Aliased"
      Height          =   255
      Index           =   0
      Left            =   0
      TabIndex        =   1
      Top             =   0
      Width           =   615
   End
   Begin VB.Menu mnuFile
      Caption         =   "&File"
      Begin VB.Menu mnuFileExit
         Caption         =   "E&xit"
      End
   End
Attribute VB_Name = "AntiAliasForm"
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 syspal(0 To 255) As PALETTEENTRY
' ************************************************
' Draw some stuff to work with.
' ************************************************
Sub GrayDrawStuff(pic As PictureBox)
Const PI = 3.14159
Const MSG = "Smile!"
Dim x1 As Single
Dim x2 As Single
Dim x3 As Single
Dim x4 As Single
Dim x5 As Single
Dim x6 As Single
Dim x7 As Single
Dim y1 As Single
Dim y2 As Single
Dim dy As Single
Dim r1 As Single
Dim r2 As Single
Dim r3 As Single
Dim r4 As Single
    x1 = pic.ScaleWidth * 0.4
    x2 = pic.ScaleWidth * 0.27
    x3 = pic.ScaleWidth * 0.53
    x4 = pic.ScaleWidth * 0.29
    x5 = pic.ScaleWidth * 0.55
    x6 = pic.ScaleWidth * 0.8
    x7 = pic.ScaleWidth * 1
    y1 = pic.ScaleHeight * 0.4
    y2 = pic.ScaleHeight * 0.25
    r1 = pic.ScaleHeight * 0.35
    r2 = pic.ScaleHeight * 0.25
    r3 = pic.ScaleHeight * 0.05
    r4 = pic.ScaleHeight * 0.0375
    pic.Cls
    pic.FillStyle = vbFSSolid
    pic.FillColor = RGB(&HB0, &HB0, &HB0)
    pic.ForeColor = pic.FillColor
    pic.Circle (x1, y1), r1
    pic.FillColor = RGB(&H90, &H90, &H90)
    pic.ForeColor = pic.FillColor
    pic.Circle (x1, y1), r3
    pic.FillColor = vbWhite
    pic.ForeColor = vbBlack
    pic.Circle (x2, y2), r3
    pic.Circle (x3, y2), r3
    pic.FillColor = vbBlack
    pic.Circle (x4, y2), r4, , , , 1.5
    pic.Circle (x5, y2), r4, , , , 1.5
    pic.FillStyle = vbFSTransparent
    pic.ForeColor = RGB(&H40, &H40, &H40)
    pic.Circle (x1, y1), r2, , PI, 2 * PI
    pic.ForeColor = RGB(&H30, &H30, &H30)
    pic.CurrentX = x1 - pic.TextWidth(MSG) / 2
    pic.CurrentY = (pic.ScaleHeight + y1 + r1 _
        - pic.TextHeight(MSG)) / 2
    pic.Print MSG
    pic.ForeColor = RGB(&H50, &H50, &H50)
    dy = pic.ScaleHeight / 15
    For y1 = dy / 2 To pic.ScaleHeight Step dy
        pic.Line (x6, y1)-(x7, y1 * 2)
    Next y1
    pic.ForeColor = vbBlack
End Sub
' ************************************************
' Draw stuff in color or black and white.
' ************************************************
Sub DrawIt(pic As PictureBox)
    If GrayCheck.Value = vbChecked Then
        GrayDrawStuff pic
    Else
        BWDrawStuff pic
    End If
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.
' Leave new system palette entries in SysPal().
' ***********************************************
Sub MatchGrayPalette(pic As Control)
Dim origpal(0 To 255) As PALETTEENTRY
Dim wid As Long
Dim hgt As Long
Dim bytes() As Byte
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
Dim logpal As Long
    ' Make sure pic has the foreground palette.
    pic.ZOrder
    status = RealizePalette(pic.hdc)
    DoEvents
    ' Get the system palette entries.
    status = GetSystemPaletteEntries(pic.hdc, 0, SysPalSize, origpal(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
        syspal(i) = origpal(i)
    Next i
    For i = StaticColor1 + 1 To StaticColor2 - 1
        With syspal(i)
            .peRed = 0
            .peGreen = 0
            .peBlue = 0
            .peFlags = PC_NOCOLLAPSE
        End With
    Next i
    For i = StaticColor2 To 255
        syspal(i) = origpal(i)
    Next i
    status = SetPaletteEntries(logpal, 0, SysPalSize, syspal(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 syspal(i)
            .peRed = c
            .peGreen = c
            .peBlue = c
        End With
    Next i
    status = SetPaletteEntries(logpal, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, syspal(StaticColor1 + 1))
    ' Realize the gray palette.
    status = 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
' ************************************************
' Anti-alias.
' ************************************************
Sub CmdGo_Click()
Dim S As Integer
    MousePointer = vbHourglass
    ' Make EnlargedPic the correct size.
    If Not IsNumeric(ScaleText.Text) Then _
        ScaleText.Text = "2"
    S = CInt(ScaleText.Text)
    If S < 1 Then
        ScaleText.Text = "2"
        S = 2
    End If
    EnlargedPic.Width = _
        EnlargedPic.Width - _
        EnlargedPic.ScaleWidth + _
        S * AliasedPic.ScaleWidth + S
    EnlargedPic.Height = _
        EnlargedPic.Height - _
        EnlargedPic.ScaleHeight + _
        S * AliasedPic.ScaleHeight + S
    ' Make EnlargedPic use the right thicknesses.
    EnlargedPic.DrawWidth = S * AliasedPic.DrawWidth
    EnlargedPic.Font.Size = S * AliasedPic.Font.Size
    ' Draw the enlarged picture.
    AntiAliasedPic.Cls
    DrawIt EnlargedPic
    DoEvents
    ' Shrink the enlarged picture.
    ShrinkPicture EnlargedPic, AntiAliasedPic, S
    MousePointer = vbDefault
End Sub
' ************************************************
' Draw some stuff to work with.
' ************************************************
Sub BWDrawStuff(pic As PictureBox)
Const PI = 3.14159
Const MSG = "Smile!"
Dim x1 As Single
Dim x2 As Single
Dim x3 As Single
Dim x4 As Single
Dim x5 As Single
Dim x6 As Single
Dim x7 As Single
Dim y1 As Single
Dim y2 As Single
Dim dy As Single
Dim r1 As Single
Dim r2 As Single
Dim r3 As Single
Dim r4 As Single
    x1 = pic.ScaleWidth * 0.4
    x2 = pic.ScaleWidth * 0.27
    x3 = pic.ScaleWidth * 0.53
    x4 = pic.ScaleWidth * 0.29
    x5 = pic.ScaleWidth * 0.55
    x6 = pic.ScaleWidth * 0.8
    x7 = pic.ScaleWidth * 1
    y1 = pic.ScaleHeight * 0.4
    y2 = pic.ScaleHeight * 0.25
    r1 = pic.ScaleHeight * 0.35
    r2 = pic.ScaleHeight * 0.25
    r3 = pic.ScaleHeight * 0.05
    r4 = pic.ScaleHeight * 0.0375
    pic.Cls
    pic.Circle (x1, y1), r1
    pic.Circle (x1, y1), r2, , PI, 2 * PI
    pic.Circle (x1, y1), r3
    pic.Circle (x2, y2), r3
    pic.Circle (x3, y2), r3
    pic.FillStyle = vbFSSolid
    pic.Circle (x4, y2), r4, , , , 1.5
    pic.Circle (x5, y2), r4, , , , 1.5
    pic.FillStyle = vbFSTransparent
    pic.CurrentX = x1 - pic.TextWidth(MSG) / 2
    pic.CurrentY = (pic.ScaleHeight + y1 + r1 _
        - pic.TextHeight(MSG)) / 2
    pic.Print MSG
    dy = pic.ScaleHeight / 15
    For y1 = dy / 2 To pic.ScaleHeight Step dy
        pic.Line (x6, y1)-(x7, y1 * 2)
    Next y1
End Sub
' ************************************************
' Shrink fpic into tpic, reducing by a factor of
' 1/s.
' ************************************************
Sub ShrinkPicture(fpic As PictureBox, tpic As PictureBox, S As Integer)
Dim X As Integer
Dim Y As Integer
Dim i As Integer
Dim j As Integer
Dim clr As Long
Dim status As Long
Dim bm As BITMAP
Dim hbm As Integer
Dim wid As Long
Dim hgt As Long
Dim fbytes() As Byte
Dim tbytes() As Byte
    ' Get the input pixels.
    hbm = fpic.Image
    status = GetObject(hbm, BITMAP_SIZE, bm)
    wid = bm.bmWidthBytes
    hgt = bm.bmHeight
    ReDim fbytes(0 To wid - 1, 0 To hgt - 1)
    status = GetBitmapBits(hbm, wid * hgt, fbytes(0, 0))
    ' Dimension the output pixel array.
    hbm = tpic.Image
    status = GetObject(hbm, BITMAP_SIZE, bm)
    wid = bm.bmWidthBytes
    hgt = bm.bmHeight
    ReDim tbytes(0 To wid - 1, 0 To hgt - 1)
    ' Shrink the image.
    For Y = 0 To hgt - 1
        For X = 0 To wid - 1
            ' Compute the value of pixel (x, y).
            clr = 0
            For i = 0 To S - 1
                For j = 0 To S - 1
                    clr = clr + syspal( _
                        fbytes(S * X + j, S * Y + i)).peRed
                Next j
            Next i
            ' Set the output pixel's value.
            clr = clr / S / S
            tbytes(X, Y) = NearestNonstaticGray(CInt(clr))
        Next X
    Next Y
    ' Update the output image.
    status = SetBitmapBits(hbm, wid * hgt, tbytes(0, 0))
    tpic.Refresh
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.
    Me.Show
    MousePointer = vbHourglass
    DoEvents
    MatchGrayPalette AliasedPic
    MatchGrayPalette AntiAliasedPic
    MatchGrayPalette EnlargedPic
    DoEvents
    ' Blank the backgrounds.
    AntiAliasedPic.Cls
    EnlargedPic.Cls
    ' Make everyone use the same font.
    AntiAliasedPic.Font.Name = AliasedPic.Font.Name
    AntiAliasedPic.Font.Bold = AliasedPic.Font.Bold
    AntiAliasedPic.Font.Italic = AliasedPic.Font.Italic
    AntiAliasedPic.Font.Strikethrough = AliasedPic.Font.Strikethrough
    AntiAliasedPic.Font.Underline = AliasedPic.Font.Underline
    EnlargedPic.Font.Name = AliasedPic.Font.Name
    EnlargedPic.Font.Bold = AliasedPic.Font.Bold
    EnlargedPic.Font.Italic = AliasedPic.Font.Italic
    EnlargedPic.Font.Strikethrough = AliasedPic.Font.Strikethrough
    EnlargedPic.Font.Underline = AliasedPic.Font.Underline

    ' Make AntiAliasedPic use the right thicknesses.
    AntiAliasedPic.DrawWidth = AliasedPic.DrawWidth
    AntiAliasedPic.Font.Size = AliasedPic.Font.Size

    ' Draw original stuff.
    DrawIt AliasedPic
    MousePointer = vbDefault
End Sub
Private Sub Form_Unload(Cancel As Integer)
    End
End Sub
' ************************************************
' Redraw the original stuff.
' ************************************************
Private Sub GrayCheck_Click()
    DrawIt AliasedPic
End Sub
Private Sub mnuFileExit_Click()
    Unload Me
End Sub