Dan Appleman's Visual Basic 5.0 Programmers Guide to the Win32 API

home *** CD-ROM | disk | FTP | other *** search

/ Dan Appleman's Visual Bas…s Guide to the Win32 API / Dan.Applmans.Visual.Basic.5.0.Programmers.Guide.To.The.Win32.API.1997.Ziff-Davis.Press.CD / VB5PG32.mdf / classlib / desaware / samplev5 / quickdrw / quikdraw.frm (.txt) < prev next >

Wrap

Visual Basic Form | 1997-02-17 | 25.5 KB | 756 lines

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 = 1875 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 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 Begin VB.Menu NoOne Caption = "-" End Begin VB.Menu MenuExit Caption = "&Exit" Index = 100 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 ' Delete the current metafile Private Sub CmdDeleteMF_Click() If MetaFile Is Nothing Then Else MetaFile.DeleteMetafile Set MetaFile = Nothing 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) Dim tmpDC As dwDeviceContext Dim sys As New dwSystem Dim rc As New dwRECT Dim oldsize As New dwPoint Dim oldpoint As New dwPoint #If Win32 Then Dim oldpolymode& Dim saved& #Else Dim oldpolymode% Dim saved% #End If Select Case Index Case 0 ' Execute button - draw into Picture1 after ' clearing the control. Set tmpDC = New dwDeviceContext tmpDC.hDC = Picture1.hDC Picture1.Cls Case 1 ' SmallView button - draw into Picture2 Picture2.Cls Set tmpDC = New dwDeviceContext tmpDC.hDC = 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 = tmpDC.SaveDC ' The entire area of Picture1 is scaled to fit ' Picture2 exactly - this requires a change of ' the mapping mode. tmpDC.SetMapMode 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. tmpDC.SetWindowExtEx Picture1.ScaleWidth, Picture1.ScaleHeight, oldsize tmpDC.SetViewportExtEx Picture2.ScaleWidth, Picture2.ScaleHeight, oldsize Case 2 ' AddToMeta button - Add the current object ' to the global metafile. ' First create a new metafile device context. Set tmpDC = sys.CreateMetafile(vbNullString) If MetaFile Is Nothing Then Else ' If a global metafile already exists, first ' play the existing metafile into the new one. tmpDC.PlayMetaFile MetaFile ' Then delete the existing metafile. MetaFile.DeleteMetafile Set MetaFile = Nothing ' 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 Pen Is Nothing And Brush Is Nothing Then Else tmpDC.SelectObjectPen Pen tmpDC.SelectObjectBrush Brush End If ' Also change the polygon filling mode to winding if necessary If ChkPoly.value = 1 Then oldpolymode = tmpDC.SetPolyFillMode(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 tmpDC.MoveTo PointCollection(1) ' and draw to the specified point. tmpDC.LineTo PointCollection(2) End If Case 1 ' Draw an ellipse If PointsUsed% = 2 Then rc.SetRect PointCollection(1).x, PointCollection(1).y, PointCollection(2).x, PointCollection(2).y tmpDC.Ellipse rc End If Case 2 ' Draw a focus rectangle If PointsUsed% = 2 Then rc.SetRect PointCollection(1).x, PointCollection(1).y, PointCollection(2).x, PointCollection(2).y tmpDC.DrawFocusRect rc End If Case 3 ' Draw a chord If PointsUsed% = 4 Then tmpDC.Chord PointCollection(1), PointCollection(2), PointCollection(3), PointCollection(4) End If Case 4 ' Draw a pie If PointsUsed% = 4 Then tmpDC.Pie PointCollection(1), PointCollection(2), PointCollection(3), PointCollection(4) End If Case 5 ' Draw an arc If PointsUsed% = 4 Then tmpDC.Arc PointCollection(1), PointCollection(2), PointCollection(3), PointCollection(4) End If Case 6 ' Draw a polygon If PointsUsed% > 1 Then tmpDC.Polygon PointCollection End If Case 7 ' Draw a polyline If PointsUsed% > 1 Then tmpDC.Polyline PointCollection End If Case 8 ' Draw a rectangle If PointsUsed% = 2 Then rc.SetRect PointCollection(1).x, PointCollection(1).y, PointCollection(2).x, PointCollection(2).y tmpDC.Rectangle rc End If End Select ' Be sure to restore the original GDI objects! tmpDC.SelectObjectPen Nothing tmpDC.SelectObjectBrush Nothing If ChkPoly.value = 1 Then tmpDC.SetPolyFillMode 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 tmpDC.RestoreDC saved Case 2 ' Close the metafile device context and ' objtain a metafile handle. Set MetaFile = tmpDC.CloseMetafile 'tmpDC.hDC = picture1.hDC End Select Set tmpDC = Nothing Set sys = Nothing Set rc = Nothing Set oldsize = Nothing Set oldpoint = Nothing End Sub ' Show the current global metafile if one exists. It will ' be shown in both Picture1 and Picture2 Private Sub CmdShowMF_Click() #If Win32 Then Dim saved& #Else Dim saved% #End If Dim tmpDC As dwDeviceContext Dim oldsize As New dwPoint If MetaFile Is Nothing Then Exit Sub End If ' Because the original drawing was into Picture1, ' playing the metafile into Picture1 is trivial. Picture1.Cls Set tmpDC = New dwDeviceContext tmpDC.hDC = Picture1.hDC tmpDC.PlayMetaFile MetaFile ' Picture 2 is trickier. First we clear it and save the ' current DC state. Picture2.Cls tmpDC.hDC = Picture2.hDC saved = tmpDC.SaveDC ' Now set the new coordinate system. See the CmdExecute()_Click ' command for further explanation tmpDC.SetMapMode MM_ANISOTROPIC tmpDC.SetWindowExtEx Picture1.ScaleWidth, Picture1.ScaleHeight, oldsize tmpDC.SetViewportExtEx 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. tmpDC.PlayMetaFile MetaFile ' And restore the original DC state tmpDC.RestoreDC saved Set tmpDC = Nothing Set oldsize = Nothing 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 i% If MetaFile Is Nothing Then Else MetaFile.DeleteMetafile Set MetaFile = Nothing End If Set Pen = Nothing Set Pen = Nothing Set PointCollection = Nothing 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%, i% ' 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 ' Clear all the points in the collection For i% = 1 To PointCollection.count PointCollection.Remove 1 Next i% ' 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 some reasonable number, but ' you can change the max number of points here without ' changing anything else. Case 6, 7 MaxPoints% = 32 End Select End Sub Private Sub MenuExit_Click(Index As Integer) Unload QuikDraw End Sub Private Sub mnu_MetafileCopy_Click() #If Win32 Then Dim di& #Else Dim di% #End If Dim hdcMeta As dwDeviceContext Dim newmf As dwMetaFile Dim hgmem As New dwGlobalMemory Dim mfp As METAFILEPICT Dim GlblAddr& Dim oldsize As New dwPoint Dim sys As New dwSystem If MetaFile Is Nothing Then MsgBox "Metafile must be defined before saving" Exit Sub End If Set hdcMeta = sys.CreateMetafile(vbNullString) hdcMeta.SetWindowExtEx Picture1.ScaleWidth, Picture1.ScaleHeight, oldsize hdcMeta.PlayMetaFile MetaFile Set newmf = hdcMeta.CloseMetafile mfp.mm = MM_ANISOTROPIC mfp.xExt = Picture1.ScaleWidth mfp.yExt = Picture1.ScaleHeight mfp.hMF = newmf.hMetaFile Set hgmem = sys.GlobalAlloc(GMEM_MOVEABLE, Len(mfp)) GlblAddr = hgmem.GlobalLock() agCopyData mfp, ByVal GlblAddr&, Len(mfp) hgmem.GlobalUnlock ' Place the metafile into the clipboard di = OpenClipboard(Picture1.hwnd) di = EmptyClipboard() di = SetClipboardData(CF_METAFILEPICT, hgmem.hGlobal) di = CloseClipboard() Set hgmem = Nothing Set sys = Nothing Set oldsize = Nothing Set newmf = Nothing Set hdcMeta = Nothing End Sub Private Sub mnu_MetafileLoad_Click() Dim usefile$ #If Win32 Then Dim saved& Dim di&, dl& #Else Dim saved% Dim di%, dl& #End If Dim dc As New dwDeviceContext Dim oldsize As New dwPoint Dim usemf As dwMetaFile CMDialogMF.DialogTitle = "Load a metafile" CMDialogMF.Action = 1 usefile$ = CMDialogMF.filename If usefile$ <> "" Then Set usemf = LoadTheMetafile(usefile$) If usemf Is Nothing Then Else ' Now draw the metafile Picture1.Cls Set dc = New dwDeviceContext dc.hDC = Picture1.hDC saved = dc.SaveDC ' 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 dc.SetMapMode MM_ANISOTROPIC dc.SetViewportExtEx 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. dc.PlayMetaFile usemf ' And restore the original DC state dc.RestoreDC saved usemf.DeleteMetafile Set usemf = Nothing Set dc = Nothing End If End If Set oldsize = Nothing End Sub Private Sub mnu_MetafileSave_Click() Dim di& Dim usefile$ If MetaFile Is Nothing 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$, MetaFile, 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%, i% Dim newPoint As New dwPoint ' If last command was an execute, clear the points to ' start a new image If LastWasExecute% Then PointsUsed% = 0 LastWasExecute% = 0 For i% = 1 To PointCollection.count PointCollection.Remove 1 Next i% End If ' If the maximum number of points has been exceeded ' Shift all of the points down If PointsUsed% >= MaxPoints% Then PointCollection.Remove 1 PointsUsed% = PointsUsed% - 1 End If ' Add the current point to the list newPoint.x = CInt(x) newPoint.y = CInt(y) PointCollection.Add Item:=newPoint PointsUsed% = PointsUsed% + 1 Picture1.Cls ' Draw small + indicators to show where the points are. set For pt% = 1 To PointsUsed% px% = PointCollection(pt%).x py% = PointCollection(pt%).y Picture1.Line (px% - 2, py%)-(px% + 3, py%) Picture1.Line (px%, py% - 2)-(px%, py% + 3) Next pt% Set newPoint = Nothing End Sub ' This picture control shows a rectangle drawn in the ' current pen and brush. Private Sub Picture3_Paint() Dim rc As New dwRECT Dim hwnd As New dwWindow Dim tmpDC As dwDeviceContext #If Win32 Then Dim di& #Else Dim di% #End If ' Get the window handle for Picture2 hwnd.hwnd = Picture3.hwnd ' Get a rectangle with the client area size... Set rc = hwnd.GetClientRect() '.. and shrink it by 10 pixels on a side. rc.InflateRect -10, -10 Set tmpDC = New dwDeviceContext tmpDC.hDC = Picture3.hDC ' Select in our private pen and brush If Pen Is Nothing And Brush Is Nothing Then Else tmpDC.SelectObjectPen Pen tmpDC.SelectObjectBrush Brush End If ' Draw the rectangle tmpDC.Rectangle rc ' Be sure to restore the original GDI objects. tmpDC.SelectObjectPen Nothing tmpDC.SelectObjectBrush Nothing Set rc = Nothing Set hwnd = Nothing Set tmpDC = Nothing 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 ' Now create the new pen Pen.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 Brush.CreateSolidBrush QBColor(ScrollObject(1).value) Else Brush.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