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

Visual Basic Form | 1997-01-08 | 12.2 KB | 402 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 ColorCheck
      Caption         =   "Color"
      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         =   "AALIAS2.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         =   "AALIAS2.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         =   "AALIAS2.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
' ************************************************
' Redraw the original stuff.
' ************************************************
Private Sub ColorCheck_Click()
    DrawIt AliasedPic
End Sub
' ************************************************
' 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
' ************************************************
' Draw stuff in color or black and white.
' ************************************************
Sub DrawIt(pic As PictureBox)
    If ColorCheck.Value = vbChecked Then
        ColorDrawStuff pic
    Else
        BWDrawStuff pic
    End If
End Sub
' ************************************************
' Draw some stuff to work with.
' ************************************************
Sub ColorDrawStuff(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 = vbYellow
    pic.ForeColor = pic.FillColor
    pic.Circle (x1, y1), r1
    pic.FillColor = RGB(255, 153, 51)
    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 = vbRed
    pic.Circle (x1, y1), r2, , PI, 2 * PI
    pic.ForeColor = vbBlue
    pic.CurrentX = x1 - pic.TextWidth(MSG) / 2
    pic.CurrentY = (pic.ScaleHeight + y1 + r1 _
        - pic.TextHeight(MSG)) / 2
    pic.Print MSG
    pic.ForeColor = RGB(&H80, 0, &H80)
    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
' ************************************************
' Shrink fpic into tpic, reducing by a factor of
' 1/s.
' ************************************************
Sub ShrinkPicture(fpic As PictureBox, tpic As PictureBox, S As Integer)
Dim SysPal(0 To 255) As PALETTEENTRY
Dim x As Integer
Dim y As Integer
Dim i As Integer
Dim j As Integer
Dim r As Long
Dim g As Long
Dim b 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
Dim pos As Integer
    ' Make sure fpic has the foreground palette.
    fpic.ZOrder
    status = RealizePalette(fpic.hdc)
    DoEvents
    ' Get the system palette entries.
    status = GetSystemPaletteEntries(fpic.hdc, 0, 256, SysPal(0))

    ' 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).
            r = 0
            g = 0
            b = 0
            For i = 0 To S - 1
                For j = 0 To S - 1
                    pos = fbytes(S * x + j, S * y + i)
                    r = r + SysPal(pos).peRed
                    g = g + SysPal(pos).peGreen
                    b = b + SysPal(pos).peBlue
                Next j
            Next i
            ' Set the output pixel's value.
            r = r / S / S
            g = g / S / S
            b = b / S / S
            tpic.PSet (x, y), RGB(r, g, b)
        Next x
        DoEvents
    Next y
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
    ' 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
End Sub
Private Sub Form_Unload(Cancel As Integer)
    End
End Sub
Private Sub mnuFileExit_Click()
    Unload Me
End Sub