Este es
un modulo clase que sirve para obtener las distintas figuras que se encuentran
dentro de una imagen, este método es muy usado en varias aplicaciones tales como MSN Messenger, Messenger Yahoo! y otras, cuyo objetivo es acelerar y optimizar el manejo de imágenes
sin tener que usar a menudo el método load Picture que abecés es algo lento,
con esta clase solo vasta con cargar una sola ves la imagen en la memoria para
luego separar cada cuadro y para aplicarlo a sus distintos usos. En el caso de
MSN Messenger las imágenes las guarda dentro del ejecutable como archivo de
recursos y en el de MSN Yahoo! Las guarda dentro de una carpeta junto a la aplicación
para crear sus distintos skin



Esta clase
también es útil a la hora de hacer OCX para
crear controles personalizados y también porque no para hacer algún jueguito
donde se requiere velocidad con el manejo de gráficos



Trabaja
igual que el “PictureClip” (Microsoft PictureClip Controls 6.0) solo que no se
requiere de un OCX y además posee un método Paint que elimina la mascara del
cuadro



Estos
son las clase de gráficos con los que trata el modulo


Fig(1)


Fig(3)

Fig(4)





Solo basta
con indicar el numero de columnas y el numero de fila y luego poder indicar el
grafico en forma secuencial





Como
veran la Fig(1) cuenta con 5 Columnas x 5 Filas si indicamos el numero 7 nos
devolvera el boton de la columna 2 de la fila 2 (osea el signo ? de color verde)





En la
Fig(2) cuenta con 79 columnas x 1 fila
osea que en este caso cada numero del 1 al 79 sera correlativo a su imagen

importante todos graficos dentro de la imagen deven ser del mismo tamaño


ClassCuadros (modulo clase)


Código:
 '----------------------------------------------------------- ----------------------------
' Module : ClassCuadros
' Fecha : 19/06/2006 18:02
' Autor : Leandro Ascierto
'
' Informacion:
'ClassCuadros.Picture = picture que se va a tratar
'ClassCuadros.Columnas = Numero de columnas de la imagen
'ClassCuadros.Filas = Numero de filas de la imagen
'ClassCuadros.CeldasCount = Devuleve la cantidad de celdas
'ClassCuadros.Cuadro(index) Devuleve la imagen selecionada en forma de bitmap
'ClassCuadros.Paint [numero de celda], [hdc del destino], [Left del destino], [Top del destino], [valor True o False sobre la transparencia de la mascara]
 '----------------------------------------------------------- ----------------------------

Option Explicit
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC 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
Private Declare Function TransparentBlt Lib "msimg32.dll" (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 crTransparent As Long) As Boolean
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function CreateIC Lib "GDI32.dll" Alias "CreateICA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, ByRef lpInitData As Any) As Long
Private Declare Function MulDiv Lib "Kernel32.dll" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Private Declare Function GetDeviceCaps Lib "GDI32.dll" (ByVal hDC As Long, ByVal nIndex As Long) As Long

Private Const LOGPIXELSX As Long = 88 ' Logical pixels/inch in X
Private Const LOGPIXELSY As Long = 90 ' Logical pixels/inch in Y


Private Type GUID
 Data1 As Long
 Data2 As Integer
 Data3 As Integer
 Data4(7) As Byte
End Type

Private Type PicBmp
 Size As Long
 Type As Long
 hBmp As Long
 hPal As Long
 Reserved As Long
End Type

Dim m_Columnas As Integer
Dim m_Filas As Integer
Dim m_Picture As Picture
Dim m_DC As Long
Dim m_Left As Long
Dim m_Top As Long
Dim hBmp As Long, PictureDC As Long
Public Property Set Picture(ByVal New_Picture As Picture)
Call Descargar
'combierto a m_picture en un hdc compatible
Set m_Picture = New_Picture
PictureDC = CreateCompatibleDC(0)
Call SelectObject(PictureDC, m_Picture.Handle)
End Property

Public Property Let Columnas(ByVal New_Columnas As Integer)
m_Columnas = New_Columnas
End Property
Public Property Get CeldasCount()
CeldasCount = m_Columnas * m_Filas
End Property
Public Property Let Filas(ByVal New_Filas As Integer)
m_Filas = New_Filas
End Property

Public Property Get Cuadro(ByVal Celda As Integer) As StdPicture
 Set Cuadro = Desglozar(Celda, True)
End Property

Public Function Paint(ByVal Celda As Integer, ByVal SourceHdc As Long, ByVal Left As Single, ByVal Top As Single, ByVal Transparent As Boolean)
m_DC = SourceHdc
m_Left = Left
m_Top = Top
Call Desglozar(Celda, False, Transparent)
End Function

Private Function Desglozar(Celda As Integer, Bitmap As Boolean, Optional Transparent As Boolean) As Picture
Dim Alto As Long, Ancho As Long
Dim X As Integer, Y As Integer, Nro As Single

