Solved

Saving pictures as monochrome bitmap

Posted on 1998-10-06
5
638 Views
Last Modified: 2013-12-03
When saving a picturebox in VB, it defaults to saving it as a 24bit BMP file.  I need to save this as a 2bit monochrome bitmap (the picture only containts blach/white pixels)

How do i do that?  Has anyone got a OCX for this?  Saving it as GIF or another nondestructive fileformat is acceptable too.
0
Comment
Question by:FlyveHest
  • 2
  • 2
5 Comments
 
LVL 14

Expert Comment

by:waty
ID: 1438385
Use this


Option Explicit

' *** Make form transparent
Declare Function CombineRgn Lib "GDI32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Declare Function CreateRectRgn Lib "GDI32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Public Const RGN_AND = 1
Public Const RGN_COPY = 5
Public Const RGN_DIFF = 4
Public Const RGN_OR = 2
Public Const RGN_XOR = 3

' *** Get an RGB Colour from an OLE_COLOR
Private Declare Function OleTranslateColor Lib "olepro32.dll" (ByVal OLE_COLOR As Long, ByVal hPalette As Long, pccolorref As Long) As Long
Private Const CLR_INVALID = -1

' *** CopyDesktop
Private Declare Function DeleteDC Lib "GDI32" (ByVal hDC As Long) As Long
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 GetDesktopWindow Lib "user32" () As Long

' *** RepaintWindow
Private Type POINTAPI
   x As Long
   y As Long
End Type

Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function InvalidateRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT, ByVal bErase As Long) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long

' **** CreateMaskImage
' Creates a memory DC1
Private Declare Function CreateCompatibleDC Lib "GDI32" (ByVal hDC As Long) As Long

' Creates a bitmap in memory:
Private Declare Function CreateCompatibleBitmap Lib "GDI32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long

' Places a GDI Object into DC, returning the previous one:
Private Declare Function SelectObject Lib "GDI32" (ByVal hDC As Long, ByVal hObject As Long) As Long

' Deletes a GDI Object:
Private Declare Function DeleteObject Lib "GDI32" (ByVal hObject As Long) As Long

' Copies Bitmaps from one DC to another, can also perform
' raster operations during the transfer:
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 Const SRCCOPY = &HCC0020

' Sets the backcolour of a device context:
Private Declare Function SetBkColor Lib "GDI32" (ByVal hDC As Long, ByVal crColor As Long) As Long

' *** Fonts
Private Const LF_FACESIZE = 32

Private Type LogFont
   lfHeight As Long
   lfWidth As Long
   lfEscapement As Long
   lfOrientation As Long
   lfWeight As Long
   lfItalic As Byte
   lfUnderline As Byte
   lfStrikeOut As Byte
   lfCharSet As Byte
   lfOutPrecision As Byte
   lfClipPrecision As Byte
   lfQuality As Byte
   lfPitchAndFamily As Byte
   lfFaceName As String * LF_FACESIZE
End Type

Private Declare Function CreateFontIndirect Lib "GDI32" Alias "CreateFontIndirectA" (lpLogFont As LogFont) As Long

Private Declare Function SetBkMode Lib "GDI32" (ByVal hDC As Long, ByVal nBkMode As Long) As Long

Private Const TRANSPARENT = 1
Private Const OPAQUE = 2

Declare Function GetDeviceCaps Lib "GDI32" (ByVal hDC As Long, ByVal nIndex As Long) As Long

Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long

Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long

Private Type TEXTMETRIC
   tmHeight As Integer
   tmAscent As Integer
   tmDescent As Integer
   tmInternalLeading As Integer
   tmExternalLeading As Integer
   tmAveCharWidth As Integer
   tmMaxCharWidth As Integer
   tmWeight As Integer
   tmItalic As String * 1
   tmUnderlined As String * 1
   tmStruckOut As String * 1
   tmFirstChar As String * 1
   tmLastChar As String * 1
   tmDefaultChar As String * 1
   tmBreakChar As String * 1
   tmPitchAndFamily As String * 1
   tmCharSet As String * 1
   tmOverhang As Integer
   tmDigitizedAspectX As Integer
   tmDigitizedAspectY As Integer
End Type

Private Declare Function GetTextMetrics Lib "GDI32" Alias "GetTextMetricsA" (ByVal hDC As Long, lpMetrics As TEXTMETRIC) As Long

Private Declare Function GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long

Private Declare Function SetMapMode Lib "GDI32" (ByVal hDC As Long, ByVal nMapMode As Long) As Long

Private Const MM_TEXT = 1

' Constants for get device caps
Private Const PHYSICALOFFSETX = 112
Private Const PHYSICALOFFSETY = 113
Private Const PLANES = 14
Private Const BITSPIXEL = 12

