home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 4_2005-2006.ISO / data / Zips / Stretching1888045132005.psc / cDIB32.cls < prev    next >
Text File  |  2005-05-10  |  25KB  |  725 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "cDIB32"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. '================================================
  15. ' Class:         cDIB32.cls (cDIB 32-bit version)
  16. ' Author:        Carles P.V.
  17. ' Dependencies:
  18. ' Last revision: 2004.9.12 (# 2005.04.02)
  19. '================================================
  20. '
  21. ' - 2004.08.18
  22. '
  23. '   * Fixed CreateFromBitmapFile() function:
  24. '     m_uBIH structure was not initialized (filled) -> Save() function failed
  25. '     Thanks to Paul Caton
  26. '
  27. '     Now, private variables 'm_Width, m_Height, m_BPP, m_BytesPerScanline and m_Size'
  28. '     have been removed. Directly taken from m_uBIH structure.
  29. '
  30. '   * Also added CreateFromResourceBitmap() variation (by Paul Caton)
  31. '
  32. ' - 2004.08.19
  33. '
  34. '   * Fixed Image() Property:
  35. '     Going back to original routine. Probably problems for using a still selected DIB (?).
  36. '     Anyway, old function worked well when setting/extracting Image to/from VB-Clipboard
  37. '     using vbCFDIB format (but not using vbCFBitmap one) (?).
  38. '     Also, curiously, Image was returned as 'down-top DIB'.
  39. '
  40. '   * Improved Save() function: Removed GlobalLock/GlobalUnlock. Redundant when allocating
  41. '     fixed memory. The GlobalAlloc returns the memory pointer.
  42. '
  43. '   Thanks again, Paul.
  44. '
  45. ' - 2004.09.12
  46. '
  47. '   * Fixed CreateFromStdPicture() function.
  48. '   * Added StretchBltMode param. in Stretch() and Paint() functions.
  49. '
  50. '========================================================================================
  51. '
  52. ' # 2005.04.02
  53. '
  54. '   * Current cDIB32:
  55. '     - Simplified version: only accepting 32-bit bitmaps
  56. '     - New CreateFromResourceBitmap() (uses LoadLibraryEx()). Thanks to redbird77.
  57.  
  58. Option Explicit
  59.  
  60. '-- API:
  61.  
  62. Private Type BITMAPFILEHEADER
  63.     bfType      As Integer
  64.     bfSize      As Long
  65.     bfReserved1 As Integer
  66.     bfReserved2 As Integer
  67.     bfOffBits   As Long
  68. End Type
  69.  
  70. Private Type BITMAPINFOHEADER
  71.     biSize          As Long
  72.     biWidth         As Long
  73.     biHeight        As Long
  74.     biPlanes        As Integer
  75.     biBitCount      As Integer
  76.     biCompression   As Long
  77.     biSizeImage     As Long
  78.     biXPelsPerMeter As Long
  79.     biYPelsPerMeter As Long
  80.     biClrUsed       As Long
  81.     biClrImportant  As Long
  82. End Type
  83.  
  84. Private Type BITMAP
  85.     bmType       As Long
  86.     bmWidth      As Long
  87.     bmHeight     As Long
  88.     bmWidthBytes As Long
  89.     bmPlanes     As Integer
  90.     bmBitsPixel  As Integer
  91.     bmBits       As Long
  92. End Type
  93.  
  94. Private Type GUID
  95.     Data1 As Long
  96.     Data2 As Integer
  97.     Data3 As Integer
  98.     Data4(7) As Byte
  99. End Type
  100.  
  101. Private Type PICTDESC
  102.     Size     As Long
  103.     Type     As Long
  104.     hBmp     As Long
  105.     hPal     As Long
  106.     Reserved As Long
  107. End Type
  108.  
  109. Private Type RECT2
  110.     x1 As Long
  111.     y1 As Long
  112.     x2 As Long
  113.     y2 As Long
  114. End Type
  115.  
  116. Private Const DIB_RGB_COLORS      As Long = 0
  117. Private Const COLORONCOLOR        As Long = 3
  118. Private Const HALFTONE            As Long = 4
  119. Private Const OBJ_BITMAP          As Long = 7
  120. Private Const LR_LOADFROMFILE     As Long = &H10
  121. Private Const IMAGE_BITMAP        As Long = 0
  122. Private Const LR_CREATEDIBSECTION As Long = &H2000
  123.  
  124. Private Declare Function CreateDIBSection32 Lib "gdi32" Alias "CreateDIBSection" (ByVal hDC As Long, lpBitsInfo As BITMAPINFOHEADER, ByVal wUsage As Long, lpBits As Long, ByVal handle As Long, ByVal dw As Long) As Long
  125. Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal dwImageType As Long, ByVal dwDesiredWidth As Long, ByVal dwDesiredHeight As Long, ByVal dwFlags As Long) As Long
  126.  
  127. Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
  128. Private Declare Function GetObjectType Lib "gdi32" (ByVal hgdiobj As Long) As Long
  129. Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
  130. Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
  131. Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
  132. Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
  133. Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
  134. Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
  135. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  136. Private Declare Function BitBlt Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
  137. Private Declare Function StretchBlt Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
  138. Private Declare Function SetStretchBltMode Lib "gdi32" (ByVal hDC As Long, ByVal nStretchMode As Long) As Long
  139. Private Declare Function SetRect Lib "user32" (lpRect As RECT2, ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As Long
  140. Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As RECT2, ByVal hBrush As Long) As Long
  141. Private Declare Function OleTranslateColor Lib "olepro32" (ByVal OLE_COLOR As Long, ByVal hPalette As Long, ColorRef As Long) As Long
  142. Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
  143. Private Declare Function OleCreatePictureIndirect Lib "olepro32" (lpPictDesc As PICTDESC, riid As Any, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
  144.  
  145. Private Declare Function FindResourceStr Lib "kernel32" Alias "FindResourceA" (ByVal hInstance As Long, ByVal lpName As String, ByVal lpType As Long) As Long
  146. Private Declare Function LoadLibraryEx Lib "kernel32" Alias "LoadLibraryExA" (ByVal lpLibFileName As String, ByVal hFile As Long, ByVal dwFlags As Long) As Long
  147. Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
  148. Private Declare Function LoadResource Lib "kernel32" (ByVal hInstance As Long, ByVal hResInfo As Long) As Long
  149. Private Declare Function LockResource Lib "kernel32" (ByVal hResData As Long) As Long
  150. Private Declare Function SizeofResource Lib "kernel32" (ByVal hInstance As Long, ByVal hResInfo As Long) As Long
  151.  
  152. Private Const LOAD_LIBRARY_AS_DATAFILE As Long = &H2
  153. Private Const RT_BITMAP                As Long = 2
  154.  
  155. '//
  156.  
  157. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDst As Any, lpSrc As Any, ByVal Length As Long)
  158. Private Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (lpDst As Any, ByVal Length As Long)
  159.  
  160. '//
  161.  
  162. Private Const CF_DIB As Long = 8
  163.  
  164. Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
  165. Private Declare Function EmptyClipboard Lib "user32" () As Long
  166. Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
  167. Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
  168. Private Declare Function CloseClipboard Lib "user32" () As Long
  169.  
  170. '//
  171.  
  172. Private Const GMEM_FIXED    As Long = &H0
  173. Private Const GMEM_MOVEABLE As Long = &H2
  174. Private Const GMEM_DDESHARE As Long = &H2000
  175. Private Const GMEM_ZEROINIT As Long = &H40
  176.  
  177. Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
  178. Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
  179. Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
  180. Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
  181. Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
  182.  
  183. '//
  184.  
  185. Private Const INVALID_HANDLE_VALUE  As Long = -1
  186. Private Const CREATE_ALWAYS         As Long = 2
  187. Private Const GENERIC_READ          As Long = &H80000000
  188. Private Const GENERIC_WRITE         As Long = &H40000000
  189. Private Const FILE_ATTRIBUTE_NORMAL As Long = &H80
  190.  
  191. Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
  192. Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As Any) As Long
  193. Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
  194.  
  195. '//
  196.  
  197. '-- Public Enums.:
  198. Public Enum eBPPCts
  199.     [01_bpp] = 1
  200.     [04_bpp] = 4
  201.     [08_bpp] = 8
  202.     [16_bpp] = 16
  203.     [24_bpp] = 24
  204.     [32_bpp] = 32
  205. End Enum
  206.  
  207. Public Enum eStretchBltModeCts
  208.     [sbmColorOnColor] = COLORONCOLOR
  209.     [sbmHalftone] = HALFTONE
  210. End Enum
  211.  
  212. '-- Private Variables:
  213. Private m_uBIH    As BITMAPINFOHEADER
  214. Private m_hDC     As Long
  215. Private m_hDIB    As Long
  216. Private m_hOldDIB As Long
  217. Private m_lpBits  As Long
  218.  
  219.  
  220.  
  221. '========================================================================================
  222. ' Class
  223. '========================================================================================
  224.  
  225. Private Sub Class_Terminate()
  226.  
  227.     '-- Destroy current DIB
  228.     Call Me.Destroy
  229. End Sub
  230.  
  231.  
  232.  
  233. '========================================================================================
  234. ' Methods
  235. '========================================================================================
  236.  
  237. Public Function Create(ByVal Width As Long, _
  238.                        ByVal Height As Long _
  239.                        ) As Long
  240.     
  241.     '-- Destroy previous
  242.     Call Me.Destroy
  243.     
  244.     '-- Define DIB header
  245.     With m_uBIH
  246.         .biSize = Len(m_uBIH)
  247.         .biPlanes = 1
  248.         .biBitCount = 32
  249.         .biWidth = Width
  250.         .biHeight = Height
  251.         .biSizeImage = (4 * .biWidth) * .biHeight
  252.     End With
  253.     
  254.     '-- Create DIB and select into a DC
  255.     m_hDC = CreateCompatibleDC(0)
  256.     If (m_hDC <> 0) Then
  257.         m_hDIB = CreateDIBSection32(m_hDC, m_uBIH, DIB_RGB_COLORS, m_lpBits, 0, 0)
  258.         If (m_hDIB <> 0) Then
  259.             m_hOldDIB = SelectObject(m_hDC, m_hDIB)
  260.           Else
  261.             Call Me.Destroy
  262.         End If
  263.     End If
  264.     
  265.     '-- Success
  266.     Create = m_hDIB
  267. End Function
  268.  
  269. Public Function CreateFromBitmapFile(ByVal Filename As String _
  270.                                     ) As Long
  271.   
  272.   Dim uBI As BITMAP
  273.     
  274.     '-- File exists [?]
  275.     If (FileLen(Filename)) Then
  276.     
  277.         '-- Destroy previous
  278.         Call Me.Destroy
  279.  
  280.         '-- Create DIB and select into a DC
  281.         m_hDC = CreateCompatibleDC(0)
  282.         If (m_hDC <> 0) Then
  283.             m_hDIB = LoadImage(App.hInstance, Filename, IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE Or LR_CREATEDIBSECTION)
  284.             
  285.             '-- Is there a DIB handle
  286.             If (m_hDIB <> 0) Then
  287.                 Call GetObject(m_hDIB, Len(uBI), uBI)
  288.                 
  289.                 '-- 32-bit?
  290.                 If (uBI.bmBitsPixel = 32) Then
  291.                     m_hOldDIB = SelectObject(m_hDC, m_hDIB)
  292.                   Else
  293.                     Call Me.Destroy
  294.                 End If
  295.               
  296.               Else
  297.                 Call Me.Destroy
  298.             End If
  299.         End If
  300.         
  301.         '-- Get DIB props.:
  302.         If (m_hDIB <> 0) Then
  303.             '-- Get props.:
  304.             With m_uBIH
  305.                 .biSize = Len(m_uBIH)
  306.                 .biPlanes = 1
  307.                 .biBitCount = uBI.bmBitsPixel
  308.                 .biWidth = uBI.bmWidth
  309.                 .biHeight = uBI.bmHeight
  310.                 .biSizeImage = (4 * .biWidth) * .biHeight
  311.             End With
  312.             '-- Bits pointer
  313.             m_lpBits = uBI.bmBits
  314.             
  315.             '-- Success
  316.             CreateFromBitmapFile = m_hDIB
  317.         End If
  318.     End If
  319. End Function
  320.  
  321. Public Function CreateFromResourceBitmap(ByVal Filename As String, _
  322.                                          ByVal ResID As Variant _
  323.                                          ) As Long
  324.  
  325.   Dim hInstance As Long
  326.   Dim hInfo     As Long
  327.   Dim hData     As Long
  328.   Dim lSize     As Long
  329.  
  330.   Dim uBIH      As BITMAPINFOHEADER
  331.   Dim lpResHDR  As Long
  332.   Dim lpResBMP  As Long
  333.   
  334.     '-- File exists [?]
  335.     If (FileLen(Filename)) Then
  336.  
  337.         '-- Get handle to the mapped executable module
  338.         hInstance = LoadLibraryEx(Filename, 0, LOAD_LIBRARY_AS_DATAFILE)
  339.         If (hInstance) Then
  340.             
  341.             '-- Get resource info handle
  342.             hInfo = FindResourceStr(hInstance, IIf(IsNumeric(ResID), "#", vbNullString) & ResID, RT_BITMAP)
  343.             If (hInfo) Then
  344.             
  345.                 '-- Get handle to DIB data
  346.                 hData = LoadResource(hInstance, hInfo)
  347.                 If (hData) Then
  348.                 
  349.                     '-- Get size of DIB data
  350.                     lSize = SizeofResource(hInstance, hInfo)
  351.         
  352.                     '-- Get pointer to first byte of DIB data (header)
  353.                     lpResHDR = LockResource(hData)
  354.                     
  355.                     '-- Extract DIB info header
  356.                     Call CopyMemory(uBIH, ByVal lpResHDR, Len(uBIH))
  357.                     
  358.                     '-- 32-bit?
  359.                     If (uBIH.biBitCount = 32) Then
  360.                     
  361.                         '-- Create DIB / fill data
  362.                         If (Me.Create(uBIH.biWidth, uBIH.biHeight)) Then
  363.                             
  364.                             lpResBMP = lpResHDR + Len(m_uBIH)
  365.                             With m_uBIH
  366.                                 Call CopyMemory(ByVal m_lpBits, ByVal lpResBMP, .biSizeImage)
  367.                             End With
  368.                             
  369.                             '-- Success
  370.                             CreateFromResourceBitmap = m_hDIB
  371.                         End If
  372.                     End If
  373.                 End If
  374.             End If
  375.             Call FreeLibrary(hInstance)
  376.         End If
  377.     End If
  378. End Function
  379.  
  380. Public Function CreateFromClipboard() As Long
  381.     
  382.   Dim hClipMem  As Long
  383.   Dim lpClipHDR As Long
  384.   Dim lpClipBMP As Long
  385.   Dim uBIH      As BITMAPINFOHEADER
  386.   
  387.     If (OpenClipboard(0)) Then
  388.         
  389.         '-- Get clipboard mem. handle
  390.         hClipMem = GetClipboardData(CF_DIB)
  391.         If (hClipMem <> 0) Then
  392.             
  393.             '-- Get pointer / access data
  394.             lpClipHDR = GlobalLock(hClipMem)
  395.             If (lpClipHDR <> 0) Then
  396.                 
  397.                 '-- Extract DIB info header
  398.                 Call CopyMemory(uBIH, ByVal lpClipHDR, Len(uBIH))
  399.                 
  400.                 '-- 32-bit?
  401.                 If (uBIH.biBitCount = 32) Then
  402.  
  403.                     '-- Create DIB / fill data
  404.                     If (Me.Create(uBIH.biWidth, uBIH.biHeight)) Then
  405.                         
  406.                         lpClipBMP = lpClipHDR + Len(m_uBIH)
  407.                         With m_uBIH
  408.                             Call CopyMemory(ByVal m_lpBits, ByVal lpClipBMP, .biSizeImage)
  409.                         End With
  410.                             
  411.                         '-- Success
  412.                         CreateFromClipboard = m_hDIB
  413.                     End If
  414.                 End If
  415.                 Call GlobalUnlock(hClipMem)
  416.             End If
  417.         End If
  418.         Call CloseClipboard
  419.     End If
  420. End Function
  421.  
  422. Public Function CopyToClipboard() As Long
  423.  
  424.   Dim hMem      As Long
  425.   Dim lpClipHDR As Long
  426.   Dim lpClipBMP As Long
  427.   Dim lSize     As Long
  428.     
  429.     If (m_hDIB <> 0) Then
  430.     
  431.         If (OpenClipboard(0)) Then
  432.             
  433.             '-- Size of packed DIB
  434.             lSize = Len(m_uBIH) + m_uBIH.biSizeImage
  435.             
  436.             '-- Get mem. handle and its pointer
  437.             hMem = GlobalAlloc(GMEM_MOVEABLE, lSize)
  438.             If (hMem <> 0) Then
  439.                 lpClipHDR = GlobalLock(hMem)
  440.                 If (lpClipHDR <> 0) Then
  441.                 
  442.                     lpClipBMP = lpClipHDR + Len(m_uBIH)
  443.                     
  444.                     '-- Copy data
  445.                     Call CopyMemory(ByVal lpClipHDR, m_uBIH, Len(m_uBIH))
  446.                     Call CopyMemory(ByVal lpClipBMP, ByVal lpBits, m_uBIH.biSizeImage)
  447.                     Call GlobalUnlock(hMem)
  448.                     
  449.                     '-- Paste to Clipboard
  450.                     Call EmptyClipboard
  451.                     CopyToClipboard = SetClipboardData(CF_DIB, hMem)
  452.                     Call CloseClipboard
  453.                 End If
  454.             End If
  455.         End If
  456.     End If
  457. End Function
  458.  
  459. Public Function CloneTo(oDIB32 As cDIB32 _
  460.                         ) As Long
  461.     
  462.     If (m_hDIB <> 0) Then
  463.     
  464.         '-- Create dest. DIB
  465.         If (oDIB32 Is Nothing) Then Set oDIB32 = New cDIB32
  466.         If (oDIB32.Create(m_uBIH.biWidth, m_uBIH.biHeight)) Then
  467.             '-- Copy color data
  468.             Call CopyMemory(ByVal oDIB32.lpBits, ByVal m_lpBits, m_uBIH.biSizeImage)
  469.             '-- Success
  470.             CloneTo = oDIB32.hDIB
  471.         End If
  472.     End If
  473. End Function
  474.  
  475. Public Function Save(ByVal Filename As String _
  476.                      ) As Boolean
  477.  
  478.   Const BITMAPTYPE  As Integer = &H4D42
  479.   
  480.   Dim hFile         As Long
  481.   Dim lRet          As Long
  482.   Dim lBytesWritten As Long
  483.  
  484.   Dim hMem          As Long
  485.   Dim lPtr          As Long
  486.   Dim uBFH          As BITMAPFILEHEADER
  487.   Dim aPal()        As Byte
  488.   Dim lColors       As Long
  489.   
  490.     If (m_hDIB <> 0) Then
  491.     
  492.         '-- Get file handler
  493.         hFile = CreateFile(Filename, GENERIC_READ Or GENERIC_WRITE, ByVal 0, ByVal 0, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0)
  494.         
  495.         If (hFile <> INVALID_HANDLE_VALUE) Then
  496.             
  497.             '-- Prepare file header
  498.             With uBFH
  499.                 .bfType = BITMAPTYPE
  500.                 .bfSize = Len(m_uBIH) + m_uBIH.biSizeImage
  501.                 .bfOffBits = Len(uBFH) + Len(m_uBIH)
  502.             End With
  503.             
  504.             '-- Not long alignment...
  505.             hMem = GlobalAlloc(GMEM_FIXED + GMEM_ZEROINIT, Len(uBFH))
  506.             lPtr = GlobalLock(hMem)
  507.             Call CopyMemory(ByVal lPtr, uBFH.bfType, 2)
  508.             Call CopyMemory(ByVal lPtr + 2, uBFH.bfSize, 4)
  509.             Call CopyMemory(ByVal lPtr + 6, 0, 4)
  510.             Call CopyMemory(ByVal lPtr + 10, uBFH.bfOffBits, 4)
  511.             
  512.             '-- Write file header
  513.             lRet = WriteFile(hFile, ByVal lPtr, Len(uBFH), lBytesWritten, ByVal 0)
  514.             Call GlobalUnlock(hMem)
  515.             Call GlobalFree(hMem)
  516.             
  517.             If (lRet <> 0) Then
  518.                 
  519.                 '-- Write bitmap info header
  520.                 lRet = WriteFile(hFile, m_uBIH, Len(m_uBIH), lBytesWritten, ByVal 0)
  521.                 '-- Write bitmap color data
  522.                 If (lRet <> 0) Then
  523.                     lRet = WriteFile(hFile, ByVal m_lpBits, m_uBIH.biSizeImage, lBytesWritten, ByVal 0)
  524.                 End If
  525.             End If
  526.             Call CloseHandle(hFile)
  527.             
  528.             '-- Success
  529.             Save = (lRet <> 0)
  530.         End If
  531.     End If
  532. End Function
  533.  
  534. Public Sub Destroy()
  535.  
  536.     '-- Destroy DIB
  537.     If (m_hDC <> 0) Then
  538.         If (m_hDIB <> 0) Then
  539.             Call SelectObject(m_hDC, m_hOldDIB)
  540.             Call DeleteObject(m_hDIB)
  541.         End If
  542.         Call DeleteDC(m_hDC)
  543.     End If
  544.     
  545.     '-- Reset BIH structure
  546.     Call ZeroMemory(m_uBIH, Len(m_uBIH))
  547.     
  548.     '-- Reset DIB vars.
  549.     m_hDC = 0
  550.     m_hDIB = 0
  551.     m_hOldDIB = 0
  552.     m_lpBits = 0
  553. End Sub
  554.  
  555. '//
  556.  
  557. Public Function Paint(ByVal hDC As Long, _
  558.                       Optional ByVal x As Long = 0, _
  559.                       Optional ByVal y As Long = 0, _
  560.                       Optional ByVal ROP As RasterOpConstants = vbSrcCopy, _
  561.                       Optional ByVal StretchBltMode As eStretchBltModeCts = [sbmColorOnColor] _
  562.                       ) As Long
  563.     
  564.     Paint = Me.Stretch(hDC, x, y, m_uBIH.biWidth, m_uBIH.biHeight, , , , , ROP, StretchBltMode)
  565. End Function
  566.  
  567. Public Function Stretch(ByVal hDC As Long, _
  568.                         ByVal x As Long, _
  569.                         ByVal y As Long, _
  570.                         ByVal nWidth As Long, _
  571.                         ByVal nHeight As Long, _
  572.                         Optional ByVal xSrc As Long, _
  573.                         Optional ByVal ySrc As Long, _
  574.                         Optional ByVal nSrcWidth As Long, _
  575.                         Optional ByVal nSrcHeight As Long, _
  576.                         Optional ByVal ROP As RasterOpConstants = vbSrcCopy, _
  577.                         Optional ByVal StretchBltMode As eStretchBltModeCts = [sbmColorOnColor] _
  578.                         ) As Long
  579.   
  580.   Dim lOldMode As Long
  581.     
  582.     If (m_hDIB <> 0) Then
  583.         
  584.         If (nSrcWidth = 0) Then nSrcWidth = m_uBIH.biWidth
  585.         If (nSrcHeight = 0) Then nSrcHeight = m_uBIH.biHeight
  586.         
  587.         lOldMode = SetStretchBltMode(hDC, StretchBltMode)
  588.         Stretch = StretchBlt(hDC, x, y, nWidth, nHeight, m_hDC, xSrc, ySrc, nSrcWidth, nSrcHeight, ROP)
  589.         Call SetStretchBltMode(hDC, lOldMode)
  590.     End If
  591. End Function
  592.  
  593. Public Sub Cls(Optional ByVal Color As OLE_COLOR = vbBlack)
  594.   
  595.   Dim uRect  As RECT2
  596.   Dim hBrush As Long
  597.    
  598.     If (m_hDIB <> 0) Then
  599.         Call SetRect(uRect, 0, 0, m_uBIH.biWidth, m_uBIH.biHeight)
  600.         Call OleTranslateColor(Color, 0, Color)
  601.         hBrush = CreateSolidBrush(Color)
  602.         Call FillRect(m_hDC, uRect, hBrush)
  603.         Call DeleteObject(hBrush)
  604.     End If
  605. End Sub
  606.  
  607. Public Sub Reset()
  608.     
  609.     If (m_hDIB <> 0) Then
  610.         Call ZeroMemory(ByVal m_lpBits, m_uBIH.biSizeImage)
  611.     End If
  612. End Sub
  613.  
  614. '//
  615.  
  616. Public Sub GetBestFitInfo(ByVal SrcW As Long, _
  617.                           ByVal SrcH As Long, _
  618.                           ByVal DstW As Long, _
  619.                           ByVal DstH As Long, _
  620.                           bfx As Long, _
  621.                           bfy As Long, _
  622.                           bfW As Long, _
  623.                           bfH As Long, _
  624.                           Optional ByVal StretchFit As Boolean = False)
  625.                           
  626.   Dim cW As Single
  627.   Dim cH As Single
  628.     
  629.     If ((SrcW > DstW Or SrcH > DstH) Or StretchFit) Then
  630.         cW = DstW / SrcW
  631.         cH = DstH / SrcH
  632.         If (cW < cH) Then
  633.             bfW = DstW
  634.             bfH = SrcH * cW
  635.           Else
  636.             bfH = DstH
  637.             bfW = SrcW * cH
  638.         End If
  639.       Else
  640.         bfW = SrcW
  641.         bfH = SrcH
  642.     End If
  643.     If (bfW < 1) Then bfW = 1
  644.     If (bfH < 1) Then bfH = 1
  645.     bfx = (DstW - bfW) \ 2
  646.     bfy = (DstH - bfH) \ 2
  647. End Sub
  648.  
  649.  
  650.  
  651. '========================================================================================
  652. ' Properties
  653. '========================================================================================
  654.  
  655. Public Property Get hDC() As Long
  656.     hDC = m_hDC
  657. End Property
  658.  
  659. Public Property Get hDIB() As Long
  660.     hDIB = m_hDIB
  661. End Property
  662.  
  663. Public Property Get lpBits() As Long
  664.     lpBits = m_lpBits
  665. End Property
  666.  
  667. Public Property Get Width() As Long
  668.     Width = m_uBIH.biWidth
  669. End Property
  670.  
  671. Public Property Get Height() As Long
  672.     Height = m_uBIH.biHeight
  673. End Property
  674.  
  675. Public Property Get BytesPerScanline() As Long
  676.     BytesPerScanline = 4 * m_uBIH.biWidth
  677. End Property
  678.  
  679. Public Property Get Size() As Long
  680.     Size = m_uBIH.biSizeImage
  681. End Property
  682.  
  683. Public Property Get Image() As StdPicture
  684.     
  685.   Dim lhSrcDC       As Long
  686.   Dim lhDC          As Long
  687.   Dim lhBmp         As Long
  688.   Dim lhOldBmp      As Long
  689.   Dim lpPictDesc    As PICTDESC
  690.   Dim IID_IDispatch As GUID
  691.  
  692.     If (m_hDIB <> 0) Then
  693.     
  694.         '-- Create screen compatible bitmap
  695.         lhSrcDC = GetDC(0)
  696.         lhDC = CreateCompatibleDC(lhSrcDC)
  697.         lhBmp = CreateCompatibleBitmap(lhSrcDC, m_uBIH.biWidth, m_uBIH.biHeight)
  698.         lhOldBmp = SelectObject(lhDC, lhBmp)
  699.         Call ReleaseDC(0, lhSrcDC)
  700.         
  701.         '-- Paint from DIB
  702.         Call Me.Paint(lhDC)
  703.         '-- Clean up
  704.         Call SelectObject(lhDC, lhOldBmp)
  705.         Call DeleteDC(lhDC)
  706.         
  707.         '-- Fill image info
  708.         With lpPictDesc
  709.             .Size = Len(lpPictDesc)
  710.             .Type = vbPicTypeBitmap
  711.             .hBmp = lhBmp
  712.             .hPal = 0
  713.         End With
  714.         '-- Fill GUID info
  715.         With IID_IDispatch
  716.             .Data1 = &H20400
  717.             .Data4(0) = &HC0
  718.             .Data4(7) = &H46
  719.         End With
  720.         
  721.         '-- Create picture from bitmap handle
  722.         Call OleCreatePictureIndirect(lpPictDesc, IID_IDispatch, 1, Image)
  723.     End If
  724. End Property
  725.