Saving A4 bitmaps in B/W 
Author Message
 Saving A4 bitmaps in B/W

Hello everybody,

i'm creating a small CAD-program for technical drawings and i have a problem
saving them in the right format. When i start the program, i load a 80 kB
Black/white A4 bitmap in a picturebox for the color-palette.
When i save it with the 'SavePicture'-method it always is saved in system
color format (24 bit color), therefore the size is huge, 1,8 Mb. Does anyone
know what i'm doing wrong?
Plaese advice and t.i.a.

Jacco



Wed, 18 Jun 1902 08:00:00 GMT  
 Saving A4 bitmaps in B/W

Quote:

>Hello everybody,

>i'm creating a small CAD-program for technical drawings and i have a problem
>saving them in the right format. When i start the program, i load a 80 kB
>Black/white A4 bitmap in a picturebox for the color-palette.
>When i save it with the 'SavePicture'-method it always is saved in system
>color format (24 bit color), therefore the size is huge, 1,8 Mb. Does anyone
>know what i'm doing wrong?
>Jacco

You are doing nothing wrong. With SavePicture, the size of the bitmap is based
on the system's color that displays it, regardless of the original bitmap.  You
can reduce the system's color depth.  These files really compress good with
something like PKZIP.

I had this same problem, and wrote a routine (for VB3) which converts any
bitmap to monochrome (Black & White, or any two colors). This will reduce your
file size by 24:1. See code below. Vor VB5 or 6, there are equivalent API's.
(And some that are simpler, but use different code). The biggest difference for
the ones used here is that the integer declares change to long in VB5/6.  Good
luck.

Function SaveNewBMP (pic As PictureBox, Filename As String, ByVal NumColors As
Integer)
 ' Returns a 1 if successful, a 0 if not.
 ' For VB3 and VB4 (16 bit)
 ' Save picture box at reduced color depth bitmap to reduce file size when full
color is not needed.
 ' NumColors can be either:
 '   2, 16, 256 for the number of colors, or
 '   1, 4, 8    for the number color bits (bits per pixel)
 '
 ' In Monochrome, a foregound color that is brite (closer to white) will not
show.
 ' a color that is dark, (closer to black) will show.
 ' Has provision to customize foreground and background colors in 2-color
version

 '  ** Note: this SUB sets the source picturebox to scalemode 3 (pixels).
 '     Restore scalemode and any custom scale properties if you may
 '     add more graphics or print to the picture box.
 '
 ' Type definitions and declarations needed for this sub are shown at the end
 '

 ' Tested a little.  Not gauranteed to be bug free.

 On Error GoTo SaveNewBMPErr

 Dim SaveFileHeader       As BITMAPFILEHEADER
 Dim SaveBITMAPINFO_1     As BITMAPINFO_1
 Dim SaveBITMAPINFO_4     As BITMAPINFO_4
 Dim SaveBITMAPINFO_8     As BITMAPINFO_8

 Dim BitsPerPixel         As Integer
 Dim LpBits               As Long
 Dim Num32bitWords        As Integer
 Dim Buffersize           As Long
 Dim FileNum              As Integer
 Dim Retval%              ' Temporary returns and handles follow
 Dim LRetval&             '    "        "
 Dim Memhnd%
 Dim Ghnd%
 Dim X%

 ' Set the Scalemode to pixels (*** Note: this also sets the source picturebox
to scalemode 3)
  pic.ScaleMode = 3  ' Pixels

 ' Allow for use of color bits to be used instead of the number of colors:
  If NumColors = 1 Then NumColors = 2
  If NumColors = 4 Then NumColors = 16
  If NumColors = 8 Then NumColors = 256

 ' Check for illegal NumColors. Set to default as monochrome.
  If NumColors <> 2 And NumColors <> 16 And NumColors <> 256 Then NumColors = 2

  BitsPerPixel = Log(NumColors) / Log(2)

 ' *** Calculate the buffer for the pixel data
  Num32bitWords = (pic.ScaleWidth * BitsPerPixel) \ 32   ' Integer divide
  If pic.ScaleWidth Mod 32 > 0 Then Num32bitWords = Num32bitWords + 1 ' End
each scan line on 32-bit boundary
  Buffersize = Num32bitWords * 4 * pic.ScaleHeight  ' 8-bit Bytes; 8 pixels per