Private Const MARGIN_TOP = 1
Private Const MARGIN_BOTTOM = 2
Private Const MARGIN_LEFT = 3
Private Const MARGIN_RIGHT = 4

Private Type RECT
   Left     As Long
   Top      As Long
   Right    As Long
   Bottom   As Long
End Type

Private Declare Function CreateSolidBrush Lib "GDI32" (ByVal crColor As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long

' *** Set the toolbar to Office 97
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lparam As Long) As Long
Private Declare Function SendMessageAny Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lparam As Any) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hwndParent As Long, ByVal hWndChildWindow As Long, ByVal lpClassName As String, ByVal lpsWindowName As String) As Long
Private Const WM_USER = &H400
Private Const TB_SETSTYLE = WM_USER + 56
Private Const TB_GETSTYLE = WM_USER + 57
Private Const TBSTYLE_FLAT = &H800


Public Function CreateMaskImage(ByRef picFrom As PictureBox, ByRef picTo As PictureBox, Optional ByVal lTransparentColor As Long = -1) As Boolean
   ' *** Create a mask image (all black for the transparent colour otherwise white) from a bitmap
   
   Dim lhDC       As Long
   Dim lhBmp      As Long
   Dim lhBmpOld   As Long

   ' Make picTo the same size as picFrom and clear it:
   With picTo
      .Width = picFrom.Width
      .Height = picFrom.Height
      .Cls
   End With

   ' Create a monochrome DC & Bitmap of the
   ' same size as the source picture:
   lhDC = CreateCompatibleDC(0)
   If (lhDC <> 0) Then
      lhBmp = CreateCompatibleBitmap(lhDC, picFrom.ScaleWidth \ Screen.TwipsPerPixelX, picFrom.ScaleHeight \ Screen.TwipsPerPixelY)
      If (lhBmp <> 0) Then
         lhBmpOld = SelectObject(lhDC, lhBmp)

         ' Set the back 'colour' of the monochrome
         ' DC to the colour we wish to be transparent:
         If (lTransparentColor = -1) Then lTransparentColor = picFrom.BackColor
         SetBkColor lhDC, lTransparentColor

         ' Copy from the from picture to the monochrome DC
         ' to create the mask:
         BitBlt lhDC, 0, 0, picFrom.ScaleWidth \ Screen.TwipsPerPixelX, picFrom.ScaleHeight \ Screen.TwipsPerPixelY, picFrom.hDC, 0, 0, SRCCOPY

         ' Now put the mask into picTo:
         BitBlt picTo.hDC, 0, 0, picFrom.ScaleWidth \ Screen.TwipsPerPixelX, picFrom.ScaleHeight \ Screen.TwipsPerPixelY, lhDC, 0, 0, SRCCOPY
         picTo.Refresh

         ' Clear up the bitmap we used to create
         ' the mask:
         SelectObject lhDC, lhBmpOld
         DeleteObject lhBmp
      End If
      ' Clear up the monochrome DC:
      DeleteObject lhDC
   End If

End Function

0
 

Author Comment

by:FlyveHest
ID: 1438386
Where do your code save an actual BMP file?  It seems like it copies from one picturebox to another, but when you save the contents of a picbox in VB its ALWAYS saved as a 24bit BMP file.

Seems like your source was for creating a mask from an image, and not to save a BMP as monochrome.
0
 

Accepted Solution

by:
janeausten earned 80 total points
ID: 1438387
hi,

i asked the very same question a few months ago, and came up with  this program.

GOOD LUCK

~~~~~~~~~~~~~~~~~~~~~ MODULE
Global Pic As Object

Public Type BITMAPFILEHEADER    '14 bytes
   bfType As Integer
   bfSize As Long
   bfReserved1 As Integer
   bfReserved2 As Integer
   bfOffBits As Long
End Type

Public 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

Public Type RGBQUAD
   rgbBlue As Byte
   rgbGreen As Byte
   rgbRed As Byte
   rgbReserved As Byte
End Type

Public Type BITMAPINFO_1
   bmiHeader As BITMAPINFOHEADER
   bmiColors(1) As RGBQUAD
End Type

Public Const PIXEL As Integer = 3
Public Const DIB_RGB_COLORS As Long = 0
Public Const PALVERSION = &H300

Public Declare Function GetDIBits1 Lib "gdi32" Alias "GetDIBits" _
  (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, _
  ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO_1, _
  ByVal wUsage As Long) As Long

