[Sample code] Get Strng Memory from dib (VBA, VB6)

2014-04-30
2014-05-01
  • Thanks for your incredible DLL. It works fine from VBA.
    This is a sample code, simple and easy to use the library, when you working without saving to disk
    From my point of view, the samples included in Wrapper dir are really complicated

    
    :::VB6, VBA
    Option Explicit
    'You need also the DLL Declarations
    'API Declaration (ByRef is dangerous but more flexible)
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    'input: a valid dib&, FIF format
    'return: string (image data)
    Private Function szMemDib$(dib&, FIF As FREE_IMAGE_FORMAT, Optional QUALITY&)
    Const JPEG_QUALITYSUPERB& = &H80
    On Local Error GoTo ErrszMemDib
    Dim stream&, lBuffer&, lLen&, szBuffer$
        'if JPG and no quality specified, use extra quality
        If (FIF = FIF_JPEG) And (QUALITY = 0) Then QUALITY& = JPEG_QUALITYSUPERB&
        'prepare memory stream
        stream& = FreeImage_OpenMemory()
        'save dib to an stream
        If FreeImage_SaveToMemory(FIF, dib, stream, QUALITY&) Then
            'read the memory and get the length
            Call FreeImage_AcquireMemory(stream&, lBuffer&, lLen&)
            If lLen& > 0 Then
                'prepare buffer
                szBuffer$ = Space(lLen&)
                'copy pointer to buffer
                Call CopyMemory(ByVal szBuffer$, ByVal lBuffer&, lLen&)
                szMemDib$ = szBuffer$
            End If
        End If
        'unload the stream
        Call FreeImage_CloseMemory(stream&)
    Exit Function
    'control de errores
    ErrszMemDib:
        Select Case MsgBox(Err.Description & ": " & Err.Source, vbQuestion Or vbAbortRetryIgnore, "App.Title")
            Case vbRetry: Resume 0
            Case vbAbort: Exit Function
            Case vbIgnore: Resume Next
        End Select
    End Function
    
    

    And call it like this

    
    :::VB6, VBA
        dib& = FreeImage_Load(FIF_BMP, arcPhoto$)
        If dib& Then
            szParaCod$ = szMemDib$(dib&, FIF)
            Call FreeImage_Unload(dib&)
            If Len(szParaCod$) Then
                If SavePhoto Then
    
                    'just a sample
                    'if you need save to disk use DLL...
                    'iFreeFile& = FreeImage_Save&(FIF, dib&, arcPhoto$)
    
                    'or use native code                
                    iFreeFile& = FreeFile
                    Open arcPhoto$ For Binary Shared As #iFreeFile&
                        Put #iFreeFile&, 1, szParaCod$
                    Close #iFreeFile&
                End If
            End If
        End If
    
     
    Last edit: Míchel Rodríguez 2014-05-14