Solved

saving form to bitmap question

Posted on 1997-08-11
1
224 Views
Last Modified: 2013-12-03
To save a maximized form as a bitmap, I am using BitBlt to copy it to a picturebox and then using SavePicture.
If my screen is running 1024x768 at 32k colours, the saved bitmap file is 1.5MB. Does anybody know how I could force a save to a 256 colour bitmap to give me a smaller bitmap?
0
Comment
Question by:mark_s
1 Comment
 
LVL 7

Accepted Solution

by:
tward earned 100 total points
ID: 1430228
Here is some code I ran across, I have never tried it though:

It may be better if I send it to you via email or go to the following site and download KONVERT.ZIP from the VB 4 Part.

http://www.geocities.com/siliconvalley/bay/3317

Attribute VB_Name = "SAVBMP1"
Option Explicit
'***************************************************
'
'  This app demonstrates a method of saving bitmaps
' at any color depth.  Any bitmap may be loaded into
' the picturebox (any color depth: how it displays
' depends on your video driver, however).  You can
' then save it as a monochrome, 16-color, 256-color,
' or 16million color bitmap (with the corresponding
' differences in file size!).
'  The file is saved as Test.bmp in the app directory.
'
'***************************************************

Type BITMAPFILEHEADER
  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
  biXPelsPerMeter As Long
  biYPelsPerMeter As Long
  biClrUsed As Long
  biClrImportant As Long
End Type

Type LOGPALETTE16
  PalVersion As Integer
  PalNumEntries As Integer
  palPalEntry(15) As Long
End Type

Type LOGPALETTE256
  PalVersion As Integer
  PalNumEntries As Integer
  palPalEntry As String * 1024
End Type

Dim FileHead As BITMAPFILEHEADER
Dim InfoHead As BITMAPINFOHEADER
Dim Pal16 As LOGPALETTE16
Dim Pal256 As LOGPALETTE256

Const HEADERLEN = 54
Const BF_TYPE = 19778 ' "BM"
Const PALLEN256 = 1024
Const PALLEN16 = 64
Const PALLEN2 = 8
Const BISIZ = 40

Declare Function GetPixel Lib "GDI32" (ByVal hDC As Integer, ByVal X As Integer, ByVal Y As Integer) As Long
Declare Function GetNearestPaletteIndex Lib "GDI32" (ByVal hPalette As Integer, ByVal crColor As Long) As Integer
Declare Function DeleteObject Lib "GDI32" (ByVal hObject As Integer) As Integer
'alias two versions of CreatePalette for 16 or 256 colors
Declare Function CreatePalette16 Lib "GDI32" Alias "CreatePalette" (lpLogPalette As LOGPALETTE16) As Integer
Declare Function CreatePalette256 Lib "GDI32" Alias "CreatePalette" (lpLogPalette As LOGPALETTE256) As Integer

Function FileExist(Filenam As String) As Integer
  ' checks whether a filespec exists
  Dim Result As Integer
  On Error GoTo FileExistErr
 
  Result = GetAttr(Filenam)
  FileExist = True
  Exit Function

FileExistErr:
FileExist = False
Exit Function

End Function

Function GreyScale(ByVal Colr As Long) As Integer
' Takes a long integer color value and converts it
' to an equivalent grayscale value between 0 and 255
  Dim R As Long, G As Long, B As Long
 
  ' Break up long color value into red, green, blue
  R = Colr Mod 256
  Colr = Colr \ 256
  G = Colr Mod 256
  Colr = Colr \ 256
  B = Colr Mod 256
 
  ' Find equivalent grayscale value, 0 - 255.
  GreyScale = 76 * R / 255 + 150 * G / 255 + 28 * B / 255

End Function