byte for mono; 2 for 16 color; 4 for 256 color
 ' Buffersize can be larger than this; results in larger bitmap file.

  ' *** Fill the Bitmap info
  If BitsPerPixel = 1 Then
   SaveBITMAPINFO_1.bmiHeader.biSize = 40
   SaveBITMAPINFO_1.bmiHeader.biWidth = pic.ScaleWidth
   SaveBITMAPINFO_1.bmiHeader.biHeight = pic.ScaleHeight
   SaveBITMAPINFO_1.bmiHeader.biPlanes = 1
   SaveBITMAPINFO_1.bmiHeader.biBitCount = BitsPerPixel
   SaveBITMAPINFO_1.bmiHeader.biCompression = 0
   SaveBITMAPINFO_1.bmiHeader.biClrUsed = 0
   SaveBITMAPINFO_1.bmiHeader.biClrImportant = 0
   SaveBITMAPINFO_1.bmiHeader.biSizeImage = Buffersize
  End If

  If BitsPerPixel = 4 Then
   SaveBITMAPINFO_4.bmiHeader.biSize = 40
   SaveBITMAPINFO_4.bmiHeader.biWidth = pic.ScaleWidth
   SaveBITMAPINFO_4.bmiHeader.biHeight = pic.ScaleHeight
   SaveBITMAPINFO_4.bmiHeader.biPlanes = 1
   SaveBITMAPINFO_4.bmiHeader.biBitCount = BitsPerPixel
   SaveBITMAPINFO_4.bmiHeader.biCompression = 0
   SaveBITMAPINFO_4.bmiHeader.biClrUsed = 0
   SaveBITMAPINFO_4.bmiHeader.biClrImportant = 0
   SaveBITMAPINFO_4.bmiHeader.biSizeImage = Buffersize
  End If

  If BitsPerPixel = 8 Then
   SaveBITMAPINFO_8.bmiHeader.biSize = 40
   SaveBITMAPINFO_8.bmiHeader.biWidth = pic.ScaleWidth
   SaveBITMAPINFO_8.bmiHeader.biHeight = pic.ScaleHeight
   SaveBITMAPINFO_8.bmiHeader.biPlanes = 1
   SaveBITMAPINFO_8.bmiHeader.biBitCount = BitsPerPixel
   SaveBITMAPINFO_8.bmiHeader.biCompression = 0
   SaveBITMAPINFO_8.bmiHeader.biClrUsed = 0
   SaveBITMAPINFO_8.bmiHeader.biClrImportant = 0
   SaveBITMAPINFO_8.bmiHeader.biSizeImage = Buffersize
  End If

  If BitsPerPixel = 1 Then Bilen = Len(SaveBITMAPINFO_1)
  If BitsPerPixel = 4 Then Bilen = Len(SaveBITMAPINFO_4)
  If BitsPerPixel = 8 Then Bilen = Len(SaveBITMAPINFO_8)

  ' *** Make and fill a Header for the new bitmap
    SaveFileHeader.bfType = &H4D42      ' "BM" for Bitmap; first two characters
in file
    SaveFileHeader.bfSize = Len(SaveFileHeader) + Bilen + Buffersize
    SaveFileHeader.bfOffBits = Len(SaveFileHeader) + Bilen

  ' Now allocate a buffer to hold the bitmap data
  ' Use the global memory pool since the buffer size could be larger than 64k
bytes
    Ghnd% = GlobalAlloc(GMEM_MOVEABLE, Buffersize)  ' Global handle
    If Ghnd% = 0 Then ' Error
     msg = "Global Allocate error."
     GoTo SaveNewBMPErr:
    End If

    LpBits = GlobalLock&(Ghnd%)                     ' Pointer to memory
location
    If LpBits = 0 Then ' Error
     msg = "Global Lock error."
     GoTo SaveNewBMPErr:
    End If

  ' Put the color table for the # of colors selected into the SaveBITMAPINFO_#
  ' and get the bitmap data from the picturebox and put it in the memory
allocated
    If BitsPerPixel = 1 Then Retval% = GetDIBits1(pic.hDC, pic.Image, 0,
pic.ScaleHeight, LpBits, SaveBITMAPINFO_1, DIB_RGB_COLORS)
    If BitsPerPixel = 4 Then Retval% = GetDIBits4(pic.hDC, pic.Image, 0,
pic.ScaleHeight, LpBits, SaveBITMAPINFO_4, DIB_RGB_COLORS)
    If BitsPerPixel = 8 Then Retval% = GetDIBits8(pic.hDC, pic.Image, 0,
pic.ScaleHeight, LpBits, SaveBITMAPINFO_8, DIB_RGB_COLORS)
    If Retval% = 0 Then ' Error
     msg = "Get DI Bits error."
     GoTo SaveNewBMPErr:
    End If

  ' Here is where you can customize the foreground and background colors for a
