FAQ's de VB6

[LeandroA]

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(2)

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

' Module : ClassCuadros
' Fecha : 19/06/2006 18:02
' Autor : Leandro Ascierto

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"

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

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...assCuadros.zip

Mis Agradecimiento para todos lo que me ayudaron a terminarla