Function InitPal16() As Integer
  Dim hPal As Variant  'I hate Variants, but CreatePalette() returns NULL if unsuccessful

  'initialize logical palette
  Pal16.PalVersion = &H300
  Pal16.PalNumEntries = 16
  '16 standard Windows colors
  Pal16.palPalEntry(0) = &H0&
  Pal16.palPalEntry(1) = &HBF&
  Pal16.palPalEntry(2) = &HBF00&
  Pal16.palPalEntry(3) = &HBFBF&
  Pal16.palPalEntry(4) = &HBF0000
  Pal16.palPalEntry(5) = &HBF00BF
  Pal16.palPalEntry(6) = &HBFBF00
  Pal16.palPalEntry(7) = &H808080
  Pal16.palPalEntry(8) = &HC0C0C0
  Pal16.palPalEntry(9) = &HFF&
  Pal16.palPalEntry(10) = &HFF00&
  Pal16.palPalEntry(11) = &HFFFF&
  Pal16.palPalEntry(12) = &HFF0000
  Pal16.palPalEntry(13) = &HFF00FF
  Pal16.palPalEntry(14) = &HFFFF00
  Pal16.palPalEntry(15) = &HFFFFFF

  'create a logical palette
  hPal = CreatePalette16(Pal16)

  'red is &HFF& in VB, and goes into the bmp palette as 4 bytes: FF 00 00 00
  'because the *low* byte is written *first* to a binary file.  This would be
  'great, except that the bmp file palette entries are arranged in byte order
  'BB GG RR XX; *blue* is the first byte!
  'Therefore, rearrange the palette for writing into the bitmap:
  Pal16.palPalEntry(0) = &H0&
  Pal16.palPalEntry(1) = &HBF0000  'dark blue in VB, but comes out dark red in bmp palette
  Pal16.palPalEntry(2) = &HBF00&
  Pal16.palPalEntry(3) = &HBFBF00
  Pal16.palPalEntry(4) = &HBF&
  Pal16.palPalEntry(5) = &HBF00BF
  Pal16.palPalEntry(6) = &HBFBF&
  Pal16.palPalEntry(7) = &H808080
  Pal16.palPalEntry(8) = &HC0C0C0
  Pal16.palPalEntry(9) = &HFF0000
  Pal16.palPalEntry(10) = &HFF00&
  Pal16.palPalEntry(11) = &HFFFF00
  Pal16.palPalEntry(12) = &HFF&
  Pal16.palPalEntry(13) = &HFF00FF
  Pal16.palPalEntry(14) = &HFFFF&
  Pal16.palPalEntry(15) = &HFFFFFF

  'return the palette handle, or -1 for an error
  If IsNull(hPal) Then
    InitPal16 = -1
  Else
    InitPal16 = hPal
  End If
 
End Function

Function InitPal256(Filenam As String) As Integer
  Dim h As Integer, i As Integer
  Dim FileHeader As BITMAPFILEHEADER
  Dim InfoHeader As BITMAPINFOHEADER
  Dim LogPal As LOGPALETTE256
  Dim hPal As Variant
  Dim tmp As String * 1
  Dim chars As String * 4

  Pal256.PalVersion = &H300
  Pal256.PalNumEntries = 256

' Convert to grayscale:
  If Form2!Check2 Then
    For i = 1 To 1021 Step 4
    ' this gives RGB = 0, 0, 0 to RGB = 255, 255, 255
      chars = Chr$(i \ 4) & Chr$(i \ 4) & Chr$(i \ 4) & Chr$(0)
      Mid$(LogPal.palPalEntry, i, 4) = chars
      Mid$(Pal256.palPalEntry, i, 4) = chars
    Next i
    LogPal.PalVersion = &H300
    LogPal.PalNumEntries = 256
    hPal = CreatePalette256(LogPal)
    GoTo CheckAndExit
    'Exit Function
  End If

' it's too much typing to hard-code a default palette:
' we'll use the one from rainbow.dib
  'FileNam = "c:\vb\rainbow.dib"
  'The Filenam parameter above is a hook I never used:
  ' instead we'll get the file name off Form2
  Filenam = Form2!Text1
  If Not FileExist(Filenam) Then
    MsgBox "Palette file not found!"
    GoTo CheckAndExit
    'Exit Function
  End If

  h = FreeFile
  Open Filenam For Binary Access Read As #h
  Get #h, , FileHeader
  Get #h, , InfoHeader

  If FileHeader.bfType <> BF_TYPE Then
    'not a bitmap
    MsgBox "Palette file is Not a bitmap file." & FileHeader.bfType
  ElseIf InfoHeader.biBitCount <> 8 Then
    'not an 8-bit bitmap
    MsgBox "Palette file is Not an 8-bit bitmap."
