vb 6.0 convert base64 image data into .bmp image

[rahuls.8333]

Hi guys,

I have requirement to create .bmp or .png or .jpeg image from data received from a source in base64 format. i want to convert this text data(base 64) into a .bmp image file. our application is developed in vb 6.0

kindly help!!!!!

Rahul.

[rahuls.8333]

Hi guys,

I have requirement to create .bmp or .png or .jpeg image from data received from a source in base64 format. i want to convert this text data(base 64) into a .bmp image file. our application is developed in vb 6.0

kindly help!!!!!

Rahul.

use this link for sample base 64 image datahttps://drive.google.com/open?id=1se...ZEOF7RCa3z29nr

[dilettante]

Using WIA 2.0... or you might write more code and do it in GDI+ Flat API calls instead.

[labmany]

This is a sample to convert Base64 into a bitmap.

May I ask what hematology analyzer is this?!


P.S :
* The Base64 Decoding function was freely available on the Internet
** The function for saving byte array into a bitmap was kindly provided by Olaf Schmidt

[wqweto]

@labmany: If you pinched the Decode64 function from VB - Fast Base64 Encoding and Decoding thread why did you choose the slower and more bloated pure VB6 implementation that returns (inconvenient) string that has to be treated w/ StrConv before saving to a binary BMP file?

FYI, here is the shorter (and faster, and LAA) FromBase64Array function from the same thread

' Attribute VB_Name = "mdFromBase64Array"
Option Explicit
 
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
 
Public Function FromBase64Array(sText As String) As Byte()
    Const STR_BASE64_CHARS As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
    Static laPow2(0 To 30) As Long
    Static laTable()       As Long
    Dim baInput()       As Byte
    Dim lIdx            As Long
    Dim lCh             As Long
    Dim baOutput()      As Byte
    Dim lPtr            As Long
    Dim lCarry          As Long
    
    On Error GoTo EH
    '--- init decoding table
    If laPow2(0) = 0 Then
        For lIdx = 0 To UBound(laPow2)
            laPow2(lIdx) = 2 ^ lIdx
        Next
        ReDim laTable(0 To &H3FF) As Long
        For lIdx = 0 To UBound(laTable)
            laTable(lIdx) = -1
        Next
        baInput = StrConv(STR_BASE64_CHARS, vbFromUnicode)
        For lIdx = 0 To UBound(baInput)
            lCh = baInput(lIdx)
            laTable(lCh) = lIdx * laPow2(2)
            laTable(&H100 + lCh) = (lIdx And &H30) \ laPow2(4) Or (lIdx And &HF) * laPow2(12)
            laTable(&H200 + lCh) = (lIdx And &H3) * laPow2(22) Or (lIdx And &H3C) * laPow2(6)
            laTable(&H300 + lCh) = lIdx * laPow2(16)
        Next
    End If
    '--- figure out output size
    baInput = StrConv(Replace(Replace(sText, vbCr, vbNullString), vbLf, vbNullString), vbFromUnicode)
    If laTable(baInput(UBound(baInput))) >= 0 Then
        lIdx = 1
    ElseIf laTable(baInput(UBound(baInput) - 1)) >= 0 Then
        lIdx = 2
    Else
        lIdx = 3
    End If
    ReDim baOutput(0 To (Len(sText) \ 4) * 3 - lIdx) As Byte
    '--- decode loop
    lPtr = VarPtr(baOutput(0))
    For lIdx = 0 To UBound(baInput) - 3 Step 4
        lCh = laTable(baInput(lIdx + 0)) _
            Or laTable(&H100 + baInput(lIdx + 1)) _
            Or laTable(&H200 + baInput(lIdx + 2)) _
            Or laTable(&H300 + baInput(lIdx + 3))
        If lCh < 0 Then
            Exit For
        End If
        Call CopyMemory(ByVal lPtr, lCh, 3)
        lPtr = (lPtr Xor &H80000000) + 3 Xor &H80000000
    Next
    lPtr = UnsignedDiff(VarPtr(baOutput(0)), lPtr)
    '-- handle trailing 4 chars (or input error)
    If lIdx <= UBound(baInput) Then
        lCh = laTable(baInput(lIdx + 0))
        Debug.Assert lCh >= 0 '--- input error
        If lCh < 0 Then
            GoTo QH
        End If
        lCarry = lCh
        lCh = laTable(baInput(lIdx + 1))
        Debug.Assert lCh >= 0 '--- input error
        If lCh < 0 Then
            GoTo QH
        End If
        baOutput(lPtr + 0) = (lCarry Or lCh \ laPow2(6)) And &HFF
        lCarry = lCh * laPow2(2)
        lCh = laTable(baInput(lIdx + 2))
        If lCh < 0 Then
            lPtr = lPtr + 1
            GoTo QH
        End If
        baOutput(lPtr + 1) = (lCarry Or lCh \ laPow2(4)) And &HFF
        lCarry = lCh * laPow2(4)
        lCh = laTable(baInput(lIdx + 3))
        If lCh < 0 Then
            lPtr = lPtr + 2
            GoTo QH
        End If
        Debug.Assert lCh < 0 '--- error in decoding tables
        baOutput(lPtr + 2) = (lCarry Or lCh \ laPow2(2)) And &HFF
        lPtr = lPtr + 3
    End If
