Te envio un m�dulo con dos funciones que creo que son utiles.
La primera es para crear objetos StdPicture a partir de handles de iconos, bitmaps o metafiles.
La segunda crea iconos (en objetos StdPicture) a partir de bitmaps en objetos StdPicture.
El codigo esta bastante comentado. La primera funcion la he sacado del Knowledge Base de Microsoft y la segunda esta hecha 100% por mi.


Eduardo.


Revisi�n del 10/02/1999:

He separado las distintas conversiones en diferentes procedimientos para hacer mas claro el c�digo. He tambi�n agregado un nuevo parametro MaskColor para especificar el color que sera usado como transparente por el icono.
He intentado hacer que el subprocedimiento pvWMFaICO funcione, pero no he tenido exito con las funciones para metafiles. Si alguien sabe o pudo usarlas me gustaria que me pasaran el codigo la manera.
Eduardo

Actualizacion del 05/02/1999:

Corregi algunos errores como que si no se podia crear el objeto el handle del icono quedaba en memoria.
A�ad� soporte para iconos. Si la funcion recibe un icono devuelve un nuevo icono con el tama�o especificado en la funcion.
En cuanto a esto ultimo si intentan grabar con SavePicture un icono de tama�o diferente a 32x32 la transparencia no es grabada correctamente. No es problema del codigo. Supongo que es un bug en la function SavePicture o esta no soporta iconos que no sean 32x32, ya que esos son los unicos que VB usa.

Eduardo.

El c�digo:

Attribute VB_Name = "mdlPictureAIcono"
Option Explicit

Public Enum ModosDeStretch
    BlackOnWhite = 1
    WhiteOnBlack = 2
    ColorOnColor = 3
    Halftone = 4
    Desconocida = 5
End Enum

Private Type PICTDESC
    cbSizeOfStruct As Long
    picType As Long
    hgdiObj As Long
    hPalOrXYExt As Long
End Type

Private Type IID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7)  As Byte
End Type

Private Declare Sub OleCreatePictureIndirect Lib "oleaut32.dll" (lpPictDesc As PICTDESC, riid As IID, ByVal fOwn As Boolean, lplpvObj As Object)
    
Private Type pvICONINFO
    fIcon As Long
    xHotspot As Long
    yHotspot As Long
    hbmMask As Long
    hbmColor As Long
End Type

Private Type pvRECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Declare Function CreateIconIndirect Lib "user32" (piconinfo As pvICONINFO) As Long
Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
Private Declare Function DrawIconEx Lib "user32" (ByVal hdc As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long
Private Declare Function GetIconInfo Lib "user32" (ByVal hIcon As Long, piconinfo As pvICONINFO) As Long

Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long

Private Declare Function SetStretchBltMode Lib "gdi32" (ByVal hdc As Long, ByVal nStretchMode As Long) As Long
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
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 CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long

Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lppvRECT As pvRECT, ByVal hBrush As Long) As Long

Private Declare Function SelectPalette Lib "gdi32" (ByVal hdc As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long
Private Declare Function RealizePalette Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateHalftonePalette Lib "gdi32" (ByVal hdc As Long) As Long

Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function OleTranslateColor Lib "oleaut32.dll" (ByVal lOleColor As Long, ByVal lHPalette As Long, lColorRef As Long) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal Color As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal Color As Long) As Long

Const DI_MASK = &H1

Const DI_IMAGE = &H2