2-color bitmap
  'If BitsPerPixel = 1 Then
    ' For the Foreground color add this line:
     ' Mid$(SaveBITMAPINFO_1.bmiColors, 1, 3) = Chr$(ForeBlue) +
Chr$(ForeGreen) + Chr$(ForeRed)
    ' For the Foreground color add this line:
       ' Mid$(SaveBITMAPINFO_1.bmiColors, 5, 3) = Chr$(BackBlue) +
Chr$(BackGreen) + Chr$(BackRed)
    ' Where ForeBlue, etc are integers from 0 to 255 that represent the
respective color strength.
    ' For White set all to 255; for Black set all to 0.
    ' Defaults: Black foreground, White background.
  'End If

  ' *** Save the Bitmap Header and BitmapInfo to disk
  ' First remove old bitmap file if there
    If Dir$(Filename) <> "" Then Kill Filename   ' Drive and path have already
been checked
    FileNum = FreeFile
    Open Filename For Binary As FileNum

    Put FileNum, , SaveFileHeader

    If BitsPerPixel = 1 Then Put FileNum, , SaveBITMAPINFO_1
    If BitsPerPixel = 4 Then Put FileNum, , SaveBITMAPINFO_4
    If BitsPerPixel = 8 Then Put FileNum, , SaveBITMAPINFO_8

  ' Get a DOS memory handle for the destination of the bitmap data
    Memhnd% = FileAttr(FileNum, 2)

  ' And copy the pixel data from the global memory to the BitmapInfo already
saved on disk
    LRetval& = hwrite(ByVal Memhnd%, LpBits, Buffersize)
    If LRetval& = -1 Then ' Error
     msg = "hwrite error."
     GoTo SaveNewBMPErr:
    End If

    SaveNewBMP = 1

DoneSaveNewBitmap:

    Close FileNum

  ' Release the global memory block, but only if opened
   If Ghnd% > 0 Then
    X% = GlobalUnlock(Ghnd%)
    X% = GlobalFree(Ghnd%)
   End If

Exit Function

SaveNewBMPErr:
  If Len(msg) = 0 Then msg = "Error - " + Error$(Err)
  MsgBox msg, 48, "Save New Bitmap"
  msg = ""
  SaveNewBMP = 0
  If Err > 0 Then
   Resume DoneSaveNewBitmap
  Else
   GoTo DoneSaveNewBitmap
  End If

' *****  Type definitions needed by this sub
 ' Type BITMAPFILEHEADER   '14 Bytes
  '       bfType As Integer
  '       bfSize As Long
  '       bfReserved1 As Integer
  '       bfReserved2 As Integer
  '       bfOffBits As Long
 ' End Type

 '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
   '       biXPel{*filter*}eter As Long
   '       biYPel{*filter*}eter As Long
   '       biClrUsed As Long
   '       biClrImportant As Long
 ' End Type

'Type BITMAPINFO_1   ' For monochrome
   '     bmiHeader As BITMAPINFOHEADER
   '     bmiColors As String * 8
 'End Type

 'Type BITMAPINFO_4   ' For 4 bits per pixel (16 colors)
   '     bmiHeader As BITMAPINFOHEADER
   '     bmiColors As String * 64
 'End Type

 'Type BITMAPINFO_8   ' For 8 bits per pixel (256 colors)
   '      bmiHeader As BITMAPINFOHEADER
   '      bmiColors As String * 1024
 'End Type

' ****  Declares needed by this sub.  All one one line:

 'Declare Function GlobalAlloc% Lib "Kernel" (ByVal wFlags%, ByVal dwBytes&)
 'Declare Function GlobalLock& Lib "Kernel" (ByVal hMem%)
 'Declare Function GlobalFree% Lib "Kernel" (ByVal hMem%)
 'Declare Function GlobalUnlock% Lib "Kernel" (ByVal hMem%)
 'Declare Function DeleteDC% Lib "GDI" (ByVal hDC%)
 'Declare Function hwrite& Lib "Kernel" Alias "_hwrite"
...

read more »



Wed, 18 Jun 1902 08:00:00 GMT  
 
 [ 2 post ] 

 Relevant Pages 

1. Personal WS vs Peer WS

2. Saving an excel WS

3. Saving Bitmaps

4. Help! Saving Bitmaps

5. Saving Bitmaps to different color modes

6. Q: How to save pictures as compressed bitmaps?

7. saving bitmaps, icons, metafiles in 1 file

8. Saving bitmaps.

9. Saving Bitmaps

10. How to save bitmaps/wav files in Resource File

11. Loading and saving 256 color bitmaps

12. How to save monochrome bitmaps

 

 
Powered by phpBB® Forum Software