Сохранить bmp с глубиной цвета 1 bpp

[eVe]

В пикчербокс я кидаю бмп-файл, перевожу его в черно-белый и сохраняю на диске. Но глубина цвета у него остается 24 bpp, т.е. true-color, что сказывается на размере. Мне же необходимо, чтобы он был 1 bpp. Как можно это сделать?
Спасибо заранее

[tyomitch]

Код: Выделить всё

Option Explicit
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) 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 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 Type Guid
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
Private Type PICTDESC
    Size As Long
    Type As Long
    hBmp As Long
    hPal As Long
    reserved As Long
End Type
Private Declare Function OleCreatePictureIndirect Lib "olepro32" (lpPictDesc As PICTDESC, riid As Guid, ByVal fOwn As Long, lplpvObj As IPicture) As Long

Private Sub Command1_Click()
Dim hDC As Long, hBmp As Long, hBmpOld As Long
Picture1.ScaleMode = vbPixels
Picture1.BackColor = vbWhite

hDC = CreateCompatibleDC(Picture1.hDC)
hBmp = CreateBitmap(Picture1.ScaleWidth, Picture1.ScaleHeight, 1, 1, ByVal 0&)
hBmpOld = SelectObject(hDC, hBmp)
BitBlt hDC, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, Picture1.hDC, 0, 0, vbSrcCopy
SelectObject hDC, hBmpOld
DeleteDC hDC
Set Picture1.Picture = CreatePictureFromBitmap(hBmp)

SavePicture Picture1.Picture, "c:\temp.bmp"
End Sub

Private Function CreatePictureFromBitmap(ByVal hBmp As Long) As StdPicture
Dim Pic As PICTDESC, IID_IDispatch As Guid
    With IID_IDispatch
       .Data1 = &H20400
       .Data4(0) = &HC0
       .Data4(7) = &H46
    End With
    With Pic
       .Size = Len(Pic)
       .Type = vbPicTypeBitmap
       .hBmp = hBmp
       .hPal = 0
    End With
    OleCreatePictureIndirect Pic, IID_IDispatch, 1, CreatePictureFromBitmap
End Function


[TEH3OP]

Хех... уже ответили... ну лана...

[eVe]

Спасибо большое за оперативную помощь - все очень классно работает. Ступор для меня был конкретный. Пасиба!