'---------------------------------------------------------------------------
' GetIcon: devuelve un icono pasado cualquier clase de objeto Picture.
'
' Parametros:
'	Bitmap: el objeto Picture a convertir en ICO
'   [IconCX]: el ancho del icono a crear
'   [IconCY]: el alto del icono a crear
'   [ModoDeStretch]: la manera en que windows cambiara el tama�o de
'                    la imagen
'	[CrearCursor]: crea un cursor en lugar de un icono
'   [MaskColor]: especifica el color que se usara para dar transparencia al
'                icono. Solo se usa si el objeto original es un mapa de bits.
'---------------------------------------------------------------------------
Public Function GetIcon(ByVal Bitmap As IPicture, Optional ByVal IconCX As Long, Optional ByVal IconCY As Long, Optional ModoDeStretch As ModosDeStretch = Halftone, Optional CrearCursor As Boolean = False, Optional MaskColor As OLE_COLOR = -1) As StdPicture
Dim hIcon As Long, IconPict As StdPicture
Dim ScreenDC As Long, BitmapDC As Long
Dim hMask As Long, hImagen As Long
Dim hIcn As Long, II As pvICONINFO

    On Error Resume Next

    ' Si no se indica un tama_o de icono
    ' se crea uno de 32x32
    
    If IconCX = 0 Then IconCX = 32
    If IconCY = 0 Then IconCY = 32
    
    ScreenDC = GetWindowDC(0&)
    BitmapDC = CreateCompatibleDC(ScreenDC)
    
    hImagen = CreateCompatibleBitmap(ScreenDC, IconCX, IconCY)
    hMask = CreateBitmap(IconCX, IconCY, 1, 1, ByVal 0&)
    
    If Bitmap Is Nothing Then
         
        pvIconoVacio IconCX, IconCY, hImagen, hMask, BitmapDC
    
    ElseIf Bitmap.Handle = 0 Then
        
        pvIconoVacio IconCX, IconCY, hImagen, hMask, BitmapDC
        
    ElseIf Bitmap.Type = vbPicTypeEMetafile Or Bitmap.Type = vbPicTypeMetafile Then
    
        pvWMFaICO IconCX, IconCY, hImagen, hMask, BitmapDC
    
    ElseIf Bitmap.Type = vbPicTypeIcon Then
        
        pvResizeIcon Bitmap, IconCX, IconCY, hImagen, hMask, BitmapDC
        
    Else
                
        pvBMPaICO Bitmap, IconCX, IconCY, hImagen, hMask, BitmapDC, ScreenDC, MaskColor, ModoDeStretch
        
    End If
    
    DeleteDC BitmapDC
    ReleaseDC 0&, ScreenDC
    
    II.fIcon = CrearCursor
    II.hbmColor = hImagen
    II.hbmMask = hMask
    
    hIcon = CreateIconIndirect(II)

    
    Set IconPict = HandleToPicture(hIcon, vbPicTypeIcon)
     
    If IconPict Is Nothing Then
        
        DeleteObject hIcn
        Set GetIcon = Nothing
        
    Else
        
        Set GetIcon = IconPict
        
    End If
    
     
End Function

Private Sub pvBMPaICO(Bitmap As IPicture, ByVal Ancho As Long, ByVal Alto As Long, ByVal hImagen As Long, ByVal hMask As Long, ByVal hdc As Long, ByVal ScrDC As Long, ByVal MaskColor As Long, ByVal ModoDeStretch As Byte)
Dim R As pvRECT, hBr As Long, MskClr As Long
Dim hOldPal As Long, hDC_Bitmap As Long, hDC_Copia As Long
Dim TmpBMP As Long

    R.Bottom = Alto
    R.Right = Ancho
    
    ' Creo un segudo DC para usar
    ' en caso de que la imagen
    ' no este seleccionada en uno
    
    hDC_Bitmap = CreateCompatibleDC(ScrDC)
    
    SetStretchBltMode hdc, ModoDeStretch
            
    ' Dibujo la mascara
    
    If MaskColor = -1 Then    ' No hay transparencia
        
        ' Selecciono la mascara...
        SelectObject hdc, hMask
        
        ' ... y la lleno con negro (opaco)
        hBr = CreateSolidBrush(&H0)
        FillRect hdc, R, hBr
        DeleteObject hBr
    
        ' Selecciono la imagen
        SelectObject hdc, hImagen
    
        ' y pinto el bitmap
        If Bitmap.CurDC = 0 Then
    
            SelectObject hDC_Bitmap, Bitmap.Handle
            
            StretchBlt hdc, 0, 0, Ancho, Alto, hDC_Bitmap, 0, 0, Bitmap.Width / 26.45, Bitmap.Height / 26.45, vbSrcCopy
            
        Else
        
            StretchBlt hdc, 0, 0, Ancho, Alto, Bitmap.CurDC, 0, 0, Bitmap.Width / 26.45, Bitmap.Height / 26.45, vbSrcCopy
            
        End If
               
    Else

        ' Creo un DC y un bitmap para
        ' copiar la imagen. Esto lo
        ' debo hacer porque si el bitmap
        ' es DIB no pasa a B&N usando
        ' los colores de fondo y texto.
        
        hDC_Copia = CreateCompatibleDC(ScrDC)
        
        SetStretchBltMode hDC_Copia, ModoDeStretch
        
        TmpBMP = CreateCompatibleBitmap(ScrDC, Ancho, Alto)
                
        ' Hago la copia del bitmap
        SelectObject hDC_Copia, TmpBMP
        
        If Bitmap.CurDC = 0 Then
            
            SelectObject hDC_Bitmap, Bitmap.Handle
            StretchBlt hDC_Copia, 0, 0, Ancho, Alto, hDC_Bitmap, 0, 0, Bitmap.Width / 26.45, Bitmap.Height / 26.45, vbSrcCopy
            
        Else
            
            StretchBlt hDC_Copia, 0, 0, Ancho, Alto, Bitmap.CurDC, 0, 0, Bitmap.Width / 26.45, Bitmap.Height / 26.45, vbSrcCopy
            
        End If
              
        ' De ahora en mas utilizo la copia
        ' de la que ya a sido modificado su
        ' tama~o
              
        ' ---- Creo la mascara -----
        
        ' Selecciono la mascara en el DC
        SelectObject hdc, hMask
        
        ' Selecciona la paleta del bitmap
        hOldPal = SelectPalette(hdc, Bitmap.hPal, True)
        RealizePalette hdc
        
        ' Paso el OLE_COLOR a clrref
        OleTranslateColor MaskColor, Bitmap.hPal, MskClr
        
        ' Seteo el color de fondo con
        ' el color de mascara.
        SetBkColor hDC_Copia, MskClr
        SetTextColor hDC_Copia, vbWhite
        
        ' Al copiar windows transforma en blanco
        ' todos los pixel con el color de fondo
        ' y en negro el resto
        BitBlt hdc, 0, 0, Ancho, Alto, hDC_Copia, 0, 0, vbSrcCopy
          
        SelectPalette hdc, hOldPal, True
        
        SelectObject hdc, hImagen
        SelectObject hDC_Copia, hMask
        SelectObject hDC_Bitmap, TmpBMP
        
        hBr = CreateSolidBrush(&H0)
        FillRect hdc, R, hBr
        DeleteObject hBr
        
        ' Copio la mascara y luego la imagen
        BitBlt hdc, 0, 0, Ancho, Alto, hDC_Copia, 0, 0, vbNotSrcCopy
        BitBlt hdc, 0, 0, Ancho, Alto, hDC_Bitmap, 0, 0, vbSrcAnd
            
        SelectObject hDC_Bitmap, 0&
        SelectObject hDC_Copia, 0&
        SelectObject hdc, 0&
        
        DeleteObject TmpBMP
        DeleteDC hDC_Copia
        
    End If
    
    DeleteDC hDC_Bitmap
    