'  ElseIf InfoHeader.biClrsUsed <> 0 and InfoHeader.biClrsUsed <> 256 then
'    'palette may not contain 256 colors
  ElseIf FileHeader.bfOffBits <> HEADERLEN + PALLEN256 Then
    MsgBox "Palette contains only " & Str$((FileHeader.bfOffBits - HEADERLEN) / 4) & " Colors."
  Else
    'it's OK, do it

    'since we've defined the palette as a 1K string,
    'we can read it in one gulp
    Get #h, , Pal256.palPalEntry
    'Now we've got to rearrange, since the palette just
    ' read out of the bmp has BGR entries, but we need
    ' RGB for the logical palette
    For i = 1 To 1021 Step 4
      Mid$(LogPal.palPalEntry, i, 1) = Mid$(Pal256.palPalEntry, i + 2, 1)
      Mid$(LogPal.palPalEntry, i + 1, 1) = Mid$(Pal256.palPalEntry, i + 1, 1)
      Mid$(LogPal.palPalEntry, i + 2, 1) = Mid$(Pal256.palPalEntry, i, 1)
    Next i

    LogPal.PalVersion = &H300
    LogPal.PalNumEntries = 256
   
  ' create the logical palette and retrieve its handle
    hPal = CreatePalette256(LogPal)

  End If
  Close #h

CheckAndExit:
If IsNull(hPal) Or IsEmpty(hPal) Then
  InitPal256 = -1
Else
  InitPal256 = hPal
End If

End Function

Sub Output16Bmp(Filenam As String, Pict As Control)
'This routine reads a picturebox pixel by pixel and writes a
'16-color bitmap to disk using the "nearest" standard color
  Dim PixelsWide As Integer, PixelsHi As Integer
  Dim OutH As Integer
  Dim i As Integer, j As Integer, k As Integer
  Dim Line16$
  Dim Colr&
  Dim hPal As Integer
  Dim PicHDC As Integer
  Dim PalNum As Integer

' Set up the standard 16-color palette
  hPal = InitPal16()
  If hPal = -1 Then
    MsgBox ("Problem creating palette!")
    Exit Sub
  End If
  Screen.MousePointer = 11

' The output bitmap is the same size as the picturebox:
' Picture1 has AutoSize = True and ScaleMode = 3 (pixel)
  PixelsWide = Pict.ScaleWidth
  PixelsHi = Pict.ScaleHeight

' Open disk file for storing 16-color bmp:
  OutH = FreeFile
  Open Filenam For Binary Access Write As #OutH

' set header data
  InfoHead.biSize = BISIZ
  InfoHead.biWidth = PixelsWide
  InfoHead.biHeight = PixelsHi
  InfoHead.biPlanes = 1
  InfoHead.biBitCount = 4
  InfoHead.biSizeImage = CLng(PixelsWide) * PixelsHi / 2
  InfoHead.biClrImportant = 0

  FileHead.bfType = BF_TYPE
  FileHead.bfOffBits = HEADERLEN + PALLEN16
  FileHead.bfsize = FileHead.bfOffBits + WidthBytes(PixelsWide, InfoHead.biBitCount) * CLng(PixelsHi)

  Put #OutH, , FileHead
  Put #OutH, , InfoHead

' now write the 16-color palette to the file
  For i = 0 To 15
    Put #OutH, , Pal16.palPalEntry(i)
  Next i

' allocate string buffer to hold one line of 16-color bmp
  Line16$ = Space(WidthBytes(PixelsWide, InfoHead.biBitCount))

' get the picturebox hDC for GetPixel()
  PicHDC = Pict.hDC

