home *** CD-ROM | disk | FTP | other *** search
/ Programming Tool Box / SIMS_2.iso / vb_code1 / ole_2_bm / ole2bm.bas next >
BASIC Source File  |  1994-05-07  |  11KB  |  230 lines
  1. '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  2. ' OLE2BM.BAS ver. 1.1           VB 3.0 Pro Module                rev. 5/07/94
  3. '____________________________________________________________________________
  4. '
  5. ' The VB 3.0 Pro code in this module provides a way to transfer bitmap data
  6. ' back and forth between a PaintBrush object within an OLE 2.0 control (use
  7. ' MSOLE2.VBX, not OLECLIENT.VBX!) and a picture box on a container form such
  8. ' that the user can edit the bitmap manually in PaintBrush along the way.
  9. '
  10. ' This capability is useful when you wish to draw certain bitmap elements
  11. ' programmatically before or after hand editing.
  12. '
  13. ' The considerable effort required in the support procedures below is quite
  14. ' typical of the wall one hits in attempting to gain programmatic control
  15. ' over data in embedded OLE 2.0 objects under VB.  Getting the data into the
  16. ' OLE2 control is relatively easy--getting it out is the hard part.
  17. '
  18. ' If you know a simpler way to get the data out, I'd love to hear from you!
  19. '
  20. ' NB: The function OleFile2Picture() buffers bitmap data in a big VB string.
  21. ' This procedure must be rewritten to handle bitmaps larger than or near 64K
  22. ' in size.
  23. '
  24. '   Jeremy McCreary
  25. '   Cliffshade Computing
  26. '   CIS [72341,3716]
  27. '____________________________________________________________________________
  28.  
  29. Option Explicit
  30. DefInt A-Z
  31.  
  32. '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  33. ' Bitmap-related constants and data structures
  34. '____________________________________________________________________________
  35.  
  36. Global Const OLE_CREATE_EMBED = 0   ' Ole control .Action settings
  37. Global Const OLE_ACTIVATE = 7
  38. Global Const OLE_SAVE_TO_FILE = 11
  39.  
  40. Global Const OLE_CHANGED = 0        ' Ole control .Updated event code
  41.  
  42. Global Const SRCCOPY = &HCC0020     ' BitBlt raster op: Overwrite destination
  43.  
  44. Global Const CBM_INIT = &H4&        ' Init created DIB with the data passed
  45. Global Const DIB_RGB_COLORS = 0     ' DIB file color tables use RGB values
  46. Global Const OBJECT_HEADER_SIZE = 20  ' OLE file header length
  47.  
  48. Type BitmapFileHeaderType ' File header common to =all= Win 3.x .BMP files
  49.   bfType As Integer       ' Always contains string abbreviation "BM"
  50.   bfSize      As Long     ' Bitmap file size in bytes
  51.   bfReserved1 As Integer  ' Set to 0  (Mouse cursor hotspot x coord)
  52.   bfReserved2 As Integer  ' Set to 0  (Mouse cursor hotspot y coord)
  53.   bfOffBits   As Long     ' Offset from start of this header to start of data
  54. End Type
  55.  
  56.  
  57. '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  58. ' Required Windows 3.1 API declarations in type-safe form.
  59. '____________________________________________________________________________
  60.  
  61. Declare Function AnsiPrev Lib "User" (ByVal VBStr$, ByVal VBStr$) As Long
  62. Declare Function BitBlt Lib "GDI" (ByVal DesthDC, ByVal DestX, ByVal DestY, ByVal DestWidth, ByVal DestHeight, ByVal SourcehDC, ByVal SourceX, ByVal SourceY, ByVal ROP As Long)
  63. Declare Function CreateCompatibleDC Lib "GDI" (ByVal hDC)
  64. Declare Function CreateDIBitmapPacked Lib "GDI" Alias "CreateDIBitmap" (ByVal hDC, ByVal lpPackedDIB&, ByVal InitFlag&, ByVal lpDataBits&, ByVal lpBitmapInfo&, ByVal ColorUse)
  65. Declare Function DeleteDC Lib "GDI" (ByVal hDC)
  66. Declare Function DeleteObject Lib "GDI" (ByVal hObj)
  67. Declare Function GetTempFileName Lib "Kernel" (ByVal DriveLetterAscii, ByVal PrefixName$, ByVal Unique, ByVal NameBuffer$)
  68. Declare Function SelectObject Lib "GDI" (ByVal hDC, ByVal hObject)
  69.  
  70. '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  71. ' Transfer an embedded bitmap object from an OLE 2.0 (MSOLE2.VBX) control to
  72. ' a VB picture box via the intermediaries of a temporary OLE file and a
  73. ' packed DIB memory structure.
  74. '____________________________________________________________________________
  75. Sub Ole2Pic (pic As PictureBox, ole As Control)
  76. Dim f, h0, hbm, hmem, hpic, r
  77. Dim file$, kind$
  78.  
  79.   file$ = TempFileName$("")       ' Open a temporary OLE file
  80.   f = FreeFile
  81.   Open file$ For Binary As f
  82.   ole.FileNumber = f              ' Make its handle the save destination
  83.   ole.Action = OLE_SAVE_TO_FILE   ' Save the embedded data as an OLE 2.0 file
  84.   Close f
  85.   kind$ = ole.Class               ' Get correct object type
  86.  
  87.   hbm = OLEFile2Picture(pic, kind$, file$) ' Extract the bitmap from the OLE file
  88.   If hbm Then                     ' Copy the extracted DDB into picture box
  89.     hpic = pic.hDC
  90.     hmem = CreateCompatibleDC(hpic)
  91.     h0 = SelectObject(hmem, hbm)  ' Select the DDB into the memory DC
  92.     r = BitBlt(hpic, 0, 0, CInt(pic.ScaleWidth), CInt(pic.ScaleHeight), hmem, 0, 0, SRCCOPY)
  93.     r = SelectObject(hmem, h0)    ' Restore the object previously selected
  94.     r = DeleteObject(hbm)         ' Recover system resources
  95.     r = DeleteDC(hmem)
  96.     pic.Refresh                   ' Update the screen now
  97.   End If
  98.   
  99.   Kill file$                      ' Waste the temporary OLE file
  100.  
  101. End Sub
  102.  
  103. '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  104. ' Copy the device-independent bitmap (DIB) contained in a PaintBrush object
  105. ' OLE 2.0 file to a packed DIB memory image, create a device-dependent bitmap
  106. ' (DDB) from the packed DIB, and return the DDB handle for future reference.
  107. '
  108. ' NB: Once the DDB is created (i.e., once the packed DIB color table has been
  109. ' translated to the nearest available device-specific colors), subsequent
  110. ' display of the bitmap goes =much= faster than if displayed directly as a
  111. ' packed DIB, say with StretchDIBits().
  112. '____________________________________________________________________________
  113. Function OLEFile2Picture (pic As PictureBox, kind$, OLEfile$)
  114. Dim hbm, hOLE, k
  115. Dim buffers As Long, bytes As Long, ptr As Long, remainder As Long
  116. Dim BitmapOffset As Long, lpDataBits As Long, lpPackedDIB As Long
  117. Dim buffer$, PackedDIB$
  118. Dim bfh As BitmapFileHeaderType
  119. Const BUFFER_SIZE = 8192              ' File input buffer length
  120. Const STRING_LIMIT = 65500
  121. Const MB = 16                         ' Stop style MsgBox
  122.  
  123.   hOLE = FreeFile                     ' Open the source OLE file
  124.   Open OLEfile$ For Binary As hOLE
  125.     
  126.   If LOF(hOLE) > OBJECT_HEADER_SIZE Then
  127.     buffer$ = Space$(BUFFER_SIZE)
  128.     Get hOLE, 1, buffer$              ' Get first bufferfull of OLE file data
  129.     ptr = InStr(buffer$, kind$)       ' Look for a correct object class name
  130.     If ptr Then                       ' Find the bitmap's starting offset
  131.       BitmapOffset = InStr(ptr, buffer$, "BM")
  132.       If BitmapOffset Then            ' Read the embedded bitmap file
  133.         Get hOLE, BitmapOffset, bfh   ' Read the bitmap file header
  134.         bytes = bfh.bfSize - Len(bfh) ' Calculate number of buffers needed
  135.         If bytes > STRING_LIMIT Then  ' Can't use a VB string buffer
  136.             MsgBox "Sorry, your bitmap is too large to buffer in a VB string.", MB, "OLE2 File Error"
  137.             GoTo OLEFile2PictureExit  ' Beat feet
  138.         Else                          ' Initialize string to eventual size to
  139.             PackedDIB$ = Space$(bytes) ' avoid "Out of string space" error
  140.         End If
  141.         buffer$ = Space$(BUFFER_SIZE)
  142.         buffers = bytes \ BUFFER_SIZE
  143.         remainder = bytes Mod BUFFER_SIZE
  144.         ptr = 1&                      ' ptr -> 1st byte of bitmapinfo header
  145.         Do Until ptr > bytes - remainder ' Build up a packed DIB memory image in
  146.           Get hOLE, , buffer$            '  a VB string, 1 bufferfull at a time
  147.           Mid$(PackedDIB$, ptr, BUFFER_SIZE) = buffer$
  148.           ptr = ptr + BUFFER_SIZE
  149.         Loop
  150.         buffer$ = Space$(remainder)   ' Now get what's left
  151.         Get hOLE, , buffer$
  152.         Mid$(PackedDIB$, ptr) = buffer$
  153.         lpPackedDIB = SSegAddr(PackedDIB$) ' Get a long pointer to packed DIB
  154.         lpDataBits = lpPackedDIB + bfh.bfOffBits - Len(bfh)  ' and data bits
  155.       ' Create a device-dependent bitmap (DDB) compatible with the target
  156.       ' picture box device context.
  157.         hbm = CreateDIBitmapPacked(pic.hDC, lpPackedDIB, CBM_INIT, lpDataBits, lpPackedDIB, DIB_RGB_COLORS)
  158.         PackedDIB$ = ""               ' Free up memory
  159.         buffer$ = ""
  160.         Else
  161.           MsgBox "Sorry, couldn't find an embedded bitmap within the first " & Format$(BUFFER_SIZE) & " bytes of your OLE2 file.", MB, "OLE2 File Error"
  162.       End If
  163.     Else
  164.       MsgBox "Sorry, couldn't find the '" & kind$ & "' class name in your OLE2 file header.", MB, "OLE2 File Error"
  165.     End If
  166.   Else
  167.     MsgBox "Sorry, your OLE2 file is too small to contain a bitmap.", MB, "OLE2 File Error"
  168.   End If
  169.   
  170. OLEFile2PictureExit:
  171.   Close hOLE                          ' Done with the OLE file
  172.   OLEFile2Picture = hbm               ' Pass back the DDB handle
  173.  
  174. End Function
  175.  
  176. '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  177. ' Embed the bitmap contained within a VB picture box in an OLE 2.0 control
  178. ' (MSOLE2.VBX) via a temporary .BMP file.
  179. '
  180. ' NB: The OLE control =requires= the .SourceDoc file to have the extension
  181. ' "BMP" in order to embed its data as a PaintBrush object.
  182. '____________________________________________________________________________
  183. Sub Pic2Ole (pic As PictureBox, ole As Control)
  184. Dim r
  185. Dim file$
  186.  
  187.   file$ = TempFileName$("BMP")   ' Get a temporary file name with .BMP ext.
  188.   SavePicture pic.Image, file$   ' Save the picture box bitmap as a DIB file
  189.   ole.Class = "PBrush"           ' Specify creation of Pbrush bitmap object
  190.   ole.SourceDoc = file$          ' Make the temporary file the data source
  191.   ole.Action = OLE_CREATE_EMBED  ' Embed the data as an OLE 2.0 object
  192.   Kill file$                     ' Waste the temporary file
  193.  
  194. End Sub
  195.  
  196. '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  197. ' Get a long pointer to the VB string passed using an AnsiPrev() trick.
  198. '____________________________________________________________________________
  199. Function SSegAddr (VB$) As Long
  200.  
  201.   SSegAddr = AnsiPrev(ByVal VB$, ByVal VB$)
  202.  
  203. End Function
  204.  
  205. '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  206. ' Create a temporary file, which will live briefly in the subdirectory
  207. ' specified by the user's TEMP environment variable--with luck perhaps
  208. ' on a ram drive for speed.
  209. '____________________________________________________________________________
  210. Function TempFileName$ (ext$)
  211. Dim r
  212. Dim file$
  213. Const DOT = 46                            ' ANSI code for period
  214.  
  215.   file$ = Space$(255)                     ' Allow plenty of room for the name
  216.   r = GetTempFileName(0, "", -1, file$)   ' Let Windows supply a name
  217.   file$ = Trim(file$)                     ' Strip off any excess white space
  218.   If Len(ext$) Then                       ' Replace the .TMP extension
  219.     r = InStr(file$, ".TMP")              ' Find the .TMP extension
  220.     If r Then                             ' Replace if present
  221.       If Asc(ext$) <> DOT Then r = r + 1  ' Does ext. passed include period?
  222.       Mid$(file$, r) = ext$               ' Replace .TMP with new extension
  223.     End If
  224.   End If
  225.  
  226.   TempFileName$ = file$                   ' Pass back the temporary file name
  227.  
  228. End Function
  229.  
  230.