'obtengo las imagenes en forma lineal
If Celda > (m_Columnas * m_Filas) Then Exit Function
X = Celda Mod m_Columnas
Nro = IIf(X = 0, (Celda / m_Columnas) - 1, (Celda / m_Columnas))
If X = 0 Then X = m_Columnas
Y = IIf(Int(Nro) <= Nro, Int(Nro) + 1, Nro)
'-----
'obtengo las medidas de los cuadros
Ancho = ConvertPixelHimetric(m_Picture.Width, True, True) / m_Columnas
Alto = ConvertPixelHimetric(m_Picture.Height, True, False) / m_Filas
'-----
Dim hDCMemory As Long

DeleteObject (hBmp) 'elimino el arrastre de la buelta anterior
'creo una nueva superficie para depositar la imagen
hDCMemory = CreateCompatibleDC(0)
hBmp = CreateCompatibleBitmap(PictureDC, Ancho, Alto)
Call SelectObject(hDCMemory, hBmp)
'------
'pinto la nueva superficie con la imagen
BitBlt hDCMemory, -Ancho * (X - 1), -Alto * (Y - 1), Ancho * X, Alto * Y, PictureDC, 0, 0, vbSrcCopy

'Si es el metodo "Paint" pinto las superficie sobre el hdc indicado con la mascara transparente o no
If Bitmap = False Then
 If Transparent Then
 TransparentBlt m_DC, m_Left, m_Top, Ancho, Alto, hDCMemory, 0, 0, Ancho, Alto, GetPixel(PictureDC, 0, 0)
 Else
 BitBlt m_DC, m_Left, m_Top, Ancho, Alto, hDCMemory, 0, 0, vbSrcCopy
 End If
 
Else

'Si es el metodo "Picture" combierto la superficie en un bitmap
Dim Pic As PicBmp, IID_IDispatch As GUID

 'Fill GUID info
 With IID_IDispatch
 .Data1 = &H20400
 .Data4(0) = &HC0
 .Data4(7) = &H46
 End With

 'Fill picture info
 With Pic
 .Size = Len(Pic) ' Length of structure
 .Type = vbPicTypeBitmap ' Type of Picture (bitmap)
 .hBmp = hBmp ' Handle to bitmap
 .hPal = m_Picture.hPal ' Handle to palette (may be null)
 End With

 'Create the picture
 Call OleCreatePictureIndirect(Pic, IID_IDispatch, 1, Desglozar)

End If
'Elimino la superficie temporal creada
Call DeleteDC(hDCMemory)
End Function
Private Function ConvertPixelHimetric(ByVal inValue As Long, ByVal ToPix As Boolean, inXAxis As Boolean) As Long
 Dim TempIC As Long, GDCFlag As Long
 'rutina para obtener las medidas de la imagen en Himetric
 Const HimetricInch As Long = 2540
 
 TempIC = CreateIC("DISPLAY", vbNullString, vbNullString, ByVal 0&)
 
 If (TempIC) Then
 If (inXAxis) Then GDCFlag = LOGPIXELSX Else GDCFlag = LOGPIXELSY
 
 If (ToPix) Then
   ConvertPixelHimetric = MulDiv(inValue, GetDeviceCaps(TempIC, GDCFlag), HimetricInch)
 Else
   ConvertPixelHimetric = MulDiv(inValue, HimetricInch, GetDeviceCaps(TempIC, GDCFlag))
 End If
 Call DeleteDC(TempIC)
 End If
End Function

Private Sub Class_Terminate()
Call Descargar
End Sub
Private Sub Descargar()
On Error Resume Next
'elimino todos los objetos creados
Call DeleteObject(hBmp)
Call DeleteObject(m_Picture.Handle)
Call DeleteDC(PictureDC)
Set m_Picture = Nothing
End Sub
Un ejemplo para provar
Guarden la Fig(2) en el disco "C:\" con el nombre "caritas.bmp"
En un formulario:
Código:
Dim Icons As ClassCuadros 'declaro Icons como la clase
Private Sub Form_Load()
Set Icons = New ClassCuadros 'Inicializo
Set Icons.Picture = LoadPicture("C:\caritas.bmp") 'cargo el grafico
Icons.Columnas = 79 'indico las columnas
Icons.Filas = 1 ' indico las filas
Me.AutoRedraw = True 'importante para el metodo paint
'voy a obenter el icono de la columna 51 de la fila 1
Me.Picture = Icons.Cuadro(51) 'devuelve en bitmap
Icons.Paint 51, Me.hDC, 50, 0, True 'pinta sin la mascara
Icons.Paint 51, Me.hDC, 100, 0, False 'pinta con la mascara
End Sub

Private Sub Form_Unload(Cancel As Integer)
setIcons = Nothing 'lo quito de la memoria
End Sub
Parametros de metodo paint
Código:
Objeto.Paint [numero de celda],
[hdc del destino], [Left
del destino], [Top
del destino], [valor True o False sobre la
transparencia de la mascara]
Un ejemplo para descargar
http://ar.geocities.com/leandroascie...uadros/ClassCu adros.zip

Mis Agradecimiento para todos lo que me ayudaron a terminarla




Edited by: Leandro