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 / samplev4 / quickdrw / quikdraw.bas next >
Encoding:
BASIC Source File  |  1996-01-18  |  10.0 KB  |  318 lines
  1. Attribute VB_Name = "QUIKDRAW1"
  2. Option Explicit
  3. ' QuikDraw program example
  4. ' This version of QuickDraw uses the Desaware
  5. ' API Class Library.
  6.  
  7.  
  8. #If Win32 Then
  9. ' Not all functions or data types are in the Class
  10. ' Library.
  11. Type METAFILEPICT
  12.         mm As Long
  13.         xExt As Long
  14.         yExt As Long
  15.         hMF As Long
  16. End Type
  17.  
  18. Type METARECORD
  19.         rdSize As Long
  20.         rdFunction As Integer
  21.         rdParm(1) As Integer
  22. End Type
  23.  
  24. Declare Function CloseClipboard& Lib "user32" ()
  25. Declare Function EmptyClipboard& Lib "user32" ()
  26. Declare Function GetObjectType& Lib "gdi32" (ByVal hgdiobj As Long)
  27. Declare Function OpenClipboard& Lib "user32" (ByVal hwnd As Long)
  28. Declare Function SetClipboardData& Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long)
  29.  
  30. Declare Function lopen Lib "kernel32" Alias "_lopen" (ByVal lpPathName As String, ByVal iReadWrite As Long) As Long
  31. Declare Function lclose Lib "kernel32" Alias "_lclose" (ByVal hFile As Long) As Long
  32. Declare Function lcreat Lib "kernel32" Alias "_lcreat" (ByVal lpPathName As String, ByVal iAttribute As Long) As Long
  33. Declare Function llseek Lib "kernel32" Alias "_llseek" (ByVal hFile As Long, ByVal lOffset As Long, ByVal iOrigin As Long) As Long
  34. Declare Function lread Lib "kernel32" Alias "_lread" (ByVal hFile As Long, lpbuffer As Any, ByVal wBytes As Long) As Long
  35. Declare Function lwrite Lib "kernel32" Alias "_lwrite" (ByVal hFile As Long, lpbuffer As Any, ByVal wBytes As Long) As Long
  36.  
  37. Declare Function hread Lib "kernel32" Alias "_hread" (ByVal hFile As Long, lpbuffer As Any, ByVal lBytes As Long) As Long
  38. Declare Function hwrite Lib "kernel32" Alias "_hwrite" (ByVal hFile As Long, lpbuffer As Any, ByVal lBytes As Long) As Long
  39.  
  40. #Else
  41.  
  42. Type METAFILEPICT    '8 Bytes
  43.     mm As Integer
  44.     xExt As Integer
  45.     yExt As Integer
  46.     hMF As Integer
  47. End Type
  48.  
  49. Declare Function CloseClipboard% Lib "user" ()
  50. Declare Function EmptyClipboard% Lib "user" ()
  51. Declare Function OpenClipboard% Lib "user" (ByVal hwnd%)
  52. Declare Function SetClipboardData% Lib "user" (ByVal wFormat%, ByVal hMem%)
  53.  
  54. Declare Function lopen% Lib "kernel" Alias "_lopen" (ByVal lpPathName$, ByVal iReadWrite%)
  55. Declare Function lclose% Lib "kernel" Alias "_lclose" (ByVal hFile%)
  56. Declare Function lcreat% Lib "kernel" Alias "_lcreat" (ByVal lpPathName$, ByVal iAttribute%)
  57. Declare Function llseek& Lib "kernel" Alias "_llseek" (ByVal hFile%, ByVal lOffset&, ByVal iOrigin%)
  58. Declare Function lread% Lib "kernel" Alias "_lread" (ByVal hFile%, lpbuffer As Any, ByVal wBytes%)
  59. Declare Function lwrite% Lib "kernel" Alias "_lwrite" (ByVal hFile%, lpbuffer As Any, ByVal wBytes%)
  60. Declare Function hread& Lib "kernel" Alias "_hread" (ByVal hf%, hpvBuffer As Any, ByVal cbBuffer&)
  61. Declare Function hwrite& Lib "kernel" Alias "_hwrite" (ByVal hf%, hpvBuffer As Any, ByVal cbBuffer&)
  62.  
  63. #End If
  64.  
  65. Type RECTS
  66.         left As Integer
  67.         top As Integer
  68.         right As Integer
  69.         bottom As Integer
  70. End Type
  71.  
  72. Type METAFILEHEADER     ' 22 bytes
  73.     key As Long
  74.     hMF As Integer
  75.     bbox As RECTS
  76.     inch As Integer
  77.     Reserved As Long
  78.     checksum As Integer
  79. End Type
  80.  
  81. ' Application global variables
  82.  
  83. ' Metafile to hold objects
  84. Public MetaFile As dwMetaFile
  85.  
  86. ' Private Pen and Brush to use
  87. Public Pen As New dwPen
  88. Public Brush As New dwBrush
  89.  
  90. Public MaxPoints%   ' Maximum points to use this drawing mode
  91. Public PointsUsed%  ' Number of points used.
  92. ' collection of dwPoints
  93. Public PointCollection As New Collection
  94.  
  95. ' Current drawing mode - most recent Draw menu index
  96. Public LastDrawIndex%
  97.  
  98. ' This flag is set to -1 after the Execute button is pressed.
  99. ' This is an indication that the next click in Picture1 should
  100. ' start a new object.
  101. Public LastWasExecute%
  102.  
  103.  
  104. ' Public constants imported from APICONST.TXT
  105. Public Const R2_BLACK = 1
  106. Public Const R2_NOTMERGEPEN = 2
  107. Public Const R2_MASKNOTPEN = 3
  108. Public Const R2_NOTCOPYPEN = 4
  109. Public Const R2_MASKPENNOT = 5
  110. Public Const R2_NOT = 6
  111. Public Const R2_XORPEN = 7
  112. Public Const R2_NOTMASKPEN = 8
  113. Public Const R2_MASKPEN = 9
  114. Public Const R2_NOTXORPEN = 10
  115. Public Const R2_NOP = 11
  116. Public Const R2_MERGENOTPEN = 12
  117. Public Const R2_COPYPEN = 13
  118. Public Const R2_MERGEPENNOT = 14
  119. Public Const R2_MERGEPEN = 15
  120. Public Const R2_WHITE = 16
  121. Public Const ALTERNATE = 1
  122. Public Const WINDING = 2
  123. Public Const TRANSPARENT = 1
  124. Public Const OPAQUE = 2
  125. Public Const MM_TEXT = 1
  126. Public Const MM_LOMETRIC = 2
  127. Public Const MM_HIMETRIC = 3
  128. Public Const MM_LOENGLISH = 4
  129. Public Const MM_HIENGLISH = 5
  130. Public Const MM_TWIPS = 6
  131. Public Const MM_ISOTROPIC = 7
  132. Public Const MM_ANISOTROPIC = 8
  133. Public Const ABSOLUTE = 1
  134. Public Const RELATIVE = 2
  135. Public Const WHITE_BRUSH = 0
  136. Public Const LTGRAY_BRUSH = 1
  137. Public Const GRAY_BRUSH = 2
  138. Public Const DKGRAY_BRUSH = 3
  139. Public Const BLACK_BRUSH = 4
  140. Public Const NULL_BRUSH = 5
  141. Public Const HOLLOW_BRUSH = NULL_BRUSH ' change references to this
  142. Public Const WHITE_PEN = 6
  143. Public Const BLACK_PEN = 7
  144. Public Const NULL_PEN = 8
  145. Public Const OEM_FIXED_FONT = 10
  146. Public Const ANSI_FIXED_FONT = 11
  147. Public Const ANSI_VAR_FONT = 12
  148. Public Const SYSTEM_FONT = 13
  149. Public Const DEVICE_DEFAULT_FONT = 14
  150. Public Const DEFAULT_PALETTE = 15
  151. Public Const SYSTEM_FIXED_FONT = 16
  152. Public Const PS_SOLID = 0
  153. Public Const PS_DASH = 1
  154. Public Const PS_DOT = 2
  155. Public Const PS_DASHDOT = 3
  156. Public Const PS_DASHDOTDOT = 4
  157. Public Const PS_NULL = 5
  158. Public Const PS_INSIDEFRAME = 6
  159. Public Const HS_HORIZONTAL = 0
  160. Public Const HS_VERTICAL = 1
  161. Public Const HS_FDIAGONAL = 2
  162. Public Const HS_BDIAGONAL = 3
  163. Public Const HS_CROSS = 4
  164. Public Const HS_DIAGCROSS = 5
  165.  
  166. Public Const GMEM_MOVEABLE = &H2
  167. Public Const CF_METAFILEPICT = 3
  168. Public Const GMEM_ZEROINIT = &H40
  169.  
  170. Function LoadTheMetafile(filename$) As dwMetaFile
  171.     #If Win32 Then
  172.         Dim fhnd&
  173.         Dim di&, dl&
  174.         Dim mfglbhnd&
  175.  
  176.     #Else
  177.         Dim fhnd%
  178.         Dim di%, dl&
  179.         Dim mfglbhnd%
  180.     #End If
  181.     Dim mf As New dwMetaFile
  182.     Dim gmem As New dwGlobalMemory
  183.     Dim sys As New dwSystem
  184.     Dim mfile As METAFILEHEADER
  185.     Dim mfinfosize&
  186.     Dim currentfileloc&
  187.     Dim gptr&
  188.     
  189.     ' Open the file to read
  190.     fhnd = lopen(filename$, 0)
  191.     If fhnd < 0 Then Exit Function
  192.  
  193.     ' First read the placeable header file header
  194.     di = lread(fhnd, mfile, Len(mfile))
  195.     If mfile.key <> &H9AC6CDD7 Then
  196.         ' It's not a placeable metafile - so just seek to the start
  197.         di = llseek(fhnd, 0, 0)
  198.     End If
  199.     
  200.     ' Now we need a buffer that will contain the metafile data
  201.     currentfileloc& = llseek(fhnd, 0, 1)
  202.     mfinfosize& = llseek(fhnd, 0, 2) - currentfileloc&
  203.  
  204.     
  205.     ' Now allocate a buffer to hold the data
  206.     ' We use the Global memory pool because this buffer
  207.     ' could easily be above 64k bytes.
  208.     Set gmem = sys.GlobalAlloc(GMEM_MOVEABLE, mfinfosize)
  209.     gptr& = gmem.GlobalLock()
  210.     dl = llseek(fhnd, currentfileloc, 0)
  211.  
  212.     dl = hread(fhnd, ByVal gptr, mfinfosize)
  213.  
  214.     ' Win32 does not support the SetMetaFileBitsBetter function
  215.     #If Win32 Then
  216.         ' If we were using a byte array, we could use
  217.         ' the original definition of SetMetaFileBitsEx, but
  218.         ' we want to preserve 16 bit compatibility
  219.         Set mf = gmem.SetMetafileBits()
  220.         gmem.GlobalUnlock
  221.     #Else
  222.         gmem.GlobalUnlock
  223.         Set mf = gmem.SetMetafileBits()
  224.     #End If
  225.     
  226.     di = lclose(fhnd)
  227.  
  228.     ' Don't delete the global handle - it holds the metafile data
  229.     Set LoadTheMetafile = mf
  230. End Function
  231.  
  232. '
  233. '
  234. ' Even though xExt and yExt are longs, they are limited to integer
  235. ' values to stay compatible with the METAFILEHEADER structure
  236. '
  237. Function SaveTheMetafile(filename$, mfhnd As dwMetaFile, xExt&, yExt&)
  238.     #If Win32 Then
  239.         Dim fhnd&
  240.         Dim di&, dl&
  241.     #Else
  242.         Dim fhnd%
  243.         Dim di%, dl&
  244.     #End If
  245.     Dim sys As New dwSystem
  246.     Dim DC As dwDeviceContext
  247.     Dim newmf As New dwMetaFile
  248.     Dim gmem As New dwGlobalMemory
  249.     Dim mfile As METAFILEHEADER
  250.     Dim mfinfosize&
  251.     Dim currentfileloc&
  252.     Dim gptr&
  253.  
  254.     Dim oldsize As New dwPoint
  255.  
  256.     ' Open the file to write
  257.     fhnd = lcreat(filename$, 0)
  258.     fhnd = lopen(filename$, 2)
  259.     If fhnd < 0 Then Exit Function
  260.     If mfhnd Is Nothing Then Exit Function
  261.  
  262.  
  263.     ' First write a placeable header file header
  264.     mfile.key = &H9AC6CDD7  ' The key - required
  265.     mfile.hMF = 0           ' Must be 0
  266.     mfile.bbox.left = 0
  267.     mfile.bbox.top = 0
  268.     ' These should be calculated using GetDeviceCaps
  269.     mfile.bbox.right = xExt + 1 ' Size in metafile units of bounding area
  270.     mfile.bbox.bottom = yExt + 1
  271.     mfile.inch = 1000 ' Number of metafile units per inch
  272.     
  273.     mfile.Reserved = 0
  274.     ' Build the checksum
  275.     mfile.checksum = &H9AC6 Xor &HCDD7
  276.     mfile.checksum = mfile.checksum Xor mfile.bbox.right
  277.     mfile.checksum = mfile.checksum Xor mfile.bbox.bottom
  278.     mfile.checksum = mfile.checksum Xor mfile.inch
  279.     
  280.     
  281.     ' Write the buffer
  282.     di = lwrite(fhnd, mfile, Len(mfile))
  283.     
  284.     ' Now we retrieve a handle that will contain the
  285.     ' metafile  - We make a copy, but first we set the
  286.     ' extents so that it can be properly displayed
  287.     Set DC = sys.CreateMetafile(vbNullString)
  288.     DC.SetWindowExtEx xExt, yExt, oldsize
  289.     di = DC.SetMapMode(MM_ANISOTROPIC)
  290.     DC.PlayMetaFile mfhnd
  291.     Set newmf = DC.CloseMetafile()
  292.     
  293.     #If Win32 Then
  294.         ' Find out how bit the buffer needs to be
  295.         mfinfosize = newmf.GetMetafileBitsSize()
  296.         If mfinfosize = 0 Then
  297.             di = lclose(fhnd)
  298.             Exit Function
  299.         End If
  300.         Set gmem = sys.GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, mfinfosize)
  301.         gptr = gmem.GlobalLock()
  302.         newmf.GetMetafileBitsByAddr mfinfosize, ByVal gptr
  303.     #Else
  304.         Set gmem = newmf.GetMetafileBitsByAddr()
  305.         gptr = gmem.GlobalLock()
  306.         mfinfosize = gmem.GlobalSize()
  307.     #End If
  308.  
  309.     
  310.     dl = hwrite(fhnd, ByVal gptr, mfinfosize)
  311.  
  312.     gmem.GlobalUnlock
  313.     gmem.GlobalFree
  314.     di = lclose(fhnd)
  315.  
  316. End Function
  317.  
  318.