I've got a picture property on my activex, sometimes I need to show it
in monochrome, any idea?

    Thanks in advance, Saeid

--

S.Azish, Development Manager
System Advance Ltd.
64 ST MARKS ROAD
ENFIELD, LONDON, UK
EN1 1BB
Tel.: (+44)-020 8364 5600
Fax: (+44)-020 8342 0034

'***
Private Declare Function CreateDIBSection1 Lib "gdi32" _
    Alias "CreateDIBSection" (ByVal hdc As Long, _
    pBitmapInfo As BITMAPINFO1, ByVal un As Long, _
    ByVal lplpVoid As Long, ByVal handle As Long, _
    ByVal dw 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 DeleteObject Lib "gdi32" _
    (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" _
    (ByVal hdc As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetDC Lib "user32" _
    (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" _
    (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" _
    (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" _
    (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" _
    (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function SetBkColor Lib "gdi32" _
    (ByVal hdc As Long, ByVal crColor As Long) As Long

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

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

Private Type BITMAPINFO1
    bmiHeader As BITMAPINFOHEADER
    bmiColors(1) As RGBQUAD
End Type

Private Sub Form_Load()
    Dim DeskWnd As Long, DeskDC As Long
    Dim MyDC As Long
    Dim MyDIB As Long, OldDIB As Long
    Dim DIBInf As BITMAPINFO1

    'Persist drawing
    Picture1.AutoRedraw = True

    'Create DC based on desktop DC
    DeskWnd = GetDesktopWindow()
    DeskDC = GetDC(DeskWnd)
    MyDC = CreateCompatibleDC(DeskDC)
    ReleaseDC DeskWnd, DeskDC

    'Validate DC
    If (MyDC = 0) Then Exit Sub

    'Set DIB information
    With DIBInf
        With .bmiHeader 'Same size as picture
            .biWidth = Picture1.ScaleX( _
                Picture1.ScaleWidth, Picture1.ScaleMode, vbPixels)
            .biHeight = Picture1.ScaleY( _
                Picture1.ScaleHeight, Picture1.ScaleMode, vbPixels)
            .biBitCount = 1
            .biPlanes = 1
            .biClrUsed = 2
            .biClrImportant = 2
            .biSize = Len(DIBInf.bmiHeader)
        End With

        ' Palette is Black ...
        With .bmiColors(0)
            .rgbRed = &H0
            .rgbGreen = &H0
            .rgbBlue = &H0
        End With

        ' ... and white
        With .bmiColors(1)
            .rgbRed = &HFF
            .rgbGreen = &HFF
            .rgbBlue = &HFF
        End With
    End With

    ' Create the DIBSection
    MyDIB = CreateDIBSection1(MyDC, DIBInf, 0, ByVal 0&, 0, 0)

    If (MyDIB) Then ' Validate and select DIB
        OldDIB = SelectObject(MyDC, MyDIB)

        ' Draw original picture to
        BitBlt MyDC, 0, 0, DIBInf.bmiHeader.biWidth, _
            DIBInf.bmiHeader.biHeight, Picture1.hdc, 0, 0, vbSrcCopy
        BitBlt Picture1.hdc, 0, 0, DIBInf.bmiHeader.biWidth, _
            DIBInf.bmiHeader.biHeight, MyDC, 0, 0, vbSrcCopy
        SelectObject MyDC, OldDIB
        DeleteObject MyDIB
    End If

    DeleteDC MyDC

    Picture1.Refresh
End Sub
'***

This will convert the Picture1 to monochrome.  If you just want to convert
the picture to monochrome then you can create a second DC and select the
picture into that, this will also work if your image is in an StdPicture
object rather than coming from a picture box.
Hope this helps,

    Mike

 -- EDais --

 - Microsoft Visual Basic MVP -
WWW: http://www.*-*-*.com/

'***
        ...
        ' Draw original picture to the monocrome DC and map to palette
        BitBlt MyDC, 0, 0, DIBInf.bmiHeader.biWidth, _
            DIBInf.bmiHeader.biHeight, Picture1.hdc, 0, 0, vbSrcCopy
        ' Draw the monochome image back to the picture box
        BitBlt Picture1.hdc, 0, 0, DIBInf.bmiHeader.biWidth, _
            DIBInf.bmiHeader.biHeight, MyDC, 0, 0, vbSrcCopy

        ' Clean up DIB
        SelectObject MyDC, OldDIB
        DeleteObject MyDIB
    End If

    ' Clean up DC
    DeleteDC MyDC

    ' Redraw on screen
    Picture1.Refresh
End Sub
'***

That's better *g* - Ah, it's been a long week already!..

    Mike

 -- EDais --

 - Microsoft Visual Basic MVP -
WWW: Http://EDais.earlsoft.co.uk/

That's greyscale, not monochrome :)
Here's the code converted to create a greyscale version instead:

'***
Private Declare Function CreateDIBSection8 Lib "gdi32" _
    Alias "CreateDIBSection" (ByVal hdc As Long, _
    pBitmapInfo As BITMAPINFO8, ByVal un As Long, _
    ByVal lplpVoid As Long, ByVal handle As Long, _
    ByVal dw 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 DeleteObject Lib "gdi32" _
    (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" _
    (ByVal hdc As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetDC Lib "user32" _
    (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" _
    (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" _
    (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" _
    (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" _
    (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function SetBkColor Lib "gdi32" _
    (ByVal hdc As Long, ByVal crColor As Long) As Long

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

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

Private Type BITMAPINFO8
    bmiHeader As BITMAPINFOHEADER
    bmiColors(255) As RGBQUAD
End Type

Private Sub Form_Load()
    Dim DeskWnd As Long, DeskDC As Long
    Dim MyDC As Long
    Dim MyDIB As Long, OldDIB As Long
    Dim DIBInf As BITMAPINFO8
    Dim MakePal As Long

    ' Persist drawing
    Picture1.AutoRedraw = True

    ' Create DC based on desktop DC
    DeskWnd = GetDesktopWindow()
    DeskDC = GetDC(DeskWnd)
    MyDC = CreateCompatibleDC(DeskDC)
    ReleaseDC DeskWnd, DeskDC

    ' Validate DC
    If (MyDC = 0) Then Exit Sub

    ' Set DIB information
    With DIBInf
        With .bmiHeader ' Same size as picture
            .biWidth = Picture1.ScaleX( _
                Picture1.ScaleWidth, Picture1.ScaleMode, vbPixels)
            .biHeight = Picture1.ScaleY( _
                Picture1.ScaleHeight, Picture1.ScaleMode, vbPixels)
            .biBitCount = 8
            .biPlanes = 1
            .biClrUsed = 256
            .biClrImportant = 256
            .biSize = Len(DIBInf.bmiHeader)
        End With

        ' Palette is Greyscale
        For MakePal = 0 To 255
            With .bmiColors(MakePal)
                .rgbRed = MakePal
                .rgbGreen = MakePal
                .rgbBlue = MakePal
            End With
        Next MakePal
    End With

    ' Create the DIBSection
    MyDIB = CreateDIBSection8(MyDC, DIBInf, 0, ByVal 0&, 0, 0)

    If (MyDIB) Then ' Validate and select DIB
        OldDIB = SelectObject(MyDC, MyDIB)

        ' Draw original picture to the greyscale DIB
        BitBlt MyDC, 0, 0, DIBInf.bmiHeader.biWidth, _
            DIBInf.bmiHeader.biHeight, Picture1.hdc, 0, 0, vbSrcCopy

        ' Draw the greyscale image back to the picture box
        BitBlt Picture1.hdc, 0, 0, DIBInf.bmiHeader.biWidth, _
            DIBInf.bmiHeader.biHeight, MyDC, 0, 0, vbSrcCopy

        ' Clean up DIB
        SelectObject MyDC, OldDIB
        DeleteObject MyDIB
    End If

    ' Clean up DC
    DeleteDC MyDC

    ' Redraw on screen
    Picture1.Refresh
End Sub
'***

Hope this helps,

    Mike

 -- EDais --

 - Microsoft Visual Basic MVP -
WWW: http://www.*-*-*.com/

    Perfect Mate!

Saeid

    Mike

 -- EDais --

 - Microsoft Visual Basic MVP -
WWW: Http://EDais.earlsoft.co.uk/