' loop through all pixels in the image
  For i = PixelsHi - 1 To 0 Step -1
    'change picture to 16-color format:
    'one byte of 16-color data = 2 pixels
    For j = 0 To PixelsWide - 1 Step 2
      'build up one byte (for two pixels of image)
      'in the low byte of an integer:
      PalNum = 0
      For k = 0 To 1
        'get color of this pixel from picturebox
        'GetPixel is a little faster than Point
        ''Colr& = Pict.Point(j + k, i)
        Colr& = GetPixel(PicHDC, j + k, i)
        'find nearest color in std windows palette
        'and load into appropriate bits of integer PalNum.
        'Exponentiation is slow, so I use the If/Else instead
        ''PalNum = PalNum Or 16 ^ (1 - k) * GetNearestPaletteIndex(hPal, Colr&)
        If k = 0 Then  'upper nibble
          PalNum = PalNum Or 16 * GetNearestPaletteIndex(hPal, Colr&)
        Else           'lower nibble
          PalNum = PalNum Or GetNearestPaletteIndex(hPal, Colr&)
        End If
      Next k
      ' add PalNum byte to character buffer
      Mid$(Line16$, j / 2 + 1, 1) = Chr$(PalNum)
    Next j

    'write out a line of the bmp
    Put #OutH, , Line16$
    DoEvents
  Next i

  'All done: close the disk file
  Close #OutH

  'release the palette
  i = DeleteObject(hPal)
  Screen.MousePointer = 0
  If i = 0 Then MsgBox "Couldn't release palette!"

End Sub

Sub Output24BitBmp(Filenam As String, Pict As Control)
'This routine reads a picturebox pixel by pixel and writes a
'16M-color bitmap to disk
  Dim PixelsWide As Integer, PixelsHi As Integer
  Dim OutH As Integer
  Dim i As Integer, j As Integer
  Dim Line16M$
  Dim Colr&
  Dim PicHDC As Integer
  Dim Red%, Green%, Blue%

  Screen.MousePointer = 11
'******************************
'Dim start
'start = Timer
'******************************

' The output bitmap is the same size as the picturebox:
' Picture1 has AutoSize = True and ScaleMode = 3 (pixel)
  PixelsWide = Pict.ScaleWidth
  PixelsHi = Pict.ScaleHeight

' Open disk file for storing 16M-color bmp:
  OutH = FreeFile
  Open Filenam For Binary Access Write As #OutH

' set header data
  InfoHead.biSize = BISIZ
  InfoHead.biWidth = PixelsWide
  InfoHead.biHeight = PixelsHi
  InfoHead.biPlanes = 1
  InfoHead.biBitCount = 24
  InfoHead.biSizeImage = CLng(PixelsWide) * PixelsHi * 3
  InfoHead.biClrImportant = 0

  FileHead.bfType = BF_TYPE
  FileHead.bfOffBits = HEADERLEN
  FileHead.bfsize = FileHead.bfOffBits + WidthBytes(PixelsWide, InfoHead.biBitCount) * CLng(PixelsHi)

  Put #OutH, , FileHead
  Put #OutH, , InfoHead

' buffer to hold one line of 16M-color bmp
  Line16M = Space(WidthBytes(PixelsWide, InfoHead.biBitCount))
 
  PicHDC = Pict.hDC
' loop through all pixels in the image
  For i = PixelsHi - 1 To 0 Step -1
    'change picture to 16M-color format:
    'three bytes of 16M-color data = 1 pixel
    For j = 0 To PixelsWide - 1 Step 1
      'build up 3 bytes for one pixel of image
      'get color of this pixel from picturebox
      'GetPixel is a little faster than Point
      'Colr& = Pict.Point(j, i)
      Colr& = GetPixel(PicHDC, j, i)
      'Break up long color value into RGB
      Red% = Colr& Mod 256
      Colr& = Colr& \ 256
      Green% = Colr& Mod 256
      Colr& = Colr& \ 256
      Blue% = Colr& Mod 256
      Mid$(Line16M$, j * 3 + 1, 1) = Chr$(Blue%)
      Mid$(Line16M$, j * 3 + 2, 1) = Chr$(Green%)
      Mid$(Line16M$, j * 3 + 3, 1) = Chr$(Red%)
    Next j
    'write out a line of the bmp
    Put #OutH, , Line16M$
  Next i
  'All done: close the disk file
  Close #OutH
  Screen.MousePointer = 0

'*****************************
'Debug.Print Timer - start
'*****************************

