home *** CD-ROM | disk | FTP | other *** search
- VERSION 5.00
- Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.1#0"; "COMDLG32.OCX"
- Begin VB.Form QuikDraw
- Appearance = 0 'Flat
- BackColor = &H80000005&
- Caption = "QuikDraw"
- ClientHeight = 4245
- ClientLeft = 1110
- ClientTop = 1770
- ClientWidth = 7365
- BeginProperty Font
- Name = "MS Sans Serif"
- Size = 8.25
- Charset = 0
- Weight = 700
- Underline = 0 'False
- Italic = 0 'False
- Strikethrough = 0 'False
- EndProperty
- ForeColor = &H80000008&
- LinkMode = 1 'Source
- LinkTopic = "Form1"
- PaletteMode = 1 'UseZOrder
- ScaleHeight = 4245
- ScaleWidth = 7365
- Begin VB.HScrollBar ScrollObject
- Height = 255
- Index = 4
- Left = 5400
- Max = 9
- TabIndex = 16
- Top = 3840
- Value = 1
- Width = 495
- End
- Begin VB.CheckBox ChkPoly
- Appearance = 0 'Flat
- BackColor = &H80000005&
- Caption = "PolyMode WINDING"
- ForeColor = &H80000008&
- Height = 255
- Left = 1800
- TabIndex = 18
- Top = 3840
- Width = 2175
- End
- Begin VB.CommandButton CmdShowMF
- Appearance = 0 'Flat
- BackColor = &H80000005&
- Caption = "ShowMF"
- Height = 495
- Left = 120
- TabIndex = 6
- Top = 3720
- Width = 1095
- End
- Begin VB.HScrollBar ScrollObject
- Height = 255
- Index = 3
- Left = 6000
- Max = 7
- Min = -1
- TabIndex = 11
- Top = 3480
- Value = 6
- Width = 495
- End
- Begin VB.HScrollBar ScrollObject
- Height = 255
- Index = 2
- Left = 5400
- Max = 5
- Min = -1
- TabIndex = 10
- Top = 3480
- Width = 495
- End
- Begin VB.HScrollBar ScrollObject
- Height = 255
- Index = 1
- Left = 6000
- Max = 16
- Min = -1
- TabIndex = 9
- Top = 3120
- Value = 15
- Width = 495
- End
- Begin VB.HScrollBar ScrollObject
- Height = 255
- Index = 0
- Left = 5400
- Max = 16
- Min = -1
- TabIndex = 8
- Top = 3120
- Width = 495
- End
- Begin VB.PictureBox Picture3
- Appearance = 0 'Flat
- BackColor = &H80000005&
- ForeColor = &H80000008&
- Height = 975
- Left = 4080
- ScaleHeight = 945
- ScaleWidth = 1185
- TabIndex = 7
- Top = 3120
- Width = 1215
- End
- Begin VB.CommandButton CmdDeleteMF
- Appearance = 0 'Flat
- BackColor = &H80000005&
- Caption = "DeleteMF"
- Height = 495
- Left = 1320
- TabIndex = 5
- Top = 3120
- Width = 975
- End
- Begin VB.CommandButton CmdExecute
- Appearance = 0 'Flat
- BackColor = &H80000005&
- Caption = "AddToMF"
- Height = 495
- Index = 2
- Left = 120
- TabIndex = 4
- Top = 3120
- Width = 1095
- End
- Begin VB.PictureBox Picture2
- Appearance = 0 'Flat
- BackColor = &H80000005&
- ForeColor = &H80000008&
- Height = 1095
- Left = 5760
- ScaleHeight = 71
- ScaleMode = 3 'Pixel
- ScaleWidth = 71
- TabIndex = 3
- Top = 1440
- Width = 1095
- End
- Begin VB.CommandButton CmdExecute
- Appearance = 0 'Flat
- BackColor = &H80000005&
- Caption = "SmallView"
- Height = 495
- Index = 1
- Left = 5760
- TabIndex = 2
- Top = 840
- Width = 1095
- End
- Begin VB.CommandButton CmdExecute
- Appearance = 0 'Flat
- BackColor = &H80000005&
- Caption = "Execute"
- Height = 495
- Index = 0
- Left = 5760
- TabIndex = 1
- Top = 240
- Width = 1095
- End
- Begin VB.PictureBox Picture1
- Appearance = 0 'Flat
- BackColor = &H80000005&
- ForeColor = &H80000008&
- Height = 2895
- Left = 120
- ScaleHeight = 191
- ScaleMode = 3 'Pixel
- ScaleWidth = 319
- TabIndex = 0
- Top = 120
- Width = 4815
- End
- Begin MSComDlg.CommonDialog CMDialogMF
- Left = 3360
- Top = 3120
- _ExtentX = 847
- _ExtentY = 847
- _Version = 327680
- Filter = "Metafiles (*.wmf)|*.wmf"
- Flags = 4100
- FontSize = 2.54016e-29
- End
- Begin VB.Label Label5
- Appearance = 0 'Flat
- BackColor = &H80000005&
- Caption = "Width"
- ForeColor = &H80000008&
- Height = 255
- Left = 6600
- TabIndex = 17
- Top = 3840
- Width = 615
- End
- Begin VB.Label Label4
- Appearance = 0 'Flat
- BackColor = &H80000005&
- Caption = "Style"
- ForeColor = &H80000008&
- Height = 255
- Left = 6600
- TabIndex = 15
- Top = 3480
- Width = 615
- End
- Begin VB.Label Label3
- Appearance = 0 'Flat
- BackColor = &H80000005&
- Caption = "Color"
- ForeColor = &H80000008&
- Height = 255
- Left = 6600
- TabIndex = 14
- Top = 3120
- Width = 615
- End
- Begin VB.Label Label2
- Appearance = 0 'Flat
- BackColor = &H80000005&
- Caption = "Brush"
- ForeColor = &H80000008&
- Height = 255
- Left = 6000
- TabIndex = 13
- Top = 2760
- Width = 615
- End
- Begin VB.Label Label1
- Appearance = 0 'Flat
- BackColor = &H80000005&
- Caption = "Pen"
- ForeColor = &H80000008&
- Height = 255
- Left = 5400
- TabIndex = 12
- Top = 2760
- Width = 495
- End
- Begin VB.Menu MenuDraw
- Caption = "Draw"
- Begin VB.Menu MenuDrawType
- Caption = "Line"
- Checked = -1 'True
- Index = 0
- End
- Begin VB.Menu MenuDrawType
- Caption = "Ellipse"
- Index = 1
- End
- Begin VB.Menu MenuDrawType
- Caption = "FocusRect"
- Index = 2
- End
- Begin VB.Menu MenuDrawType
- Caption = "Chord"
- Index = 3
- End
- Begin VB.Menu MenuDrawType
- Caption = "Pie"
- Index = 4
- End
- Begin VB.Menu MenuDrawType
- Caption = "Arc"
- Index = 5
- End
- Begin VB.Menu MenuDrawType
- Caption = "Polygon"
- Index = 6
- End
- Begin VB.Menu MenuDrawType
- Caption = "Polyline"
- Index = 7
- End
- Begin VB.Menu MenuDrawType
- Caption = "Rectangle"
- Index = 8
- End
- End
- Begin VB.Menu mnu_Metafile
- Caption = "Metafile"
- Begin VB.Menu mnu_MetafileSave
- Caption = "Save"
- End
- Begin VB.Menu mnu_MetafileLoad
- Caption = "Load"
- End
- Begin VB.Menu mnu_MetafileCopy
- Caption = "Copy to Clipboard"
- End
- End
- Attribute VB_Name = "QuikDraw"
- Attribute VB_GlobalNameSpace = False
- Attribute VB_Creatable = False
- Attribute VB_PredeclaredId = True
- Attribute VB_Exposed = False
- DefStr A-Z
- Option Explicit
- ' Copyright
- 1997 by Desaware Inc. All Rights Reserved
- ' Delete the current metafile
- Private Sub CmdDeleteMF_Click()
- Dim di& ' Change to long - will work in Win16 too.
- If hndMetaFile Then
- di = DeleteMetaFile(hndMetaFile)
- hndMetaFile = 0
- End If
- End Sub
- ' Draw the current object on the picture
- ' Index = 0 is the Execute button which draws the current
- ' object into the large Picture1 control
- ' Index = 1 is the SmallView button which draws the
- ' current object into the small Picture2 control
- ' Index = 2 is the AddToMF button which adds the current
- ' object into the current metafile.
- Private Sub CmdExecute_Click(Index As Integer)
- #If Win32 Then
- Dim dc&, saved&, di&, dl&
- Dim oldpen&, oldbrush&, oldpolymode&
- #Else
- Dim dc%, saved%, di%, dl&
- Dim oldpen%, oldbrush%, oldpolymode%
- #End If
- Dim rc As RECT
- Dim oldsize As SIZE
- Dim oldpoint As POINTAPI
- Select Case Index
- Case 0 ' Execute button - draw into Picture1 after
- ' clearing the control.
- dc = Picture1.hDC
- Picture1.Cls
- Case 1 ' SmallView button - draw into Picture2
- Picture2.Cls
- dc = Picture2.hDC
- ' We're going to be changing the scaling, better
- ' save the current state of the DC or the VB
- ' drawing routines will no longer draw correctly.
- saved = SaveDC(dc)
- ' The entire area of Picture1 is scaled to fit
- ' Picture2 exactly - this requires a change of
- ' the mapping mode.
- di = SetMapMode(dc, MM_ANISOTROPIC)
-
- ' The logical window is the size of Picture1.
- ' Mapping this to the area of Picture2 is done
- ' by making all of Picture2 the viewport.
- dl& = SetWindowExtEx(dc, Picture1.ScaleWidth, Picture1.ScaleHeight, oldsize)
- dl& = SetViewportExtEx(dc, Picture2.ScaleWidth, Picture2.ScaleHeight, oldsize)
- Case 2 ' AddToMeta button - Add the current object
- ' to the global metafile.
- ' First create a new metafile device context.
- dc = CreateMetaFile(vbNullString)
- If hndMetaFile <> 0 Then
- ' If a global metafile already exists,
- ' first the existing metafile into the new one.
- di = PlayMetaFile(dc, hndMetaFile)
- ' Then delete the existing metafile.
- di = DeleteMetaFile(hndMetaFile)
- hndMetaFile = 0
- ' The drawing commands that follow will add
- ' the current object to the new metafile
- ' device context.
- End If
- End Select
- ' Select in the private pen and brush if we're using them
- If hndPen <> 0 And hndBrush <> 0 Then
- oldpen = SelectObject(dc, hndPen)
- oldbrush = SelectObject(dc, hndBrush)
- End If
- ' Also change the polygon filling mode to winding if necessary
- If ChkPoly.value = 1 Then oldpolymode = SetPolyFillMode(dc, WINDING)
- ' The object drawn depends on global LastDrawIndex which
- ' was set by the Draw menu commands.
- ' The PointsUsed global indicates how many points have
- ' been drawn in Picture1.
- Select Case LastDrawIndex
- Case 0 ' Draw a line
- If PointsUsed = 2 Then
- ' Set the current position of the pen
- dl = MoveToEx(dc, PointArray(0).x, PointArray(0).y, oldpoint)
- ' and draw to the specified point.
- di = LineTo(dc, PointArray(1).x, PointArray(1).y)
- End If
- Case 1 ' Draw an ellipse
- If PointsUsed% = 2 Then
- di = Ellipse(dc, PointArray(0).x, PointArray(0).y, PointArray(1).x, PointArray(1).y)
- End If
- Case 2 ' Draw a focus rectangle
- If PointsUsed% = 2 Then
- SetRect rc, PointArray(0).x, PointArray(0).y, PointArray(1).x, PointArray(1).y
- DrawFocusRect dc, rc
- End If
- Case 3 ' Draw a chord
- If PointsUsed% = 4 Then
- di = Chord(dc, PointArray(0).x, PointArray(0).y, PointArray(1).x, PointArray(1).y, PointArray(2).x, PointArray(2).y, PointArray(3).x, PointArray(3).y)
- End If
- Case 4 ' Draw a pie
- If PointsUsed% = 4 Then
- di = Pie(dc, PointArray(0).x, PointArray(0).y, PointArray(1).x, PointArray(1).y, PointArray(2).x, PointArray(2).y, PointArray(3).x, PointArray(3).y)
- End If
- Case 5 ' Draw an arc
- If PointsUsed% = 4 Then
- di = Arc(dc, PointArray(0).x, PointArray(0).y, PointArray(1).x, PointArray(1).y, PointArray(2).x, PointArray(2).y, PointArray(3).x, PointArray(3).y)
- End If
- Case 6 ' Draw a polygon
- If PointsUsed% > 1 Then
- di = Polygon(dc, PointArray(0), PointsUsed%)
- End If
- Case 7 ' Draw a polyline
- If PointsUsed% > 1 Then
- di = Polyline(dc, PointArray(0), PointsUsed%)
- End If
- Case 8 ' Draw a rectangle
- If PointsUsed% = 2 Then
- di = Rectangle(dc, PointArray(0).x, PointArray(0).y, PointArray(1).x, PointArray(1).y)
- End If
- End Select
- ' Be sure to restore the original GDI objects!
- If oldpen <> 0 Then di = SelectObject(dc, oldpen)
- If oldbrush <> 0 Then di = SelectObject(dc, oldbrush)
- If ChkPoly.value = 1 Then di = SetPolyFillMode(dc, oldpolymode)
- Select Case Index
- Case 0
- ' Notify the mouse down routine that the last
- ' command was an execute
- ' This informs the system that the next mouse
- ' click in Picture1 is the start of a new object.
- LastWasExecute% = -1
- Case 1 ' Restore the previous state of the Picture2 DC
- di = RestoreDC(dc, saved)
- Case 2 ' Close the metafile device context and
- ' objtain a metafile handle.
- hndMetaFile = CloseMetaFile(dc)
- dc = Picture1.hDC
- End Select
- End Sub
- ' Show the current global metafile if one exists. It will
- ' be shown in both Picture1 and Picture2
- ' Porting notes:
- ' Conditionally define the variabe types.
- ' Removed type characters % and & from variable usage to avoid
- ' conflicts between 16 and 32 bits environments
- ' Changed SetViewportEx and SetWindowExt to SetViewportExtEx and
- ' SetWindowExtEx for Win32 compatibility.
- Private Sub CmdShowMF_Click()
- #If Win32 Then
- Dim saved&, dc&, di&, dl&
- #Else
- Dim saved%, dc%, di%, dl&
- #End If
- Dim oldsize As SIZE
- ' Because the original drawing was into Picture1,
- ' playing the metafile into Picture1 is trivial.
- Picture1.Cls
- di = PlayMetaFile(Picture1.hDC, hndMetaFile)
- ' Picture 2 is trickier. First we clear it and save the
- ' current DC state.
- Picture2.Cls
- dc = Picture2.hDC
- saved = SaveDC(dc)
- ' Now set the new coordinate system. See the CmdExecute()_Click
- ' command for further explanation
- di = SetMapMode(dc, MM_ANISOTROPIC)
- dl = SetWindowExtEx(dc, Picture1.ScaleWidth, Picture1.ScaleHeight, oldsize)
- dl = SetViewportExtEx(dc, Picture2.ScaleWidth, Picture2.ScaleHeight, oldsize)
- ' All of the drawing objects that were used on the original
- ' objects were saved with the metafile, thus the metafile
- ' will automatically draw each object in the correct color
- ' and style.
- di = PlayMetaFile(dc, hndMetaFile)
- ' And restore the original DC state
- di = RestoreDC(dc, saved)
- End Sub
- ' We default to the line mode with no points defined.
- Private Sub Form_Load()
- MaxPoints% = 2
- PointsUsed% = 0
- ' Force the selection of a valid pen and brush
- ScrollObject_Change 0
- End Sub
- ' It is important to delete these GDI objects (if they
- ' were created) before closing the application so that
- ' the Windows resources may be properly freed.
- Private Sub Form_Unload(Cancel As Integer)
- Dim di&
- If hndMetaFile <> 0 Then di = DeleteMetaFile(hndMetaFile)
- If hndPen <> 0 Then di = DeleteObject(hndPen)
- If hndBrush <> 0 Then di = DeleteObject(hndBrush)
- End Sub
- ' This function handles the menu commands. Each one defines
- ' a different object to draw when the Execute command button
- ' is selected.
- Private Sub MenuDrawType_Click(Index As Integer)
- Dim x%
- ' Clear out the current object.
- PointsUsed% = 0
- Picture1.Cls
- ' LastDrawIndex is a global that shows which GDI drawing
- ' function is being tested.
- LastDrawIndex% = Index
- ' Uncheck all of the menu entries
- For x% = 0 To 8
- MenuDrawType(x%).Checked = 0
- Next x%
- ' And check this one only.
- MenuDrawType(Index).Checked = -1
- ' Each GDI drawing tool has a maximum number of points
- ' that it needs in order to perform the drawing.
- Select Case Index
- Case 0, 1, 2, 8
- MaxPoints% = 2
- Case 3, 4, 5
- MaxPoints% = 4
- ' Polygons are limited to the size of the point data array
- Case 6, 7
- MaxPoints% = 32
- End Select
- End Sub
- Private Sub mnu_MetafileCopy_Click()
- #If Win32 Then
- Dim hdcMeta&
- Dim dl&, di&
- Dim newmf&
- Dim hgmem&
- #Else
- Dim hdcMeta%
- Dim dl&, di%
- Dim newmf%
- Dim hgmem%
- #End If
- Dim mfp As METAFILEPICT
- Dim GlblAddr&
- Dim oldsize As SIZE
- If hndMetaFile = 0 Then
- MsgBox "Metafile must be defined before saving"
- Exit Sub
- End If
- hdcMeta = CreateMetaFile(vbNullString)
- dl& = SetWindowExtEx(hdcMeta, Picture1.ScaleWidth, Picture1.ScaleHeight, oldsize)
- di = PlayMetaFile(hdcMeta, hndMetaFile)
- newmf = CloseMetaFile(hdcMeta)
- mfp.mm = MM_ANISOTROPIC
- mfp.xExt = Picture1.ScaleWidth
- mfp.yExt = Picture1.ScaleHeight
- mfp.hMF = newmf
- ' Take out hardcoded sizes - used to be 8 instead of len(mfp)
- hgmem = GlobalAlloc(GMEM_MOVEABLE, Len(mfp))
- GlblAddr = GlobalLock(hgmem)
- agCopyData mfp, ByVal GlblAddr&, Len(mfp)
- di = GlobalUnlock(hgmem)
- ' Place the metafile into the clipboard
- di = OpenClipboard(Picture1.hwnd)
- di = EmptyClipboard()
- di = SetClipboardData(CF_METAFILEPICT, hgmem)
- di = CloseClipboard()
- End Sub
- Private Sub mnu_MetafileLoad_Click()
- Dim usefile$
- #If Win32 Then
- Dim saved&
- Dim dc&
- Dim usemf&
- Dim di&, dl&
- #Else
- Dim saved%
- Dim dc%
- Dim usemf%
- Dim di%, dl&
- #End If
- Dim oldsize As SIZE
- CMDialogMF.DialogTitle = "Load a metafile"
- CMDialogMF.Action = 1
- usefile$ = CMDialogMF.FileName
- If usefile$ <> "" Then
- usemf = LoadTheMetafile(usefile$)
- If usemf <> 0 Then
- ' Now draw the metafile
- Picture1.Cls
- dc = Picture1.hDC
- saved = SaveDC(dc)
- ' Now set the new coordinate system. See the CmdExecute()_Click
- ' command for further explanation
- ' Most metafiles will set their own extents, but we need
- ' to set the viewport to match the scalemode of the
- ' entire screen to fill the window
- di = SetMapMode(dc, MM_ANISOTROPIC)
- dl = SetViewportExtEx(dc, Picture1.ScaleWidth, Picture1.ScaleHeight, oldsize)
- ' All of the drawing objects that were used on the original
- ' objects were saved with the metafile, thus the metafile
- ' will automatically draw each object in the correct color
- ' and style.
- di = PlayMetaFile(dc, usemf)
- ' And restore the original DC state
- di = RestoreDC(dc, saved)
- di = DeleteMetaFile(usemf)
- End If
- End If
- End Sub
- Private Sub mnu_MetafileSave_Click()
- Dim di&
- Dim usefile$
- If hndMetaFile = 0 Then
- MsgBox "Metafile must be defined before saving"
- Exit Sub
- End If
- CMDialogMF.DialogTitle = "Save a metafile"
- CMDialogMF.Action = 2
- usefile$ = CMDialogMF.FileName
- If usefile$ <> "" Then
- di = SaveTheMetafile(usefile$, hndMetaFile, CInt(Picture1.ScaleWidth), CInt(Picture1.ScaleHeight))
- End If
- End Sub
- ' Mouse clicks in Picture1
- Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
- Dim pt%, px%, py%
- ' If last command was an execute, clear the points to
- ' start a new image
- If LastWasExecute% Then
- PointsUsed% = 0
- LastWasExecute% = 0
- End If
- ' If the maximum number of points has been exceeded
- ' Shift all of the points down
- If PointsUsed% >= MaxPoints% Then
- For pt% = 1 To MaxPoints%
- PointArray(pt% - 1) = PointArray(pt%)
- Next pt%
- PointsUsed% = PointsUsed% - 1
- End If
- ' Add the current point to the list
- PointArray(PointsUsed%).x = CInt(x)
- PointArray(PointsUsed%).y = CInt(y)
- PointsUsed% = PointsUsed% + 1
- Picture1.Cls
- ' Draw small + indicators to show where the points are.
- For pt% = 0 To PointsUsed% - 1
- px% = PointArray(pt%).x
- py% = PointArray(pt%).y
- Picture1.Line (px% - 2, py%)-(px% + 3, py%)
- Picture1.Line (px%, py% - 2)-(px%, py% + 3)
- Next pt%
- End Sub
- ' This picture control shows a rectangle drawn in the
- ' current pen and brush.
- Private Sub Picture3_Paint()
- Dim rc As RECT
- #If Win32 Then
- Dim hwnd&
- Dim oldpen&, oldbrush&
- Dim di&
- #Else
- Dim hwnd%
- Dim oldpen%, oldbrush%
- Dim di%
- #End If
- ' Get the window handle for Picture2
- hwnd = Picture3.hwnd
- ' Get a rectangle with the client area size...
- GetClientRect hwnd, rc
- '.. and shrink it by 10 pixels on a side.
- InflateRect rc, -10, -10
- ' Select in our private pen and brush
- If hndPen <> 0 And hndBrush <> 0 Then
- oldpen = SelectObject(Picture3.hDC, hndPen)
- oldbrush = SelectObject(Picture3.hDC, hndBrush)
- End If
- ' Draw the rectangle
- di = Rectangle(Picture3.hDC, rc.Left, rc.Top, rc.Right, rc.Bottom)
- ' Be sure to restore the original GDI objects!
- If oldpen <> 0 Then di = SelectObject(Picture3.hDC, oldpen)
- If oldbrush <> 0 Then di = SelectObject(Picture3.hDC, oldbrush)
- End Sub
- ' These scroll bars are used to select colors, styles and
- ' pen widths. The Min and Max properties are selected
- ' such that the Scrollbar value parameter may be used
- ' directly in the GDI object creation function.
- Private Sub ScrollObject_Change(Index As Integer)
- Dim di%
- ' Wrap around when increasing
- If ScrollObject(Index).value = ScrollObject(Index).Max Then
- ScrollObject(Index).value = ScrollObject(Index).Min + 1
- Exit Sub
- End If
- ' Wrap around when decrementing
- If ScrollObject(Index).value = ScrollObject(Index).Min Then
- ScrollObject(Index).value = ScrollObject(Index).Max - 1
- Exit Sub
- End If
- ' Delete the current objects
- If hndPen Then di = DeleteObject(hndPen)
- If hndBrush Then di = DeleteObject(hndBrush)
- ' Now create the new pen
- hndPen = CreatePen(ScrollObject(2).value, ScrollObject(4).value, QBColor(ScrollObject(0).value))
- ' Now create the new brush
- ' Value 6 indicates that we should create a solid brush
- ' 0-5 indicate styles of hatched brushes.
- If ScrollObject(3).value = 6 Then
- hndBrush = CreateSolidBrush(QBColor(ScrollObject(1).value))
- Else
- hndBrush = CreateHatchBrush(ScrollObject(3).value, QBColor(ScrollObject(1).value))
- End If
- ' Draw a sample rectangle using the current pen&Brush
- ' This forces the Paint event to be triggered.
- Picture3.Refresh
- End Sub
-