QH:
    '--- will redim only on input error
    If UBound(baOutput) <> lPtr - 1 Then
        ReDim Preserve baOutput(0 To lPtr - 1) As Byte
    End If
    FromBase64Array = baOutput
    Exit Function
EH:
    Debug.Print Err.Description
End Function
 
Private Function UnsignedDiff(ByVal lUnsignedPtr1 As Long, ByVal lUnsignedPtr2 As Long) As Long
    '--- note: retval is *signed* offset b/n *unsigned* ptr1 and *unsigned* ptr2 w/o overflow in LARGEADDRESSAWARE processes
    If (lUnsignedPtr1 And &H80000000) <> (lUnsignedPtr2 And &H80000000) Then
        UnsignedDiff = (lUnsignedPtr2 - (lUnsignedPtr1 Xor &H80000000)) Xor &H80000000
    Else
        UnsignedDiff = lUnsignedPtr2 - lUnsignedPtr1
    End If
End Function

And here is the much shorter API based impl w/ a single call to CryptStringToBinary (not twice)

' Attribute VB_Name = "mdApiFromBase64Array"
Option Explicit
 
'--- for CryptStringToBinary
Private Const CRYPT_STRING_BASE64           As Long = 1
 
Private Declare Function CryptStringToBinary Lib "crypt32" Alias "CryptStringToBinaryW" (ByVal pszString As Long, ByVal cchString As Long, ByVal dwFlags As Long, ByVal pbBinary As Long, ByRef pcbBinary As Long, ByRef pdwSkip As Long, ByRef pdwFlags As Long) As Long
 
Public Function ApiFromBase64Array(sText As String) As Byte()
    Dim lSize           As Long
    Dim dwDummy         As Long
    Dim baOutput()      As Byte
    
    lSize = Len(sText) + 1
    ReDim baOutput(0 To lSize - 1) As Byte
    Call CryptStringToBinary(StrPtr(sText), Len(sText), CRYPT_STRING_BASE64, VarPtr(baOutput(0)), lSize, 0, dwDummy)
    If lSize > 0 Then
        ReDim Preserve baOutput(0 To lSize - 1) As Byte
        ApiFromBase64Array = baOutput
    Else
        ApiFromBase64Array = vbNullString
    End If
End Function

cheers,
</wqw>

[labmany]

@labmany: If you pinched the Decode64 function from VB - Fast Base64 Encoding and Decoding thread why did you choose the slower and more bloated pure VB6 implementation that returns (inconvenient) string that has to be treated w/ StrConv before saving to a binary BMP file?

FYI, here is the shorter (and faster, and LAA) FromBase64Array function from the same thread

' Attribute VB_Name = "mdFromBase64Array"
Option Explicit
 
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
 