End Sub

Sub Output256Bmp(Filenam As String, Pict As Control)
'This routine reads a picturebox pixel by pixel and writes a
'256-color bitmap to disk using the nearest available color
  Dim PixelsWide As Integer, PixelsHi As Integer
  Dim OutH As Integer
  Dim i As Integer, j As Integer
  Dim Line256$
  Dim Colr&
  Dim hPal As Integer
  Dim PicHDC As Integer
  Dim PalNum As Integer

'******************************
'Dim start
'start = Timer
'******************************
' Set up the 256-color palette
  hPal = InitPal256("dummy")
  If hPal = -1 Then Exit Sub    'didn't work
 
  Screen.MousePointer = 11

' The output bitmap is the same size as the picturebox:
' Picture1 has AutoSize = True and ScaleMode = 3 (pixel)
  PixelsWide = Pict.ScaleWidth
  PixelsHi = Pict.ScaleHeight

' Open disk file for storing 256-color bmp:
  OutH = FreeFile
  Open Filenam For Binary Access Write As #OutH

' set header data
  InfoHead.biSize = BISIZ
  InfoHead.biWidth = PixelsWide
  InfoHead.biHeight = PixelsHi
  InfoHead.biPlanes = 1
  InfoHead.biBitCount = 8
  InfoHead.biSizeImage = CLng(PixelsWide) * PixelsHi
  InfoHead.biClrImportant = 0

  FileHead.bfType = BF_TYPE
  FileHead.bfOffBits = HEADERLEN + PALLEN256
  FileHead.bfsize = FileHead.bfOffBits + WidthBytes(PixelsWide, InfoHead.biBitCount) * CLng(PixelsHi)

  Put #OutH, , FileHead
  Put #OutH, , InfoHead

' now write the 256-color palette to the file
  Put #OutH, , Pal256.palPalEntry

' buffer to hold one line of 16-color bmp
  Line256$ = Space(WidthBytes(PixelsWide, InfoHead.biBitCount))
 
  PicHDC = Pict.hDC
' loop through all pixels in the image
  For i = PixelsHi - 1 To 0 Step -1
    'change picture to 256-color format:
    'one byte of 256-color data = 1 pixel
    For j = 0 To PixelsWide - 1 Step 1
      'build up one byte for one pixel of image
      'in the low byte of an integer:
      PalNum = 0
      'get color of this pixel from picturebox
      'GetPixel is a little faster than Point
      'Colr& = Pict.Point(j, i)
      Colr& = GetPixel(PicHDC, j, i)
      'find nearest color in palette
      PalNum = GetNearestPaletteIndex(hPal, Colr&)
      ' add PalNum byte to PalNum line buffer
      Mid$(Line256$, j + 1, 1) = Chr$(PalNum)
    Next j
    'write out a line of the bmp
    Put #OutH, , Line256$
    DoEvents
  Next i
  'All done: close the disk file
  Close #OutH
  'release the palette
  i = DeleteObject(hPal)
  Screen.MousePointer = 0
  If i = 0 Then MsgBox "Couldn't release palette!"

'*****************************
'Debug.Print Timer - start
'*****************************

End Sub

Sub OutputMonoBmp(Filenam As String, Pict As Control)

'This routine reads a picturebox pixel by pixel and writes
' a monochrome bitmap to disk.
  Dim AllToBlack As Integer, Threshold As Integer
  Dim PixelsWide As Integer, PixelsHi As Integer
  Dim OutH As Integer
  Dim i As Integer, j As Integer, k As Integer
  Dim LineMono$
  Dim Colr&
  Dim PicHDC As Integer
  Dim mono As Integer
  Dim BLACK As Long, WHITE As Long
  BLACK = &H0&
  WHITE = &HFFFFFF

  Screen.MousePointer = 11
'******************************
'Dim start
'start = Timer
'******************************
  AllToBlack = Form2!Option1(0)
  Threshold = Val(Form2!Label1)

' The output bitmap is the same size as the picturebox:
' Picture1 has AutoSize = True and ScaleMode = 3 (pixel)
  PixelsWide = Pict.ScaleWidth
  PixelsHi = Pict.ScaleHeight

