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 / dwbitmap.cls < prev    next >
Encoding:
Text File  |  1996-04-05  |  7.8 KB  |  191 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4. END
  5. Attribute VB_Name = "dwBitmap"
  6. Attribute VB_Creatable = True
  7. Attribute VB_Exposed = True
  8. Option Explicit
  9.  
  10. ' Class dwBitmap
  11. ' Desaware API Toolkit object library
  12. ' Copyright (c) 1996 by Desaware Inc.
  13. ' All rights reserved
  14.  
  15. #If Win32 Then
  16. Private ihBitmap As Long
  17. #Else
  18. Private ihBitmap As Integer
  19. #End If
  20. Private iStockBm As Boolean
  21.  
  22. #If Win32 Then
  23. Private Declare Function apiDeleteObject Lib "gdi32" Alias "DeleteObject" (ByVal handle As Long) As Long
  24. Private Declare Function apiCreateBitmap& Lib "gdi32" Alias "CreateBitmap" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, ByVal lpBits As Long)
  25. Private Declare Function apiCreateBitmapIndirect& Lib "gdi32" Alias "CreateBitmapIndirect" (ByVal lpBitmap As Long)
  26. Private Declare Function apiCreateCompatibleBitmap& Lib "gdi32" Alias "CreateCompatibleBitmap" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long)
  27. Private Declare Function apiGetBitmapBits& Lib "gdi32" Alias "GetBitmapBits" (ByVal hBitmap As Long, ByVal dwCount As Long, ByVal lpBits As Long)
  28. Private Declare Function apiGetBitmapDimensionEx& Lib "gdi32" Alias "GetBitmapDimensionEx" (ByVal hBitmap As Long, lpDimension As Size)
  29. Private Declare Function apiLoadBitmap& Lib "user32" Alias "LoadBitmapA" (ByVal hInstance As Long, ByVal lpBitmapName As Any)
  30. Private Declare Function apiSetBitmapBits& Lib "gdi32" Alias "SetBitmapBits" (ByVal hBitmap As Long, ByVal dwCount As Long, ByVal lpBits As Long)
  31. Private Declare Function apiSetBitmapDimensionEx& Lib "gdi32" Alias "SetBitmapDimensionEx" (ByVal hbm As Long, ByVal nX As Long, ByVal nY As Long, lpSize As Size)
  32. Private Declare Function apiGetObject& Lib "gdi32" Alias "GetObjectA" (ByVal handle As Long, ByVal nCount As Long, ByVal plBuffer As Long)
  33. #Else
  34. Private Declare Function apiDeleteObject% Lib "gdi" Alias "DeleteObject" (ByVal handle As Integer)
  35. Private Declare Function apiCreateBitmap% Lib "gdi" Alias "CreateBitmap" (ByVal nWidth As Integer, ByVal nHeight As Integer, ByVal nPlanes As Integer, ByVal nBitCount As Integer, ByVal lpBits As Long)
  36. Private Declare Function apiCreateBitmapIndirect% Lib "gdi" Alias "CreateBitmapIndirect" (lpBitmap As BITMAP)
  37. Private Declare Function apiCreateCompatibleBitmap% Lib "gdi" Alias "CreateCompatibleBitmap" (ByVal hDC As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer)
  38. Private Declare Function apiGetBitmapBits& Lib "gdi" Alias "GetBitmapBits" (ByVal hBitmap As Integer, ByVal dwCount As Long, ByVal lpBits As Any)
  39. Private Declare Function apiGetBitmapDimensionEx% Lib "gdi" Alias "GetBitmapDimensionEx" (ByVal hBitmap As Integer, lpDimension As Size)
  40. Private Declare Function apiLoadBitmap% Lib "user" Alias "LoadBitmap" (ByVal hInstance As Integer, ByVal lpBitmapName As Any)
  41. Private Declare Function apiSetBitmapBits& Lib "gdi" Alias "SetBitmapBits" (ByVal hBitmap As Integer, ByVal dwCount As Long, ByVal lpBits As Any)
  42. Private Declare Function apiSetBitmapDimensionEx% Lib "gdi" Alias "SetBitmapDimensionEx" (ByVal nY As Integer, lpSize As Size, ByVal hBitmap As Integer, ByVal nX As Integer)
  43. Private Declare Function apiGetObject% Lib "gdi" Alias "GetObject" (ByVal handle As Integer, ByVal nCount As Integer, ByVal plBuffer As Long)
  44. #End If 'WIN32
  45.  
  46. Public Property Get hBitmap() As Long
  47.     hBitmap = ihBitmap
  48. End Property
  49.  
  50. Public Sub CreateBitmap(ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, Bits() As Long)
  51. Attribute CreateBitmap.VB_HelpID = 2490
  52. Attribute CreateBitmap.VB_Description = "Help available in Visual Basic Programmer's Guide to Win32 API CD ROM"
  53.     Dim ret&
  54.  
  55.     ClearBitmap
  56.     ret& = apiCreateBitmap(nWidth, nHeight, nPlanes, nBitCount, Bits(0))
  57.     If ret& = 0 Then RaiseBitmapError
  58.     ihBitmap = ret&
  59.     iStockBm = False
  60. End Sub
  61.  
  62. Public Sub CreateBitmapIndirect(lpBitmap As Long)
  63. Attribute CreateBitmapIndirect.VB_HelpID = 2491
  64. Attribute CreateBitmapIndirect.VB_Description = "Help available in Visual Basic Programmer's Guide to Win32 API CD ROM"
  65. #If Win32 Then
  66.     Dim ret&
  67.     
  68.     ClearBitmap
  69.     ret& = apiCreateBitmapIndirect(lpBitmap)
  70.     If ret& = 0 Then RaiseBitmapError
  71.     ihBitmap = ret&
  72.     iStockBm = False
  73. #Else
  74.     Dim ret%
  75.     Dim tmpBitmap As BITMAP
  76.     
  77.     ClearBitmap
  78.     agCopyData agGetAddressForObject(tmpBitmap), lpBitmap, Len(tmpBitmap)
  79.     ret% = apiCreateBitmapIndirect(tmpBitmap)
  80.     If ret% = 0 Then RaiseBitmapError
  81.     ihBitmap = ret%
  82.     iStockBm = False
  83. #End If
  84. End Sub
  85.  
  86. Public Sub CreateCompatibleBitmap(dc As dwDeviceContext, ByVal nWidth As Long, ByVal nHeight As Long)
  87. Attribute CreateCompatibleBitmap.VB_HelpID = 2493
  88. Attribute CreateCompatibleBitmap.VB_Description = "Help available in Visual Basic Programmer's Guide to Win32 API CD ROM"
  89.     Dim ret&
  90.     
  91.     ClearBitmap
  92.     ret& = apiCreateCompatibleBitmap(dc.hDC, nWidth, nHeight)
  93.     If ret& = 0 Then RaiseBitmapError
  94.     ihBitmap = ret&
  95.     iStockBm = False
  96. End Sub
  97.  
  98. Public Sub GetBitmapBits(ByVal dwCount As Long, lpBits As Long)
  99. Attribute GetBitmapBits.VB_HelpID = 2538
  100. Attribute GetBitmapBits.VB_Description = "Help available in Visual Basic Programmer's Guide to Win32 API CD ROM"
  101.     Dim ret&
  102.     
  103.     If ihBitmap = 0 Then RaiseBitmapError DWERR_UNINITIALIZED
  104.     ret& = apiGetBitmapBits(ihBitmap, dwCount, lpBits)
  105.     If ret& = 0 Then RaiseBitmapError
  106. End Sub
  107.  
  108. Public Property Get Height() As Long
  109.     Dim ret&
  110.     Dim iBitmap As BITMAP
  111.     
  112.     If ihBitmap = 0 Then RaiseBitmapError DWERR_UNINITIALIZED
  113.     ret& = apiGetObject(ihBitmap, Len(iBitmap), agGetAddressForObject(iBitmap.bmType))
  114.     If ret& = 0 Then RaiseBitmapError
  115.     Height = iBitmap.bmHeight
  116. End Property
  117.  
  118. Public Property Get Width() As Long
  119.     Dim ret&
  120.     Dim iBitmap As BITMAP
  121.     
  122.     If ihBitmap = 0 Then RaiseBitmapError DWERR_UNINITIALIZED
  123.     ret& = apiGetObject(ihBitmap, Len(iBitmap), agGetAddressForObject(iBitmap.bmType))
  124.     If ret& = 0 Then RaiseBitmapError
  125.     Width = iBitmap.bmWidth
  126. End Property
  127.  
  128. Public Sub LoadBitmap(ByVal hInstance As Long, ByVal lpBitmapName)
  129. Attribute LoadBitmap.VB_HelpID = 3022
  130. Attribute LoadBitmap.VB_Description = "Help available in Visual Basic Programmer's Guide to Win32 API CD ROM"
  131.     Dim ret&
  132.     
  133.     ClearBitmap
  134.     If hInstance = 0 Then
  135.         ret& = apiLoadBitmap(hInstance, ByVal CLng(lpBitmapName))
  136.         iStockBm = True
  137.     Else
  138.         ret& = apiLoadBitmap(hInstance, ByVal CStr(lpBitmapName))
  139.         iStockBm = False
  140.     End If
  141.     If ret& = 0 Then RaiseBitmapError
  142.     ihBitmap = ret&
  143. End Sub
  144.  
  145. Public Sub SetBitmapBits(ByVal dwCount As Long, lpBits As Long)
  146. Attribute SetBitmapBits.VB_HelpID = 2614
  147.     Dim ret&
  148.     
  149.     If ihBitmap = 0 Then RaiseBitmapError DWERR_UNINITIALIZED
  150.     ret& = apiSetBitmapBits(ihBitmap, dwCount, lpBits)
  151.     If ret& = 0 Then RaiseBitmapError
  152. End Sub
  153.  
  154. Public Sub ClearBitmap()
  155.     If Not iStockBm And ihBitmap <> 0 Then
  156.         Call apiDeleteObject(ihBitmap)
  157.         ihBitmap = 0
  158.     End If
  159. End Sub
  160.  
  161. Private Sub RaiseBitmapError(Optional errval)
  162.     If IsMissing(errval) Then
  163.         RaiseBitmapError DWERR_APIRESULT
  164.     Else
  165.         RaiseError errval, "dwBitmap"
  166.     End If
  167. End Sub
  168.  
  169. Public Property Get IsStockBitmap() As Boolean
  170.     If ihBitmap = 0 Then RaiseBitmapError DWERR_UNINITIALIZED
  171.     IsStockBitmap = iStockBm
  172. End Property
  173.  
  174. Private Sub Class_Terminate()
  175.     ClearBitmap
  176. End Sub
  177.  
  178. Public Sub CopyFrom(bm As dwBitmap)
  179.     Dim dc1 As New dwDeviceContext
  180.     Dim dc2 As New dwDeviceContext
  181.     Dim dc3 As New dwDeviceContext
  182.     
  183.     dc3.CreateDC "Display", vbNullString, vbNullString, Nothing
  184.     dc1.CreateCompatibleDC dc3
  185.     dc2.CreateCompatibleDC dc3
  186.     Set dc3 = Nothing
  187.     dc1.SelectObjectBitmap Me
  188.     dc2.SelectObjectBitmap bm
  189.     dc1.BitBlt 0, 0, bm.Width, bm.Height, dc2, 0, 0, dc1.SRCCOPY
  190. End Sub
  191.