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 / cTile.cls < prev    next >
Text File  |  2005-04-03  |  7KB  |  217 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 = "cTile"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. '================================================
  15. ' Class:         cTile.cls
  16. ' Author:        Carles P.V.
  17. ' Dependencies:
  18. ' Last revision: 2003.03.28
  19. '================================================
  20.  
  21. Option Explicit
  22.  
  23. '-- API:
  24.  
  25. Private Type BITMAPINFOHEADER
  26.     biSize          As Long
  27.     biWidth         As Long
  28.     biHeight        As Long
  29.     biPlanes        As Integer
  30.     biBitCount      As Integer
  31.     biCompression   As Long
  32.     biSizeImage     As Long
  33.     biXPelsPerMeter As Long
  34.     biYPelsPerMeter As Long
  35.     biClrUsed       As Long
  36.     biClrImportant  As Long
  37. End Type
  38.  
  39. Private Type BITMAP
  40.     bmType       As Long
  41.     bmWidth      As Long
  42.     bmHeight     As Long
  43.     bmWidthBytes As Long
  44.     bmPlanes     As Integer
  45.     bmBitsPixel  As Integer
  46.     bmBits       As Long
  47. End Type
  48.  
  49. Private Type RECT2
  50.     x1 As Long
  51.     y1 As Long
  52.     x2 As Long
  53.     y2 As Long
  54. End Type
  55.  
  56. Private Type POINTAPI
  57.     x As Long
  58.     y As Long
  59. End Type
  60.  
  61. Private Const DIB_RGB_COLORS As Long = 0
  62. Private Const OBJ_BITMAP     As Long = 7
  63.  
  64. Private Const HS_HORIZONTAL  As Long = 0
  65. Private Const HS_VERTICAL    As Long = 1
  66. Private Const HS_FDIAGONAL   As Long = 2
  67. Private Const HS_BDIAGONAL   As Long = 3
  68. Private Const HS_CROSS       As Long = 4
  69. Private Const HS_DIAGCROSS   As Long = 5
  70.  
  71. Private Declare Function OleTranslateColor Lib "olepro32" (ByVal OLE_COLOR As Long, ByVal hPalette As Long, ColorRef As Long) As Long
  72. Private Declare Function CreateDIBPatternBrushPt Lib "gdi32" (lpPackedDIB As Any, ByVal iUsage As Long) As Long
  73. Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
  74. Private Declare Function CreateHatchBrush Lib "gdi32" (ByVal nIndex As Long, ByVal crColor As Long) As Long
  75. Private Declare Function SetBrushOrgEx Lib "gdi32" (ByVal hDC As Long, ByVal nXOrg As Long, ByVal nYOrg As Long, lppt As POINTAPI) As Long
  76. Private Declare Function GetObjectType Lib "gdi32" (ByVal hgdiobj As Long) As Long
  77. Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
  78. Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
  79. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  80. Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
  81. Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
  82. Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFOHEADER, ByVal wUsage As Long) As Long
  83. 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
  84. Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As RECT2, ByVal hBrush As Long) As Long
  85. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDst As Any, lpSrc As Any, ByVal Length As Long)
  86.  
  87. '//
  88.  
  89. '-- Public Enums.:
  90. Public Enum HatchBrushStyleCts
  91.     [brHorizontal] = 0
  92.     [brVertival]
  93.     [brDownwardDiagonal]
  94.     [brUpwardDiagonal]
  95.     [brCross]
  96.     [brDiagonalCross]
  97. End Enum
  98.  
  99. '-- Private Variables:
  100. Private m_hBrush As Long ' Pattern brush
  101.  
  102.  
  103.  
  104. '========================================================================================
  105. ' Class
  106. '========================================================================================
  107.  
  108. Private Sub Class_Initialize()
  109.     m_hBrush = 0
  110. End Sub
  111.  
  112. Private Sub Class_Terminate()
  113.     Call Me.DestroyPattern
  114. End Sub
  115.  
  116.  
  117.  
  118. '========================================================================================
  119. ' Methods
  120. '========================================================================================
  121.  
  122. Public Function CreatePatternFromStdPicture(Image As StdPicture) As Boolean
  123.  
  124.   Dim uBI       As BITMAP
  125.   Dim uBIH      As BITMAPINFOHEADER
  126.   Dim aBuffer() As Byte ' Packed DIB
  127.     
  128.   Dim lhDC      As Long
  129.   Dim lhOldBmp  As Long
  130.     
  131.     If (GetObjectType(Image.handle) = OBJ_BITMAP) Then
  132.     
  133.         '-- Get image info
  134.         Call GetObject(Image.handle, Len(uBI), uBI)
  135.         
  136.         '-- Prepare DIB header and redim. buffer array
  137.         With uBIH
  138.             .biSize = Len(uBIH)
  139.             .biPlanes = 1
  140.             .biBitCount = 24
  141.             .biWidth = uBI.bmWidth
  142.             .biHeight = uBI.bmHeight
  143.             .biSizeImage = ((.biWidth * 3 + 3) And &HFFFFFFFC) * .biHeight
  144.         End With
  145.         ReDim aBuffer(1 To Len(uBIH) + uBIH.biSizeImage)
  146.             
  147.         '-- Create DIB brush
  148.         lhDC = CreateCompatibleDC(0)
  149.         If (lhDC <> 0) Then
  150.             lhOldBmp = SelectObject(lhDC, Image.handle)
  151.                     
  152.             '-- Build packed DIB:
  153.             '-  Merge Header
  154.             Call CopyMemory(aBuffer(1), uBIH, Len(uBIH))
  155.             '-  Get and merge DIB bits
  156.             Call GetDIBits(lhDC, Image.handle, 0, uBI.bmHeight, aBuffer(Len(uBIH) + 1), uBIH, DIB_RGB_COLORS)
  157.             
  158.             Call SelectObject(lhDC, lhOldBmp)
  159.             Call DeleteDC(lhDC)
  160.             
  161.             '-  Create brush from packed DIB
  162.             Call Me.DestroyPattern
  163.             m_hBrush = CreateDIBPatternBrushPt(aBuffer(1), DIB_RGB_COLORS)
  164.         End If
  165.     End If
  166.     
  167.     '-- Success
  168.     CreatePatternFromStdPicture = (m_hBrush <> 0)
  169. End Function
  170.  
  171. Public Function CreatePatternFromHatchBrush(ByVal BrushStyle As HatchBrushStyleCts, ByVal Color As OLE_COLOR) As Boolean
  172.  
  173.     '-- Create brush from system brush
  174.     Call Me.DestroyPattern
  175.     Call OleTranslateColor(Color, 0, Color)
  176.     m_hBrush = CreateHatchBrush(BrushStyle, Color)
  177.     
  178.     '-- Success
  179.     CreatePatternFromHatchBrush = (m_hBrush <> 0)
  180. End Function
  181.  
  182. Public Function CreatePatternFromSolidColor(ByVal Color As OLE_COLOR) As Boolean
  183.  
  184.     '-- Create brush from solid color
  185.     Call Me.DestroyPattern
  186.     Call OleTranslateColor(Color, 0, Color)
  187.     m_hBrush = CreateSolidBrush(Color)
  188.     
  189.     '-- Success
  190.     CreatePatternFromSolidColor = (m_hBrush <> 0)
  191. End Function
  192.  
  193. Public Sub Tile(ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal Width As Long, ByVal Height As Long, Optional ByVal ResetBrushOrigin As Boolean = True)
  194.  
  195.   Dim rTile As RECT2
  196.   Dim ptOrg As POINTAPI
  197.   
  198.     If (m_hBrush <> 0) Then
  199.         '-- Set brush origin
  200.         If (ResetBrushOrigin) Then
  201.             Call SetBrushOrgEx(hDC, x, y, ptOrg)
  202.           Else
  203.             Call SetBrushOrgEx(hDC, 0, 0, ptOrg)
  204.         End If
  205.         '-- Tile image
  206.         Call SetRect(rTile, x, y, x + Width, y + Height)
  207.         Call FillRect(hDC, rTile, m_hBrush)
  208.     End If
  209. End Sub
  210.  
  211. Public Sub DestroyPattern()
  212.     If (m_hBrush <> 0) Then
  213.         Call DeleteObject(m_hBrush)
  214.         m_hBrush = 0
  215.     End If
  216. End Sub
  217.