~~~~~~~~~~~~~~~~~~~~~~~~~ FORM
Private Sub Save1(ByVal Pic As Object)
    Dim SaveBitmapInfo_1 As BITMAPINFO_1
    Dim SaveFileHeader As BITMAPFILEHEADER
    Dim SaveBits() As Byte
    Dim BufferSize As Double
    Dim fNum As Long
    Dim Retval As Long
    Dim nLen As Long
    Const BitsPixel = 1

    'size a buffer for the pixel data
    BufferSize = ((Pic.ScaleWidth / 8 + 3) And &HFFFC) * Pic.ScaleHeight
    ReDim SaveBits(0 To BufferSize - 1)
    'fill the header info for the save copy
    With SaveBitmapInfo_1.bmiHeader
        .biSize = 40
        .biWidth = Pic.ScaleWidth
        .biHeight = Pic.ScaleHeight
        .biPlanes = 1
        .biBitCount = BitsPixel
        .biCompression = 0
        .biClrUsed = 0
        .biClrImportant = 0
        .biSizeImage = BufferSize
    End With
    nLen = Len(SaveBitmapInfo_1)
    'get the bitmap from the picturebox
    Retval = GetDIBits1(Pic.hDC, Pic.Image, 0, _
        SaveBitmapInfo_1.bmiHeader.biHeight, _
        SaveBits(0), SaveBitmapInfo_1, DIB_RGB_COLORS)

    ' create a header for the save file
    With SaveFileHeader
       .bfType = &H4D42
       .bfSize = Len(SaveFileHeader) + nLen + BufferSize
       .bfOffBits = Len(SaveFileHeader) + nLen
    End With
       
    ' save it to disk
    fNum = FreeFile
   
    Open App.Path & "MY1BITPIC.bmp" For Binary As fNum
    Put fNum, , SaveFileHeader
    Put fNum, , SaveBitmapInfo_1
    Put fNum, , SaveBits()
    Close fNum

End Sub

Private Sub cmdGenerateBMPFiles_Click()
       
    Set picCadView.Picture = LoadPicture(App.Path & "YOURPIC.BMP/WMF")
    Set Pic = picCadView
    Call Save1(Pic)
   
End Sub

0
 

Author Comment

by:FlyveHest
ID: 1438388
Couldn't you comment on how you calculate the buffersize?

Why do you divide by 8, and what are the +3 for?

Hope you can help
0
 

Expert Comment

by:janeausten
ID: 1438389
here's the answer i got for that:

(quote)
Yep: this is a tricky thing.

For 8-bit bitmaps, also make sure that your BITMAPINFO structure's
biColors() array is defined as biColors(255) As Long (or As RGBQUAD), so
there's enough room for a 256-color palette.  You can actually use this for
any color depth, and just ignore the returned values for entries greater
than those that actually apply.

Calculate the length of the lpvBits array from the bitmap width, height,
and color depth as follows:

monochrome (1 Bit/Pixel)
    BufferSize = ((eWidth / 8 + 3) And &HFFFC) * eHeight
    ReDim SaveBits(0 To BufferSize - 1)

(the "/ 8" is because we're counting bytes, but each byte in monochrome
bitmaps actually stores the color data for eight pixels)

16-color (4-bit)
    BufferSize = ((eWidth / 2 + 3) And &HFFFC) * eHeight

256-color (8-bit)
    BufferSize = ((eWidth + 3) And &HFFFC) * eHeight

16million color (24-bit)
    BufferSize = ((eWidth * 3 + 3) And &HFFFC) * eHeight
   
All bitmap scan lines are stored DWORD-aligned (for faster access, I
believe).  That means that each scan line uses an integer multiple of 4
bytes.  For example, a 16-color bitmap that is 8 pixels wide needs 4 bytes
per line (because it's four bits -- half a byte -- per pixel), but one that
is 9 pixels wide uses 8 bytes per line because that's the next allowable
length.  The unused bytes are simply ignored.

When I first learned this fact, I wrote a straightforward, easy to
understand function that returned the proper number of bytes given the
color depth and bitmap width.  It was, oh, I don't know, maybe a dozen
lines.  Since then I've seen it done in a single line, but I couldn't make
heads or tails of it.

The four lines I gave you (one for each color depth) seems like a decent
compromise.  The +3 ensures that you get up to the next boundary, and the
"And &HFFFC" zeroes out the two least significant digits in the binary
representation of the number, ensuring that the result has no 1's and no
2's, and is therefore evenly divisible by 4.

(unquote)

Jim Deutch
MS Dev MVP

hope this helps

jane
0

Featured Post

6 Surprising Benefits of Threat Intelligence

All sorts of threat intelligence is available on the web. Intelligence you can learn from, and use to anticipate and prepare for future attacks.

Join & Write a Comment

Introduction In a recent article (http://www.experts-exchange.com/A_7811-A-Better-Concatenate-Function.html) for the Excel community, I showed an improved version of the Excel Concatenate() function.  While writing that article I realized that no o…
Enums (shorthand for ‘enumerations’) are not often used by programmers but they can be quite valuable when they are.  What are they? An Enum is just a type of variable like a string or an Integer, but in this case one that you create that contains…
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…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…

758 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

21 Experts available now in Live!

Get 1:1 Help Now