Public Function FromBase64Array(sText As String) As Byte()
    Const STR_BASE64_CHARS As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
    Static laPow2(0 To 30) As Long
    Static laTable()       As Long
    Dim baInput()       As Byte
    Dim lIdx            As Long
    Dim lCh             As Long
    Dim baOutput()      As Byte
    Dim lPtr            As Long
    Dim lCarry          As Long
    
    On Error GoTo EH
    '--- init decoding table
    If laPow2(0) = 0 Then
        For lIdx = 0 To UBound(laPow2)
            laPow2(lIdx) = 2 ^ lIdx
        Next
        ReDim laTable(0 To &H3FF) As Long
        For lIdx = 0 To UBound(laTable)
            laTable(lIdx) = -1
        Next
        baInput = StrConv(STR_BASE64_CHARS, vbFromUnicode)
        For lIdx = 0 To UBound(baInput)
            lCh = baInput(lIdx)
            laTable(lCh) = lIdx * laPow2(2)
            laTable(&H100 + lCh) = (lIdx And &H30) \ laPow2(4) Or (lIdx And &HF) * laPow2(12)
            laTable(&H200 + lCh) = (lIdx And &H3) * laPow2(22) Or (lIdx And &H3C) * laPow2(6)
            laTable(&H300 + lCh) = lIdx * laPow2(16)
        Next
    End If
    '--- figure out output size
    baInput = StrConv(Replace(Replace(sText, vbCr, vbNullString), vbLf, vbNullString), vbFromUnicode)
    If laTable(baInput(UBound(baInput))) >= 0 Then
        lIdx = 1
    ElseIf laTable(baInput(UBound(baInput) - 1)) >= 0 Then
        lIdx = 2
    Else
        lIdx = 3
    End If
    ReDim baOutput(0 To (Len(sText) \ 4) * 3 - lIdx) As Byte
    '--- decode loop
    lPtr = VarPtr(baOutput(0))
    For lIdx = 0 To UBound(baInput) - 3 Step 4
        lCh = laTable(baInput(lIdx + 0)) _
            Or laTable(&H100 + baInput(lIdx + 1)) _
            Or laTable(&H200 + baInput(lIdx + 2)) _
            Or laTable(&H300 + baInput(lIdx + 3))
        If lCh < 0 Then
            Exit For
        End If
        Call CopyMemory(ByVal lPtr, lCh, 3)
        lPtr = (lPtr Xor &H80000000) + 3 Xor &H80000000
    Next
    lPtr = UnsignedDiff(VarPtr(baOutput(0)), lPtr)
    '-- handle trailing 4 chars (or input error)
    If lIdx <= UBound(baInput) Then
        lCh = laTable(baInput(lIdx + 0))
        Debug.Assert lCh >= 0 '--- input error
        If lCh < 0 Then
            GoTo QH
        End If
        lCarry = lCh
        lCh = laTable(baInput(lIdx + 1))
        Debug.Assert lCh >= 0 '--- input error
        If lCh < 0 Then
            GoTo QH
        End If
        baOutput(lPtr + 0) = (lCarry Or lCh \ laPow2(6)) And &HFF
        lCarry = lCh * laPow2(2)
        lCh = laTable(baInput(lIdx + 2))
        If lCh < 0 Then
            lPtr = lPtr + 1
            GoTo QH
        End If
        baOutput(lPtr + 1) = (lCarry Or lCh \ laPow2(4)) And &HFF
        lCarry = lCh * laPow2(4)
        lCh = laTable(baInput(lIdx + 3))
        If lCh < 0 Then
            lPtr = lPtr + 2
            GoTo QH
        End If
        Debug.Assert lCh < 0 '--- error in decoding tables
        baOutput(lPtr + 2) = (lCarry Or lCh \ laPow2(2)) And &HFF
        lPtr = lPtr + 3
    End If
QH:
    '--- will redim only on input error
    If UBound(baOutput) <> lPtr - 1 Then
        ReDim Preserve baOutput(0 To lPtr - 1) As Byte
    End If
    FromBase64Array = baOutput
    Exit Function
EH:
    Debug.Print Err.Description
End Function
 
Private Function UnsignedDiff(ByVal lUnsignedPtr1 As Long, ByVal lUnsignedPtr2 As Long) As Long
    '--- note: retval is *signed* offset b/n *unsigned* ptr1 and *unsigned* ptr2 w/o overflow in LARGEADDRESSAWARE processes
    If (lUnsignedPtr1 And &H80000000) <> (lUnsignedPtr2 And &H80000000) Then
        UnsignedDiff = (lUnsignedPtr2 - (lUnsignedPtr1 Xor &H80000000)) Xor &H80000000
    Else
        UnsignedDiff = lUnsignedPtr2 - lUnsignedPtr1
    End If
End Function

And here is the much shorter API based impl w/ a single call to CryptStringToBinary (not twice)

' Attribute VB_Name = "mdApiFromBase64Array"
Option Explicit
 
'--- for CryptStringToBinary
Private Const CRYPT_STRING_BASE64           As Long = 1
 
Private Declare Function CryptStringToBinary Lib "crypt32" Alias "CryptStringToBinaryW" (ByVal pszString As Long, ByVal cchString As Long, ByVal dwFlags As Long, ByVal pbBinary As Long, ByRef pcbBinary As Long, ByRef pdwSkip As Long, ByRef pdwFlags As Long) As Long
 
Public Function ApiFromBase64Array(sText As String) As Byte()
    Dim lSize           As Long
    Dim dwDummy         As Long
    Dim baOutput()      As Byte
    
    lSize = Len(sText) + 1
    ReDim baOutput(0 To lSize - 1) As Byte
    Call CryptStringToBinary(StrPtr(sText), Len(sText), CRYPT_STRING_BASE64, VarPtr(baOutput(0)), lSize, 0, dwDummy)
    If lSize > 0 Then
        ReDim Preserve baOutput(0 To lSize - 1) As Byte
        ApiFromBase64Array = baOutput
    Else
        ApiFromBase64Array = vbNullString
    End If
End Function

cheers,
</wqw>

Thanks for the tip, I'll use that

[labmany]

Sorry, double post!

[Schmidt]

FWIW, here a Variant for RC5-Users:

