[Webinar] Streamline your web hosting managementRegister Today


Saving a transparent PNG & GIF from EMF or BitBlt

Posted on 2008-02-01
Medium Priority
Last Modified: 2013-12-03
I need to save a transparent PNG and GIF form another image.
The source image could be an EMF or, eventually, a bitmap composed using bitblt and masked it.
Question by:gkat
  • 9
  • 4

Expert Comment

ID: 20802189

Author Comment

ID: 20813589
Thanks a lot.
But actually I need to make a transparent file from an opaque bitmap. The process is:
- open a bitmap
- replace pixels from some rgb color to make a transparency
- save it as GIF or PNG

Other option is to make the GIF/PNG from EMF that is allready a transparent metafile.

I need to test the GFL SDK, may this will work...
The new generation of project management tools

With monday.com’s project management tool, you can see what everyone on your team is working in a single glance. Its intuitive dashboards are customizable, so you can create systems that work for you.


Expert Comment

ID: 20813630
so you need to apply a mask based on a given RGB value?

I have found this, but not checked it:


Author Comment

ID: 20813771
As I see, it could be a solution. But my vb crashes when i run the sample.
By the way, there is class called cPallete, but i dont know how to use it...

Expert Comment

ID: 20815819
I expect its for 256 colour (color) bitmaps.  They have a table to list the true RGB value for each pixel byte.  (I wrote my own bmp class beffore, but it couldnt deal with transparency or non BMPs).

I will take a look at the project from home later and see what I can do with it.

Expert Comment

ID: 20818568
found a bug, have fixed.

Will post fix, instuctions and sample code shortly.

Accepted Solution

dentab earned 375 total points
ID: 20818617
right, firstly you need all 3 classes in your application.  Assuming in your application directory you have a bmp with a bright-pink colour for transparency (255,0,255 or FF00FF) this is the code to use:

  Dim cGif As GIF
  Set cGif = New GIF
  cGif.SaveGIF LoadPicture(App.Path & "\bmp.bmp"), App.Path & "\gif.gif", 0, True, RGB(255, 0, 255), True
  Set cGif = Nothing

The GIF class however needs fixing.  Use the code in the snippet below to replace the class.
Option Explicit
Private Type RGBTRIPLE
     rgbRed As Byte
     rgbGreen As Byte
     rgbBlue As Byte
End Type
Private Type RGBQUAD
     rgbBlue As Byte
     rgbGreen As Byte
     rgbRed As Byte
     rgbReserved As Byte
End Type
Private Type BITMAPINFOHEADER '40 bytes
     biSize As Long
     biWidth As Long
     biHeight As Long
     biPlanes As Integer
     biBitCount As Integer
     biCompression As Long
     biSizeImage As Long
     biXPelsPerMeter As Long
     biYPelsPerMeter As Long
     biClrUsed As Long
     biClrImportant As Long
End Type
Private Type BITMAPINFO256
     bmiColors(0 To 255) As RGBQUAD
End Type
Private Type BITMAP '14 bytes
   bmType As Long
   bmWidth As Long
   bmHeight As Long
   bmWidthBytes As Long
   bmPlanes As Integer
   bmBitsPixel As Integer
   bmBits As Long