End Sub

Private Sub pvIconoVacio(ByVal Ancho As Long, ByVal Alto As Long, ByVal hImagen As Long, ByVal hMask As Long, ByVal hdc As Long)
Dim R As pvRECT, hBr As Long
    
    R.Right = Ancho
    R.Bottom = Alto
    
    ' Dibujo la mascara
    SelectObject hdc, hMask
    
    hBr = CreateSolidBrush(&HFFFFFF)
    FillRect hdc, R, hBr
    DeleteObject hBr
    
    ' Dibujo la imagen
    SelectObject hdc, hImagen
    
    hBr = CreateSolidBrush(&H0)
    FillRect hdc, R, hBr
    DeleteObject hBr
    
    SelectObject hdc, 0&
        
End Sub

Private Sub pvWMFaICO(ByVal Ancho As Long, ByVal Alto As Long, ByVal hImagen As Long, ByVal hMask As Long, ByVal hdc As Long)
        
    ' Aqui deberia pasarse de WMF a ICO
    ' pero todavia no he podido hacerlo.
        
    pvIconoVacio Ancho, Alto, hImagen, hMask, hdc
        
End Sub

Private Sub pvResizeIcon(Icono As StdPicture, ByVal Ancho As Long, ByVal Alto As Long, ByVal hImagen As Long, ByVal hMask As Long, ByVal hdc As Long)

    ' Dibujo la mascara
    SelectObject hdc, hMask
    DrawIconEx hdc, 0, 0, Icono.Handle, Ancho, Alto, 0, 0, DI_MASK
    
    ' Dibujo la imagen
    SelectObject hdc, hImagen
    DrawIconEx hdc, 0, 0, Icono.Handle, Ancho, Alto, 0, 0, DI_IMAGE
    
    SelectObject hdc, 0&
    
End Sub

'---------------------------------------------------------------------------
' HandleToPicture: Crea un objeto StdPicture dado un handle de bitmap, icono
'                  o metafile.
'---------------------------------------------------------------------------
Public Function HandleToPicture(ByVal hGDIHandle As Long, ByVal ObjectType As PictureTypeConstants, Optional ByVal hPal As Long = 0) As StdPicture
Dim ipic As IPicture, picdes As PICTDESC, iidIPicture As IID
    
    ' Fill picture description
    picdes.cbSizeOfStruct = Len(picdes)
    picdes.picType = ObjectType
    picdes.hgdiObj = hGDIHandle
    picdes.hPalOrXYExt = hPal
    
    ' IPictureDisp {7BF80981-BF32-101A-8BBB-00AA00300CAB}
    iidIPicture.Data1 = &H7BF80981

    iidIPicture.Data2 = &HBF32

    iidIPicture.Data3 = &H101A

    iidIPicture.Data4(0) = &H8B

    iidIPicture.Data4(1) = &HBB

    iidIPicture.Data4(2) = &H0

    iidIPicture.Data4(3) = &HAA

    iidIPicture.Data4(4) = &H0

    iidIPicture.Data4(5) = &H30

    iidIPicture.Data4(6) = &HC

    iidIPicture.Data4(7) = &HAB

    
    ' Crea el objeto con el handle
    OleCreatePictureIndirect picdes, iidIPicture, True, ipic
    
    Set HandleToPicture = ipic
        
End Function