' Open disk file for storing monochrome bmp:
  OutH = FreeFile
  Open Filenam For Binary Access Write As #OutH

' header info
  InfoHead.biSize = BISIZ
  InfoHead.biWidth = PixelsWide
  InfoHead.biHeight = PixelsHi
  InfoHead.biPlanes = 1
  InfoHead.biBitCount = 1
  InfoHead.biSizeImage = CLng(PixelsWide) * PixelsHi / 8
  InfoHead.biClrImportant = 0

  FileHead.bfType = BF_TYPE
  FileHead.bfOffBits = HEADERLEN + PALLEN2
  FileHead.bfsize = FileHead.bfOffBits + WidthBytes(PixelsWide, InfoHead.biBitCount) * CLng(PixelsHi)

  Put #OutH, , FileHead
  Put #OutH, , InfoHead

' palette (black and white)
  If Form2!Check1 Then
  ' negative image
    Put #OutH, , WHITE
    Put #OutH, , BLACK
  Else
    Put #OutH, , BLACK
    Put #OutH, , WHITE
  End If

' buffer to hold one line of mono bmp
  LineMono$ = Space(WidthBytes(PixelsWide, InfoHead.biBitCount))
  PicHDC = Pict.hDC
' loop through all pixels in the image
  For i = PixelsHi - 1 To 0 Step -1
    'change picture to mono format:
    ''one byte of mono data = 8 pixels
    For j = 0 To PixelsWide - 1 Step 8
      ' build up mono byte (for eight pixels of image)
      ' in the low byte of an integer:
      mono = 0
      For k = 0 To 7
        'get color of this pixel from picturebox
        'GetPixel is a little faster than Point
        'Colr& = Pict.Point(j + k, i)
        Colr& = GetPixel(PicHDC, j + k, i)
        If AllToBlack Then
          ' white is the background color: anything else is black.
          'if it's white, set that bit.  Otherwise, just go on to next
          'Note: exponentiation is *slow*: select case would be faster
          If Colr& = WHITE Then mono = mono Or 2 ^ (7 - k)
        Else
          ' any color lighter than the threshold goes white:
          If GreyScale(Colr&) >= Threshold Then mono = mono Or 2 ^ (7 - k)
        End If
      Next k
      ' add mono byte to mono line buffer
      Mid$(LineMono$, j / 8 + 1, 1) = Chr$(mono)
    Next j
    'write out a line of mono bmp
    Put #OutH, , LineMono$
    DoEvents
  Next i
  'All done: close the disk file
  Close #OutH
  Screen.MousePointer = 0
'*****************************
'Debug.Print Timer - start
'*****************************

End Sub

Function WidthBytes(Wide As Integer, BitCount As Integer) As Integer
' all bmps must have a multiple of 32 bits (a long integer)
' in each row even if not all the bits are used
  Dim tmp!
  Dim i%

  tmp! = Wide * BitCount / 32
  i% = Int(tmp!)
  If i% <> tmp! Then i% = i% + 1
  WidthBytes = i% * 4

End Function

Function WidthBytes2(Wide As Integer, BitCount As Integer) As Integer
' this is a neat algorithm I stole from VB4 How-To.
' I'm not sure I get it, but it *does* work!
  WidthBytes2 = ((CLng(BitCount) * CLng(Wide) + 31&) And &HFFE0) \ 8
End Function
0

Featured Post

IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

Join & Write a Comment

Introduction I needed to skip over some file processing within a For...Next loop in some old production code and wished that VB (classic) had a statement that would drop down to the end of the current iteration, bypassing the statements that were c…
I’ve seen a number of people looking for examples of how to access web services from VB6.  I’ve been using a test harness I built in VB6 (using many resources I found online) that I use for small projects to work out how to communicate with web serv…
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…
Get people started with the utilization of class modules. Class modules can be a powerful tool in Microsoft Access. They allow you to create self-contained objects that encapsulate functionality. They can easily hide the complexity of a process from…

708 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

Need Help in Real-Time?

Connect with top rated Experts

16 Experts available now in Live!

Get 1:1 Help Now