End Type
Private Const BI_RGB = 0&
Private Declare Function CreateDCAsNull Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, lpDeviceName As Any, lpOutput As Any, lpInitData As Any) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, 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 DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO256, ByVal wUsage As Long) As Long
Private Declare Function CreateDIBSection256 Lib "gdi32" Alias "CreateDIBSection" (ByVal hdc As Long, pBitmapInfo As BITMAPINFO256, ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Private Const DIB_RGB_COLORS = 0
Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long
'============================GIF STAFF================
Private Type GifScreenDescriptor
     logical_screen_width As Integer
     logical_screen_height As Integer
     Flags As Byte
     background_color_index As Byte
     pixel_aspect_ratio As Byte
End Type
Private Type GifImageDescriptor
     Left As Integer
     Top As Integer
     Width As Integer
     Height As Integer
     Format As Byte 'ImageFormat
End Type
'========Added by Wolfgang Goetz for transparent GIFs=====
Private Type CONTROLBLOCK '(April 8., 2002 --> Wolfgang Goetz)
    Blocksize As Byte
    Flags As Byte
    Delay As Integer
    TransParent_Color As Byte
    Terminator As Byte
End Type
Private Const GIF89a = "GIF89a"
Private Const CtrlIntro As Byte = &H21
Private Const CtrlLabel As Byte = &HF9
Const GIF87a = "GIF87a"
Const GifTerminator As Byte = &H3B
Const ImageSeparator As Byte = &H2C
Const CHAR_BIT = 8
Const CodeSize As Byte = 9
Const ClearCode = 256
Const EndCode  As Integer = 257
Const FirstCode = 258
Const LastCode As Integer = 511
Const MAX_CODE = LastCode - FirstCode
Private colTable As New Collection
Private fn As Integer
Private gifPalette(0 To 255) As RGBTRIPLE
Private bit_position As Integer
Private code_count As Integer
Private data_buffer(255) As Byte
Private aPower2(31) As Long
Private picWidth As Long, picHeight As Long
Private IsBusy As Boolean
'Private cDibSave As New cDIBSectionSave
Private m_dib As New cDIBSection
Public Event Progress(ByVal Percents As Integer)
Private m_websafeonly As Boolean
Dim bm As BITMAP
Public Function SaveGIF(ByVal pic As StdPicture, ByVal sFileName As String, _
       Optional hdc As Long = 0, Optional UseTrans As Boolean = False, _
       Optional ByVal TransColor As Long = 0, Optional ByVal WebSafePaletteOnly As Boolean = True) As Boolean
   If IsBusy Then Exit Function
   Dim scr As GifScreenDescriptor, im As GifImageDescriptor
   Dim hDCScn As Long, OldObj As Long, Src_hDc As Long
   Dim hDib256 As Long, hDC256 As Long, OldObj256 As Long
   Dim buf() As Byte, data As Byte, TransIndex As Byte
   Dim i As Long, j As Long, clr As Long
   Dim bFound As Boolean
   Dim intCode As Integer, nCount  As Integer
   Dim sPrefix As String, sByte As String
   Dim tempPic As StdPicture
   IsBusy = True
   m_websafeonly = WebSafePaletteOnly
   m_dib.CreateFromPicture pic
   Call GetObjectAPI(pic, Len(bm), bm)
   picWidth = bm.bmWidth
   picHeight = bm.bmHeight
   ReDim buf(CLng(((picWidth + 3) \ 4) * 4), picHeight) As Byte
'Prepare DC for paintings
   hDCScn = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
   hDC256 = CreateCompatibleDC(hDCScn)
   If hdc = 0 Then
      Src_hDc = CreateCompatibleDC(hDCScn)
      OldObj = SelectObject(Src_hDc, pic)
      Src_hDc = hdc
   End If
   DeleteDC hDCScn
   hDib256 = CreateDib256(hdc, bi)
   If hDib256 <> 0 Then
      OldObj256 = SelectObject(hDC256, hDib256)
      Call BitBlt(hDC256, 0, 0, picWidth, picHeight, Src_hDc, 0, 0, vbSrcCopy)
      For i = 0 To picHeight - 1
          Call GetDIBits(hDC256, hDib256, i, 1, buf(0, picHeight - i), bi, 0)
      With bi.bmiHeader
          .biSize = Len(bi.bmiHeader)
          .biWidth = picWidth
          .biHeight = picHeight
          .biPlanes = 1
          .biBitCount = 8
          .biCompression = BI_RGB
      End With
      For i = 0 To picHeight - 1
          Call GetDIBits(Src_hDc, pic, i, 1, buf(0, picHeight - i), bi, DIB_RGB_COLORS)
   End If
'Fill gif file info
   For i = 0 To 255
       gifPalette(i).rgbBlue = bi.bmiColors(i).rgbBlue
       gifPalette(i).rgbGreen = bi.bmiColors(i).rgbGreen
       gifPalette(i).rgbRed = bi.bmiColors(i).rgbRed
       If Not bFound Then
          clr = RGB(gifPalette(i).rgbRed, gifPalette(i).rgbGreen, gifPalette(i).rgbBlue)
          If clr = TransColor Then
             TransIndex = i: bFound = True
          End If
       End If
'  If TransColor = 0 Then TransIndex = 0
   scr.background_color_index = 0
   scr.Flags = &HF7 '256-color gif with global color map
   scr.pixel_aspect_ratio = 0
   im.Format = &H7 'GlobalNonInterlaced
   im.Height = picHeight
   im.Width = picWidth
   If FileExists(sFileName) Then Kill sFileName
   fn = FreeFile
   Open sFileName For Binary As fn
'Write GIF header and header info
     If UseTrans = True Then '(April 8., 2002 --> Wolfgang Goetz)
        Put #fn, , GIF89a
        Put #fn, , GIF87a
     End If
     Put #fn, , scr
     Put #fn, , gifPalette
 '(April 8., 2002 --> Wolfgang Goetz)
     If UseTrans = True Then
        Put #fn, , CtrlIntro
        Put #fn, , CtrlLabel
        Dim cb As CONTROLBLOCK
        cb.Blocksize = 4 'Always 4
        cb.Flags = 9 'Packed = 00001001 (If Bit 0 = 1: Use Transparency)
        cb.Delay = 0
        cb.TransParent_Color = TransIndex
        cb.Terminator = 0 'Always 0
        Put #fn, , cb
     End If
     Put #fn, , ImageSeparator
     Put #fn, , im
     data = CodeSize - 1
     Put #fn, , data
     data_buffer(0) = 0
     bit_position = CHAR_BIT
'Process pixels data using LZW/GIF compression
     For i = 1 To picHeight
         sPrefix = ""
         intCode = buf(0, i)
         On Error Resume Next
         For j = 1 To picWidth - 1
             sByte = MyFormat(buf(j, i))
             sPrefix = sPrefix & sByte
             intCode = colTable(sPrefix)
             If Err <> 0 Then 'Prefix wasn't in collection - save it and output code
                nCount = colTable.Count
                If nCount = MAX_CODE Then Reinitialize
                 colTable.Add nCount + FirstCode, sPrefix
                 OutputBits intCode, CodeSize
                 sPrefix = sByte
                 intCode = buf(j, i)
             End If
         OutputBits intCode, CodeSize
         If i Mod 10 = 0 Then
            RaiseEvent Progress(i * 100 / picHeight)
         End If
     OutputCode (EndCode)
     For i = 0 To data_buffer(0)
         Put #fn, , data_buffer(i)
     data = 0
     Put #fn, , data
     Put #fn, , GifTerminator
   Close fn
   Erase buf
   If hdc = 0 Then
      SelectObject Src_hDc, OldObj
      DeleteDC Src_hDc
   End If
   SelectObject hDC256, OldObj256
   DeleteObject hDib256
   DeleteDC hDC256
   SaveGIF = True
   IsBusy = False
End Function
Private Sub OutputBits(Value As Integer, Count As Integer)
   Dim i As Integer, bit As Integer
   Do While i < Count
      If bit_position = CHAR_BIT Then
         If data_buffer(0) = 255 Then
            Put #fn, , data_buffer
            data_buffer(0) = 1
            data_buffer(0) = data_buffer(0) + 1
         End If
         data_buffer(data_buffer(0)) = 0
         bit_position = 0
       End If
       bit = Sgn(Power2(i) And Value)
       If bit > 0 Then data_buffer(data_buffer(0)) = Power2(bit_position) Or data_buffer(data_buffer(0))
       i = i + 1: bit_position = bit_position + 1
End Sub
Private Sub OutputCode(code As Integer)
    code_count = code_count + 1
    If code_count > LastCode Then
      code_count = FirstCode
      Call OutputBits(ClearCode, CodeSize)
    End If
    Call OutputBits(code, CodeSize)
End Sub
Private Sub ClearTable()
   Set colTable = Nothing
   Set colTable = New Collection
End Sub
Private Sub Reinitialize()
   Call OutputBits(ClearCode, CodeSize)
End Sub
Private Function FileExists(ByVal strPathName As String) As Boolean
   Dim af As Long
   af = GetFileAttributes(strPathName)
   FileExists = (af <> -1)
End Function
Private Function Power2(ByVal i As Integer) As Long
    If aPower2(0) = 0 Then
       aPower2(0) = &H1&
       aPower2(1) = &H2&
       aPower2(2) = &H4&
       aPower2(3) = &H8&
       aPower2(4) = &H10&
       aPower2(5) = &H20&
       aPower2(6) = &H40&
       aPower2(7) = &H80&
       aPower2(8) = &H100&
       aPower2(9) = &H200&
       aPower2(10) = &H400&
       aPower2(11) = &H800&
       aPower2(12) = &H1000&
       aPower2(13) = &H2000&
       aPower2(14) = &H4000&
       aPower2(15) = &H8000&
       aPower2(16) = &H10000
       aPower2(17) = &H20000
       aPower2(18) = &H40000
       aPower2(19) = &H80000
       aPower2(20) = &H100000
       aPower2(21) = &H200000
       aPower2(22) = &H400000
       aPower2(23) = &H800000
       aPower2(24) = &H1000000
       aPower2(25) = &H2000000
       aPower2(26) = &H4000000
       aPower2(27) = &H8000000
       aPower2(28) = &H10000000
       aPower2(29) = &H20000000
       aPower2(30) = &H40000000
       aPower2(31) = &H80000000
    End If
    Power2 = aPower2(i)
End Function
Private Function MyFormat(ByVal s As String) As String
   MyFormat = Right$("00" & s, 3)
End Function
Private Function CreateDib256(ByVal h_Dc As Long, bi As BITMAPINFO256) As Long
Dim lScanSize As Long
Dim lptr As Long, lIndex As Long
Dim r As Long, g As Long, b As Long
Dim rA As Long, gA As Long, bA As Long
Dim hDib As Long, bSuccess As Boolean
Dim lHDC As Long, hBmpOld As Long, lHDCWOrk As Long, i As Long
Dim cDIBWork As cDIBSection
Dim bBltIn As Boolean
Dim cPal As New cPalette
   With bi.bmiHeader
       .biSize = Len(bi.bmiHeader)
       .biWidth = picWidth
       .biHeight = picHeight
       .biPlanes = 1
       .biBitCount = 8
       .biCompression = BI_RGB
       lScanSize = (picWidth + picWidth Mod 4)
       .biSizeImage = lScanSize * picHeight
   End With
    Set cPal = New cPalette
    Set cDIBWork = New cDIBSection
    cDIBWork.Create m_dib.Width, m_dib.Height
    If m_websafeonly = True Then
        cPal.CreateOptimal m_dib
    End If
    Call pbCreate256ColourDIBSection(hDib, bi, lptr, m_dib.Width, m_dib.Height, cPal)
    CreateDib256 = CreateDIBSection256(h_Dc, bi, DIB_RGB_COLORS, lptr, 0, 0)
End Function
Private Function pbCreate256ColourDIBSection(ByRef hDib As Long, ByRef tBI As BITMAPINFO256, ByRef lptr As Long, ByVal lWidth As Long, ByVal lheight As Long, Optional ByRef cP As cPalette = Nothing) As Long
Dim lScanSize As Long
Dim lHDC As Long
Dim i As Long
Dim iMax As Long
   lHDC = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
   With tBI.bmiHeader
       .biSize = Len(tBI.bmiHeader)
       .biWidth = lWidth
       .biHeight = lheight
       .biPlanes = 1
       .biBitCount = 8
       .biCompression = BI_RGB
       lScanSize = (lWidth + lWidth Mod 4)
       .biSizeImage = lScanSize * .biHeight
   End With
   iMax = 255
   If iMax >= cP.Count Then
      iMax = cP.Count - 1
   End If
   For i = 0 To iMax
      With tBI.bmiColors(i)
         .rgbBlue = cP.Blue(i + 1)
         .rgbGreen = cP.Green(i + 1)
         .rgbRed = cP.Red(i + 1)
      End With
'   bi = tBI
'   hDib = CreateDIBSection256( _
'           lHDC, _
'           tBI, _
'           DIB_RGB_COLORS, _
'           lptr, _
'           0, 0)
   pbCreate256ColourDIBSection = hDib
   DeleteDC lHDC
End Function

Open in new window


Expert Comment

ID: 20818623
Is the gif for use within a VB application, or for on the web?

Author Comment

ID: 20821990
Wow man!
The GIF is for multipropose uses. I am making an application that can exports images in many formats.

By the way, I can open the GIF in Photoshop but can not display it in IE7.

Do you know why?

Expert Comment

ID: 20822714
no thats why I asked "Is the gif for use within a VB application, or for on the web?"

It not just for you, but I cannot see why.  It also works in FrontPage which is bizzare but it works in firefox also.  I an only imagine its some oddity in the standard.

Is this good enough?  If it were for use with IE I would have to search for a new answer as I cannot see why this code doesnt work for IE.

Author Comment

ID: 20822805
If the GIF can not be viewed in IE this algoritm will not 100% useful.
Using another library (as freeimage.dll) to re-save maybe this will work.

Off course I wll accept your solution anyway. Thanks a lot.

By the way, do you know how can i export an EMF into transparent GIF and PNG?

Expert Comment

ID: 20822830
thanks for that!its put me at #12 for this year so far ;)

I don't but if I find anything on the subject, I'll post it as a comment


Featured Post

Keep up with what's happening at Experts Exchange!

Sign up to receive Decoded, a new monthly digest with product updates, feature release info, continuing education opportunities, and more.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

When designing a form there are several BorderStyles to choose from, all of which can be classified as either 'Fixed' or 'Sizable' and I'd guess that 'Fixed Single' or one of the other fixed types is the most popular choice. I assume it's the most p…
Background What I'm presenting in this article is the result of 2 conditions in my work area: We have a SQL Server production environment but no development or test environment; andWe have an MS Access front end using tables in SQL Server but we a…
Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…

612 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question