home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 6_2008-2009.ISO / data / zips / Boring_ana2164141022009.psc / cDIBSection.cls < prev    next >
Text File  |  2005-11-24  |  23KB  |  722 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 = "cDIBSection"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. Option Explicit
  15.  
  16. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
  17.     lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
  18.  
  19. Private Type SAFEARRAYBOUND
  20.     cElements As Long
  21.     lLbound As Long
  22. End Type
  23. Private Type SAFEARRAY2D
  24.     cDims As Integer
  25.     fFeatures As Integer
  26.     cbElements As Long
  27.     cLocks As Long
  28.     pvData As Long
  29.     Bounds(0 To 1) As SAFEARRAYBOUND
  30. End Type
  31. Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" ( _
  32.    Ptr() As Any) As Long
  33.  
  34. Private Type RGBQUAD
  35.     rgbBlue As Byte
  36.     rgbGreen As Byte
  37.     rgbRed As Byte
  38.     rgbReserved As Byte
  39. End Type
  40. Private Type BITMAPINFOHEADER '40 bytes
  41.     biSize As Long
  42.     biWidth As Long
  43.     biHeight As Long
  44.     biPlanes As Integer
  45.     biBitCount As Integer
  46.     biCompression As Long
  47.     biSizeImage As Long
  48.     biXPelsPerMeter As Long
  49.     biYPelsPerMeter As Long
  50.     biClrUsed As Long
  51.     biClrImportant As Long
  52. End Type
  53. Private Type BITMAPINFO
  54.     bmiHeader As BITMAPINFOHEADER
  55.     bmiColors As RGBQUAD
  56. End Type
  57. Private Declare Function CreateCompatibleDC Lib "gdi32" ( _
  58.    ByVal HDC As Long) As Long
  59. Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
  60. Private Declare Function GetDesktopWindow Lib "user32" () As Long
  61. ' Note - this is not the declare in the API viewer - modify lplpVoid to be
  62. ' Byref so we get the pointer back:
  63. Private Declare Function CreateDIBSection Lib "gdi32" _
  64.     (ByVal HDC As Long, _
  65.     pBitmapInfo As BITMAPINFO, _
  66.     ByVal un As Long, _
  67.     lplpVoid As Long, _
  68.     ByVal handle As Long, _
  69.     ByVal dw As Long) As Long
  70. Private Declare Function BitBlt Lib "gdi32" ( _
  71.    ByVal hDestDC As Long, _
  72.    ByVal x As Long, ByVal y As Long, _
  73.    ByVal nWidth As Long, ByVal nHeight As Long, _
  74.    ByVal hSrcDC As Long, _
  75.    ByVal xSrc As Long, ByVal ySrc As Long, _
  76.    ByVal dwRop As Long) As Long
  77. Private Declare Function SelectObject Lib "gdi32" ( _
  78.    ByVal HDC As Long, ByVal hObject As Long) As Long
  79. Private Declare Function DeleteObject Lib "gdi32" ( _
  80.    ByVal hObject As Long) As Long
  81. Private Declare Function DeleteDC Lib "gdi32" (ByVal HDC As Long) As Long
  82. Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" ( _
  83.    ByVal hInst As Long, ByVal lpsz As String, _
  84.    ByVal un1 As Long, _
  85.    ByVal n1 As Long, ByVal n2 As Long, _
  86.    ByVal un2 As Long) As Long
  87. Private Const BI_RGB = 0&
  88. Private Const BI_RLE4 = 2&
  89. Private Const BI_RLE8 = 1&
  90. Private Const DIB_RGB_COLORS = 0 '  color table in RGBs
  91.  
  92. Private Type BITMAP
  93.     bmType As Long
  94.     bmWidth As Long
  95.     bmHeight As Long
  96.     bmWidthBytes As Long
  97.     bmPlanes As Integer
  98.     bmBitsPixel As Integer
  99.     bmBits As Long
  100. End Type
  101. Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" ( _
  102.    ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
  103.  
  104. ' Start of structure:
  105. Private Const BITMAPTYPE As Integer = &H4D42
  106. Private Type BITMAPFILEHEADER
  107.    bfType As Integer '- type  ="BM" i.e &H4D42 - 2
  108.    bfSize As Long ' - size in bytes of file - 6
  109.    bfReserved1 As Integer ' - reserved, must be 0 - 8
  110.    bfReserved2 As Integer ' - reserved, must be 0 - 10
  111.    bfOffBits As Long ' offset from this structure to the bitmap bits - 14
  112. End Type
  113. Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" ( _
  114.    ByVal lpFileName As String, ByVal dwDesiredAccess As Long, _
  115.    ByVal dwShareMode As Long, lpSecurityAttributes As Any, _
  116.    ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, _
  117.    ByVal hTemplateFile As Long) As Long
  118. Private Declare Function ReadFile Lib "kernel32" ( _
  119.    ByVal hFile As Long, lpBuffer As Any, _
  120.    ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, _
  121.    lpOverlapped As Any) As Long
  122. Private Declare Function WriteFile Lib "kernel32" ( _
  123.    ByVal hFile As Long, _
  124.    lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, _
  125.    lpNumberOfBytesWritten As Long, lpOverlapped As Any) As Long
  126. Private Declare Function SetFilePointer Lib "kernel32" ( _
  127.    ByVal hFile As Long, _
  128.    ByVal lDistanceToMove As Long, _
  129.    lpDistanceToMoveHigh As Long, _
  130.    ByVal dwMoveMethod As Long) As Long
  131. Private Declare Function CloseHandle Lib "kernel32" ( _
  132.    ByVal hObject As Long) As Long
  133. Private Const INVALID_HANDLE_VALUE = -1
  134. Private Const CREATE_ALWAYS = 2
  135. Private Const GENERIC_READ = &H80000000
  136. Private Const GENERIC_WRITE = &H40000000
  137. Private Const FILE_ATTRIBUTE_ARCHIVE = &H20
  138. Private Const FILE_ATTRIBUTE_COMPRESSED = &H800
  139. Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
  140. Private Const FILE_ATTRIBUTE_HIDDEN = &H2
  141. Private Const FILE_ATTRIBUTE_NORMAL = &H80
  142. Private Const FILE_ATTRIBUTE_READONLY = &H1
  143. Private Const FILE_ATTRIBUTE_SYSTEM = &H4
  144. Private Const FILE_ATTRIBUTE_TEMPORARY = &H100
  145. Private Const FILE_BEGIN = 0
  146. Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
  147. Private Declare Function GlobalAlloc Lib "kernel32" ( _
  148.    ByVal wFlags As Long, _
  149.    ByVal dwBytes As Long) As Long
  150. Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
  151. Private Declare Function GlobalUnlock Lib "kernel32" ( _
  152.    ByVal hMem As Long) As Long
  153. Private Const GMEM_FIXED = &H0
  154. Private Const GMEM_ZEROINIT = &H40
  155. Private Const GPTR = (GMEM_FIXED Or GMEM_ZEROINIT)
  156.  
  157. Private Const FORMAT_MESSAGE_ALLOCATE_BUFFER = &H100
  158. Private Const FORMAT_MESSAGE_ARGUMENT_ARRAY = &H2000
  159. Private Const FORMAT_MESSAGE_FROM_HMODULE = &H800
  160. Private Const FORMAT_MESSAGE_FROM_STRING = &H400
  161. Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
  162. Private Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200
  163. Private Const FORMAT_MESSAGE_MAX_WIDTH_MASK = &HFF
  164. Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" ( _
  165.  ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, _
  166.  ByVal dwLanguageId As Long, ByVal lpBuffer As String, _
  167.  ByVal nSize As Long, Arguments As Long) As Long
  168.  
  169. Private Declare Function GetDIBits Lib "gdi32" ( _
  170.    ByVal aHDC As Long, ByVal hBitmap As Long, _
  171.    ByVal nStartScan As Long, ByVal nNumScans As Long, _
  172.    lpBits As Long, lpBI As BITMAPINFO, _
  173.    ByVal wUsage As Long) As Long
  174. Private Declare Function CreateDIBitmap Lib "gdi32" ( _
  175.    ByVal HDC As Long, _
  176.    lpInfoHeader As BITMAPINFOHEADER, ByVal dwUsage As Long, _
  177.    lpInitBits As Any, lpInitInfo As BITMAPINFO, _
  178.    ByVal wUsage As Long) As Long
  179.  
  180. ' DrawDIB functions:
  181. Private Declare Function DrawDibOpen Lib "msvfw32.dll" () As Long
  182. Private Declare Function DrawDibClose Lib "msvfw32.dll" ( _
  183.    ByVal hDD As Long) As Long
  184. Private Declare Function DrawDibDraw Lib "msvfw32.dll" ( _
  185.    ByVal hDD As Long, _
  186.    ByVal HDC As Long, _
  187.    ByVal xDst As Long, ByVal yDst As Long, _
  188.    ByVal dxDst As Long, ByVal dyDst As Long, _
  189.    lpBI As Any, lpBits As Any, _
  190.    ByVal xSrc As Long, ByVal ySrc As Long, _
  191.    ByVal dxSrc As Long, ByVal dySrc As Long, _
  192.       ByVal wFlags As Long) As Long
  193.  
  194. Private Type BLENDFUNCTION
  195.   BlendOp As Byte
  196.   BlendFlags As Byte
  197.   SourceConstantAlpha As Byte
  198.   AlphaFormat As Byte
  199. End Type
  200. ' BlendOp:
  201. Private Const AC_SRC_OVER = &H0
  202. ' AlphaFormat:
  203. Private Const AC_SRC_ALPHA = &H1
  204.  
  205. Private Declare Function AlphaBlend Lib "MSIMG32.DLL" ( _
  206.   ByVal hdcDest As Long, _
  207.   ByVal nXOriginDest As Long, _
  208.   ByVal nYOriginDest As Long, _
  209.   ByVal nWidthDest As Long, _
  210.   ByVal nHeightDest As Long, _
  211.   ByVal hdcSrc As Long, _
  212.   ByVal nXOriginSrc As Long, _
  213.   ByVal nYOriginSrc As Long, _
  214.   ByVal nWidthSrc As Long, _
  215.   ByVal nHeightSrc As Long, _
  216.   ByVal lBlendFunction As Long _
  217. ) As Long
  218. Private Declare Function TransparentBlt Lib "MSIMG32.DLL" ( _
  219.   ByVal hdcDest As Long, _
  220.   ByVal nXOriginDest As Long, _
  221.   ByVal nYOriginDest As Long, _
  222.   ByVal nWidthDest As Long, _
  223.   ByVal hHeightDest As Long, _
  224.   ByVal hdcSrc As Long, _
  225.   ByVal nXOriginSrc As Long, _
  226.   ByVal nYOriginSrc As Long, _
  227.   ByVal nWidthSrc As Long, _
  228.   ByVal nHeightSrc As Long, _
  229.   ByVal crTransparent As Long _
  230.  ) As Long
  231.  
  232. Private m_hDIb As Long
  233. Private m_hBmpOld As Long
  234. Private m_hDC As Long
  235. Private m_hDD As Long
  236. Private m_lPtr As Long
  237. Private m_tBI As BITMAPINFO
  238.  
  239. Public Property Get UseDrawDib() As Boolean
  240.    UseDrawDib = Not (m_hDD = 0)
  241. End Property
  242. Public Property Let UseDrawDib(ByVal bState As Boolean)
  243.    If bState Then
  244.       If m_hDD = 0 Then
  245.          m_hDD = DrawDibOpen()
  246.       End If
  247.    Else
  248.       If Not (m_hDD = 0) Then
  249.          DrawDibClose m_hDD
  250.       End If
  251.    End If
  252. End Property
  253.  
  254.  
  255. Public Function CreateDIB( _
  256.         ByVal lHDC As Long, _
  257.         ByVal lWidth As Long, _
  258.         ByVal lHeight As Long, _
  259.         ByRef hDib As Long _
  260.     ) As Boolean
  261.     With m_tBI.bmiHeader
  262.         .biSize = Len(m_tBI.bmiHeader)
  263.         .biWidth = lWidth
  264.         .biHeight = lHeight
  265.         .biPlanes = 1
  266.         .biBitCount = 24
  267.         .biCompression = BI_RGB
  268.         .biSizeImage = BytesPerScanLine * .biHeight
  269.     End With
  270.     hDib = CreateDIBSection( _
  271.             lHDC, _
  272.             m_tBI, _
  273.             DIB_RGB_COLORS, _
  274.             m_lPtr, _
  275.             0, 0)
  276.     CreateDIB = (hDib <> 0)
  277. End Function
  278. Public Function CreateFromPicture( _
  279.         ByRef picThis As StdPicture _
  280.     )
  281. Dim lHDC As Long
  282. Dim lhDCDesktop As Long
  283. Dim lhBmpOld As Long
  284. Dim tBMP As BITMAP
  285.     
  286.     GetObjectAPI picThis.handle, Len(tBMP), tBMP
  287.     If (Create(tBMP.bmWidth, tBMP.bmHeight)) Then
  288.         lhDCDesktop = GetDC(GetDesktopWindow())
  289.         If (lhDCDesktop <> 0) Then
  290.             lHDC = CreateCompatibleDC(lhDCDesktop)
  291.             DeleteDC lhDCDesktop
  292.             If (lHDC <> 0) Then
  293.                 lhBmpOld = SelectObject(lHDC, picThis.handle)
  294.                 LoadPictureBlt lHDC
  295.                 SelectObject lHDC, lhBmpOld
  296.                 DeleteObject lHDC
  297.             End If
  298.         End If
  299.     End If
  300. End Function
  301. Public Function Create( _
  302.         ByVal lWidth As Long, _
  303.         ByVal lHeight As Long _
  304.     ) As Boolean
  305. Dim bDrawDib As Boolean
  306.    bDrawDib = UseDrawDib()
  307.     ClearUp
  308.     m_hDC = CreateCompatibleDC(0)
  309.     If (m_hDC <> 0) Then
  310.         If (CreateDIB(m_hDC, lWidth, lHeight, m_hDIb)) Then
  311.             m_hBmpOld = SelectObject(m_hDC, m_hDIb)
  312.             UseDrawDib = bDrawDib
  313.             Create = True
  314.         Else
  315.             DeleteObject m_hDC
  316.             m_hDC = 0
  317.         End If
  318.     End If
  319. End Function
  320. Public Property Get BytesPerScanLine() As Long
  321.     ' Scans must align on dword boundaries:
  322.     BytesPerScanLine = (m_tBI.bmiHeader.biWidth * 3 + 3) And &HFFFFFFFC
  323. End Property
  324.  
  325. Public Property Get Width() As Long
  326.     Width = m_tBI.bmiHeader.biWidth
  327. End Property
  328. Public Property Get Height() As Long
  329.     Height = m_tBI.bmiHeader.biHeight
  330. End Property
  331.  
  332. Public Sub LoadPictureBlt( _
  333.         ByVal lHDC As Long, _
  334.         Optional ByVal lSrcLeft As Long = 0, _
  335.         Optional ByVal lSrcTop As Long = 0, _
  336.         Optional ByVal lSrcWidth As Long = -1, _
  337.         Optional ByVal lSrcHeight As Long = -1, _
  338.         Optional ByVal eRop As RasterOpConstants = vbSrcCopy _
  339.     )
  340.     If lSrcWidth < 0 Then lSrcWidth = m_tBI.bmiHeader.biWidth
  341.     If lSrcHeight < 0 Then lSrcHeight = m_tBI.bmiHeader.biHeight
  342.     BitBlt m_hDC, 0, 0, lSrcWidth, lSrcHeight, lHDC, lSrcLeft, lSrcTop, eRop
  343. End Sub
  344. Public Function SavePicture(ByVal sFileName As String) As Boolean
  345. Dim lC As Long, i As Long
  346.  
  347.    ' Save to BMP:
  348.    SavePicture = SaveToBitmap(m_lPtr, sFileName)
  349.  
  350. End Function
  351. Private Function SaveToBitmap(ByVal lPtrBits As Long, ByVal sFileName As String)
  352. Dim tBH As BITMAPFILEHEADER
  353. Dim tRGBQ As RGBQUAD
  354. Dim hFile As Long
  355. Dim lBytesWritten As Long
  356. Dim lSize As Long
  357. Dim lR As Long
  358. Dim bErr As Boolean
  359. Dim hMem As Long, lPtr As Long
  360. Dim lErr As Long
  361.  
  362.    ' Prepare the BITMAPFILEHEADER
  363.    With tBH
  364.       .bfType = BITMAPTYPE
  365.       .bfOffBits = 14 + Len(m_tBI)
  366.       .bfSize = .bfOffBits + m_tBI.bmiHeader.biSizeImage
  367.    End With
  368.    hFile = CreateFile(sFileName, _
  369.                  GENERIC_READ Or GENERIC_WRITE, _
  370.                   ByVal 0&, _
  371.                   ByVal 0&, _
  372.                   CREATE_ALWAYS, _
  373.                   FILE_ATTRIBUTE_NORMAL, _
  374.                   0)
  375.    lErr = Err.LastDllError
  376.    If (hFile = INVALID_HANDLE_VALUE) Then
  377.       ' error
  378.       Err.Raise 17, App.EXEName & ".cDIBSection", ApiError(lErr)
  379.    Else
  380.       
  381.       ' Writing the BITMAPFILEINFOHEADER is somewhat painful
  382.       ' due to non-byte alignment of structure...
  383.       hMem = GlobalAlloc(GPTR, 14)
  384.       lPtr = GlobalLock(hMem)
  385.       CopyMemory ByVal lPtr, tBH.bfType, 2
  386.       CopyMemory ByVal lPtr + 2, tBH.bfSize, 4
  387.       CopyMemory ByVal lPtr + 6, 0&, 4
  388.       CopyMemory ByVal lPtr + 10, tBH.bfOffBits, 4
  389.       lSize = 14
  390.       lR = WriteFile(hFile, ByVal lPtr, lSize, lBytesWritten, ByVal 0&)
  391.       GlobalUnlock hMem
  392.       GlobalFree hMem
  393.       
  394.       ' Add the BITMAPINFOHEADER and colour palette:
  395.       bErr = FileErrHandler(lR, lSize, lBytesWritten)
  396.       If Not bErr Then
  397.          lSize = Len(m_tBI)
  398.          lR = WriteFile(hFile, m_tBI, lSize, lBytesWritten, ByVal 0&)
  399.          bErr = FileErrHandler(lR, lSize, lBytesWritten)
  400.       End If
  401.       
  402.       If Not bErr Then
  403.          ' Its easy to write the bitmap data, though...
  404.          lSize = m_tBI.bmiHeader.biSizeImage
  405.          lR = WriteFile(hFile, ByVal lPtrBits, lSize, lBytesWritten, ByVal 0&)
  406.          bErr = FileErrHandler(lR, lSize, lBytesWritten)
  407.       End If
  408.       
  409.       
  410.       CloseHandle hFile
  411.       SaveToBitmap = Not (bErr)
  412.    End If
  413.  
  414. End Function
  415. Private Function ApiError(ByVal e As Long) As String
  416.     Dim s As String, c As Long
  417.     s = String(256, 0)
  418.     c = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM Or _
  419.                       FORMAT_MESSAGE_IGNORE_INSERTS, _
  420.                       0, e, 0&, s, Len(s), ByVal 0)
  421.     If c Then ApiError = Left$(s, c)
  422. End Function
  423. Private Function FileErrHandler( _
  424.       ByVal lR As Long, _
  425.       ByVal lSize As Long, ByVal lBytes As Long _
  426.    ) As Boolean
  427.    If (lR = 0) Or Not (lSize = lBytes) Then
  428.       'Err.Raise
  429.       FileErrHandler = True
  430.    End If
  431. End Function
  432.  
  433.  
  434. Public Sub PaintPicture( _
  435.         ByVal lHDC As Long, _
  436.         Optional ByVal lDestLeft As Long = 0, _
  437.         Optional ByVal lDestTop As Long = 0, _
  438.         Optional ByVal lDestWidth As Long = -1, _
  439.         Optional ByVal lDestHeight As Long = -1, _
  440.         Optional ByVal lSrcLeft As Long = 0, _
  441.         Optional ByVal lSrcTop As Long = 0, _
  442.         Optional ByVal eRop As RasterOpConstants = vbSrcCopy, _
  443.         Optional ByVal crTransparent As Long = -1 _
  444.     )
  445.    If (lDestWidth < 0) Then lDestWidth = m_tBI.bmiHeader.biWidth
  446.    If (lDestHeight < 0) Then lDestHeight = m_tBI.bmiHeader.biHeight
  447.    If Not (m_hDD = 0) Then
  448.       ' DrawDib method:
  449.       DrawDibDraw m_hDD, lHDC, lDestLeft, lDestTop, _
  450.       lDestWidth, lDestHeight, _
  451.        m_tBI, _
  452.        ByVal m_lPtr, _
  453.        lSrcLeft, lSrcTop, _
  454.        lDestWidth, lDestHeight, 0
  455.    Else
  456.       If Not (crTransparent = -1) Then
  457.          TransparentBlt lHDC, lDestLeft, lDestTop, _
  458.             lDestWidth, lDestHeight, _
  459.             m_hDC, _
  460.             lSrcLeft, lSrcTop, _
  461.             lDestWidth, lDestHeight, _
  462.             crTransparent
  463.       Else
  464.          BitBlt lHDC, lDestLeft, lDestTop, _
  465.             lDestWidth, lDestHeight, _
  466.             m_hDC, _
  467.             lSrcLeft, lSrcTop, eRop
  468.       End If
  469.    End If
  470. End Sub
  471. Public Sub AlphaPaintPicture( _
  472.         ByVal lHDC As Long, _
  473.         Optional ByVal lDestLeft As Long = 0, _
  474.         Optional ByVal lDestTop As Long = 0, _
  475.         Optional ByVal lDestWidth As Long = -1, _
  476.         Optional ByVal lDestHeight As Long = -1, _
  477.         Optional ByVal lSrcLeft As Long = 0, _
  478.         Optional ByVal lSrcTop As Long = 0, _
  479.         Optional ByVal lConstantAlpha As Byte = 255 _
  480.     )
  481.    If (lDestWidth < 0) Then lDestWidth = m_tBI.bmiHeader.biWidth
  482.    If (lDestHeight < 0) Then lDestHeight = m_tBI.bmiHeader.biHeight
  483.    
  484.    Dim lBlend As Long
  485.    Dim bf As BLENDFUNCTION
  486.    bf.BlendOp = AC_SRC_OVER
  487.    bf.BlendFlags = 0
  488.    bf.SourceConstantAlpha = lConstantAlpha
  489.    bf.AlphaFormat = AC_SRC_ALPHA
  490.    CopyMemory lBlend, bf, 4
  491.    
  492.    Dim lR As Long
  493.    lR = AlphaBlend( _
  494.       lHDC, _
  495.       lDestLeft, lDestTop, lDestWidth, lDestHeight, _
  496.       m_hDC, _
  497.       lSrcLeft, lSrcTop, lDestWidth, lDestHeight, _
  498.       lBlend)
  499.    If (lR = 0) Then
  500.       Debug.Print ApiError(Err.LastDllError)
  501.    End If
  502.  
  503. End Sub
  504. Public Property Get HDC() As Long
  505.     HDC = m_hDC
  506. End Property
  507. Public Property Get hDib() As Long
  508.     hDib = m_hDIb
  509. End Property
  510. Public Property Get DIBSectionBitsPtr() As Long
  511.     DIBSectionBitsPtr = m_lPtr
  512. End Property
  513. Public Sub RandomiseBits( _
  514.         Optional ByVal bGray As Boolean = False _
  515.     )
  516. Dim bDib() As Byte
  517. Dim x As Long, y As Long
  518. Dim lC As Long
  519. Dim tSA As SAFEARRAY2D
  520. Dim xEnd As Long
  521.     
  522.     ' Get the bits in the from DIB section:
  523.     With tSA
  524.         .cbElements = 1
  525.         .cDims = 2
  526.         .Bounds(0).lLbound = 0
  527.         .Bounds(0).cElements = m_tBI.bmiHeader.biHeight
  528.         .Bounds(1).lLbound = 0
  529.         .Bounds(1).cElements = BytesPerScanLine()
  530.         .pvData = m_lPtr
  531.     End With
  532.     CopyMemory ByVal VarPtrArray(bDib()), VarPtr(tSA), 4
  533.  
  534.     ' random:
  535.     Randomize Timer
  536.     
  537.     xEnd = (Width - 1) * 3
  538.     If (bGray) Then
  539.         For y = 0 To m_tBI.bmiHeader.biHeight - 1
  540.             For x = 0 To xEnd Step 3
  541.                 lC = Rnd * 255
  542.                 bDib(x, y) = lC
  543.                 bDib(x + 1, y) = lC
  544.                 bDib(x + 2, y) = lC
  545.             Next x
  546.         Next y
  547.     Else
  548.         For x = 0 To xEnd Step 3
  549.             For y = 0 To m_tBI.bmiHeader.biHeight - 1
  550.                 bDib(x, y) = 0
  551.                 bDib(x + 1, y) = Rnd * 255
  552.                 bDib(x + 2, y) = Rnd * 255
  553.             Next y
  554.         Next x
  555.     End If
  556.     
  557.     ' Clear the temporary array descriptor
  558.     ' (This does not appear to be necessary, but
  559.     ' for safety do it anyway)
  560.     CopyMemory ByVal VarPtrArray(bDib), 0&, 4
  561.     
  562. End Sub
  563.  
  564. Public Sub ClearUp()
  565.     If (m_hDC <> 0) Then
  566.         If (m_hDIb <> 0) Then
  567.             SelectObject m_hDC, m_hBmpOld
  568.             DeleteObject m_hDIb
  569.         End If
  570.         DeleteObject m_hDC
  571.     End If
  572.     m_hDC = 0: m_hDIb = 0: m_hBmpOld = 0: m_lPtr = 0
  573.     If Not (m_hDD = 0) Then
  574.       DrawDibClose m_hDD
  575.       m_hDD = 0
  576.    End If
  577. End Sub
  578.  
  579. Public Function Resample( _
  580.         ByVal lNewWidth As Long, _
  581.         Optional ByVal lNewHeight As Long = -1 _
  582.     ) As cDIBSection
  583.    
  584.    If (lNewHeight = -1) Then
  585.       lNewHeight = (Height * lNewWidth) \ Width
  586.    End If
  587.    
  588.    Dim cDib As cDIBSection
  589.    Set cDib = New cDIBSection
  590.    If cDib.Create(lNewWidth, lNewHeight) Then
  591.       If (lNewWidth <> m_tBI.bmiHeader.biWidth) Or _
  592.          (lNewHeight <> m_tBI.bmiHeader.biHeight) Then
  593.          ' Change in size, do resample:
  594.          ResampleDib cDib
  595.       Else
  596.          ' No size change so just return a copy:
  597.          cDib.LoadPictureBlt m_hDC
  598.       End If
  599.       Set Resample = cDib
  600.    End If
  601.    
  602. End Function
  603.  
  604. Private Function ResampleDib(ByRef cDibTo As cDIBSection) As Boolean
  605. Dim bDibFrom() As Byte
  606. Dim bDibTo() As Byte
  607. Dim tSAFrom As SAFEARRAY2D
  608. Dim tSATo As SAFEARRAY2D
  609.  
  610.     ' Get the bits in the from DIB section:
  611.     With tSAFrom
  612.         .cbElements = 1
  613.         .cDims = 2
  614.         .Bounds(0).lLbound = 0
  615.         .Bounds(0).cElements = m_tBI.bmiHeader.biHeight
  616.         .Bounds(1).lLbound = 0
  617.         .Bounds(1).cElements = BytesPerScanLine()
  618.         .pvData = m_lPtr
  619.     End With
  620.     CopyMemory ByVal VarPtrArray(bDibFrom()), VarPtr(tSAFrom), 4
  621.  
  622.     ' Get the bits in the to DIB section:
  623.     With tSATo
  624.         .cbElements = 1
  625.         .cDims = 2
  626.         .Bounds(0).lLbound = 0
  627.         .Bounds(0).cElements = cDibTo.Height
  628.         .Bounds(1).lLbound = 0
  629.         .Bounds(1).cElements = cDibTo.BytesPerScanLine()
  630.         .pvData = cDibTo.DIBSectionBitsPtr
  631.     End With
  632.     CopyMemory ByVal VarPtrArray(bDibTo()), VarPtr(tSATo), 4
  633.  
  634. Dim xScale As Single
  635. Dim yScale As Single
  636.  
  637. Dim x As Long, y As Long, xEnd As Long, xOut As Long
  638.  
  639. Dim fX As Single, fY As Single
  640. Dim ifY As Long, ifX As Long
  641. Dim dX As Single, dy As Single
  642. Dim r As Long, r1 As Single, r2 As Single, r3 As Single, r4 As Single
  643. Dim g As Long, g1 As Single, g2 As Single, g3 As Single, g4 As Single
  644. Dim b As Long, b1 As Single, b2 As Single, b3 As Single, b4 As Single
  645. Dim ir1 As Long, ig1 As Long, ib1 As Long
  646. Dim ir2 As Long, ig2 As Long, ib2 As Long
  647.  
  648.     xScale = (Width - 1) / cDibTo.Width
  649.     yScale = (Height - 1) / cDibTo.Height
  650.     
  651.     xEnd = cDibTo.Width - 1
  652.         
  653.     For y = 0 To cDibTo.Height - 1
  654.         
  655.         fY = y * yScale
  656.         ifY = Int(fY)
  657.         dy = fY - ifY
  658.         
  659.         For x = 0 To xEnd
  660.             fX = x * xScale
  661.             ifX = Int(fX)
  662.             dX = fX - ifX
  663.             
  664.             ifX = ifX * 3
  665.             ' Interpolate using the four nearest pixels in the source
  666.             b1 = bDibFrom(ifX, ifY)
  667.             g1 = bDibFrom(ifX + 1, ifY)
  668.             r1 = bDibFrom(ifX + 2, ifY)
  669.             b2 = bDibFrom(ifX + 3, ifY)
  670.             g2 = bDibFrom(ifX + 4, ifY)
  671.             r2 = bDibFrom(ifX + 5, ifY)
  672.             b3 = bDibFrom(ifX, ifY + 1)
  673.             g3 = bDibFrom(ifX + 1, ifY + 1)
  674.             r3 = bDibFrom(ifX + 2, ifY + 1)
  675.             b4 = bDibFrom(ifX + 3, ifY + 1): g4 = bDibFrom(ifX + 4, ifY + 1):
  676.              r4 = bDibFrom(ifX + 5, ifY + 1)
  677.             
  678.             ' Interplate in x direction:
  679.             ir1 = r1 * (1 - dy) + r3 * dy
  680.             ig1 = g1 * (1 - dy) + g3 * dy
  681.             ib1 = b1 * (1 - dy) + b3 * dy
  682.             ir2 = r2 * (1 - dy) + r4 * dy
  683.             ig2 = g2 * (1 - dy) + g4 * dy
  684.             ib2 = b2 * (1 - dy) + b4 * dy
  685.             ' Interpolate in y:
  686.             r = ir1 * (1 - dX) + ir2 * dX
  687.             g = ig1 * (1 - dX) + ig2 * dX
  688.             b = ib1 * (1 - dX) + ib2 * dX
  689.             
  690.             ' Set output:
  691.             If (r < 0) Then r = 0
  692.             If (r > 255) Then r = 255
  693.             If (g < 0) Then g = 0
  694.             If (g > 255) Then g = 255
  695.             If (b < 0) Then b = 0
  696.             If (b > 255) Then
  697.                 b = 255
  698.             End If
  699.             xOut = x * 3
  700.             bDibTo(xOut, y) = b
  701.             bDibTo(xOut + 1, y) = g
  702.             bDibTo(xOut + 2, y) = r
  703.             
  704.         Next x
  705.         
  706.     Next y
  707.  
  708.     ' Clear the temporary array descriptor
  709.     ' (This does not appear to be necessary, but
  710.     ' for safety do it anyway)
  711.     CopyMemory ByVal VarPtrArray(bDibFrom), 0&, 4
  712.     CopyMemory ByVal VarPtrArray(bDibTo), 0&, 4
  713.  
  714.  
  715. End Function
  716.  
  717. Private Sub Class_Terminate()
  718.     ClearUp
  719. End Sub
  720.  
  721.  
  722.