The code should work when pasted into on an empty Form (as long as a vbRichClient5-reference was checked into the Project) -
then it downloads a Base64-Image-Text-(String) via Web-Request - and decodes+visualizes in the Form.Picture directly.

Option Explicit

Private WithEvents DL As cDownloads

Private Sub Form_Load()
  Set DL = New_c.Downloads
      DL.Download "http://vbRichClient.com/Downloads/Base64Image.txt"
End Sub

Private Sub DL_DownloadComplete(DownloadObj As cDownload, ByVal ErrNum&, ErrString As String)
  If ErrNum Then MsgBox ErrString Else DecodeB64Img Cairo.ToBSTR(DownloadObj.GetContentData)
End Sub

Private Sub DecodeB64Img(sB64 As String)
  Dim B() As Byte: B = New_c.Crypt.Base64Dec(sB64, True)'decode sB64
  
  With Cairo.ImageList.AddImage("", B) '<-can load most Img-B-Arrays

    Set Picture = .Picture 'convert the Srf-content to VB-StdPicture
   '.WriteContentToPngFile "c:\temp\B64Dec.png" 'or write it to disk

  End With
End Sub

HTH

Olaf

[dilettante]

Since the raw image is already in BMP format you can just convert Base64 text to bytes and write them to a file if compression isn't important.

[dilettante]

References to:

Microsoft ActiveX Data Objects 2.5 Library
Microsoft CDO for Windows 2000 Library

    With New CDO.Message
        With .BodyPart
            .ContentMediaType = "image/bmp"
            .ContentTransferEncoding = "base64"
            With .GetEncodedContentStream
                .LoadFromFile "image data base 64.txt"
                .Flush
            End With
            With .GetDecodedContentStream
                .SaveToFile "image.bmp", adSaveCreateOverWrite
            End With
        End With
    End With

[rahuls.8333]

This is a sample to convert Base64 into a bitmap.

May I ask what hematology analyzer is this?!


P.S :
* The Base64 Decoding function was freely available on the Internet
** The function for saving byte array into a bitmap was kindly provided by Olaf Schmidt

Thanks for the help @labmany. i will try this code.The analyzer is Erba H360

[LaVolpe]

I have requirement to create .bmp or .png or .jpeg image from data received from a source in base64 format. i want to convert this text data(base 64) into a .bmp image file. our application is developed in vb 6.0

Rahul.

FYI: Converting PNG to Bitmap may lose any PNG transparency depending on bitmap format saved to. Even if saved to a bitmap format that will honor transparency (2 formats), any app reading the file may not properly display transparency since transparency in bitmaps isn't typical.

[dilettante]

The raw data is a simple 24bpp BMP.

[LaVolpe]

The raw data is a simple 24bpp BMP.

That sample, but the original post can be interpreted as PNG & JPG sources (or destinations?)

[dilettante]

I suppose, but then it may as likely contain something nasty (PCX, TARGA?). Or even a raw bitmap's bits. Or some vector format, metafile format, or who knows what?

Here's something else you probably won't see many places:

    Dim Size As Long
    Dim RS As ADODB.Recordset
    Dim FMT As StdFormat.StdDataFormat

    With New CDO.Message
        With .BodyPart
            .ContentMediaType = "image/bmp"
            .ContentTransferEncoding = "base64"
            With .GetEncodedContentStream
                .LoadFromFile "image data base 64.txt"
                .Flush
            End With
            With .GetDecodedContentStream
                .SaveToFile "image.bmp", adSaveCreateOverWrite
                'Get a StdPicture through devious means and display it:
                Size = .Size
                Set RS = New ADODB.Recordset
                With RS
                    .Fields.Append "Picture", adLongVarBinary, Size
                    .Open
                    .AddNew
                End With
                RS.Fields("Picture").Value = .Read(adReadAll)
                Set FMT = New StdFormat.StdDataFormat
                FMT.Type = fmtPicture
                With RS
                    Set .Fields("Picture").DataFormat = FMT
                    Set Picture = .Fields("Picture").Value
                    .Close
                End With
            End With
        End With
    End With

I suspect it will handle any image file format that VB's LoadPicture() can since it returns a Picture type object (a StdPicture's IPictureDisp interface?).

[rahuls.8333]

References to:

Microsoft ActiveX Data Objects 2.5 Library
Microsoft CDO for Windows 2000 Library

    With New CDO.Message
        With .BodyPart
            .ContentMediaType = "image/bmp"
            .ContentTransferEncoding = "base64"
            With .GetEncodedContentStream
                .LoadFromFile "image data base 64.txt"
                .Flush
            End With
            With .GetDecodedContentStream
                .SaveToFile "image.bmp", adSaveCreateOverWrite
            End With
        End With
    End With

works perfectly fine for my requirement!!!!, thanx a ton