下記サンプルは2002年11月６日に書いたコードのコピペになる。P-Codeコンパイルの実行ファイルだと正常に動作するが、ネイティブコードの実行ファイルでは変換の色具合が変であった。

Private Type BITMAPFILEHEADER
    bfType As Integer       'この構造体のタイプ
    bfSize As Long          'この構造体のサイズ
    bfReserved1 As Integer  '予約、常に０
    bfReserved2 As Integer  '予約、常に０
    bfOffBits As Long       'この構造体からビットマップデータまでのオフセット
End Type

Private Type BITMAPINFOHEADER
    biSize As Long          'この構造体のサイズ
    biWidth As Long         'ピクセルデータの幅
    biHeight As Long        'ピクセルデータの高さ
    biPlanes As Integer     'カラープレーンの高さ
    biBitCount As Integer   'ピクセルあたりのビット数(1,4,8,24のどれか)
    biCompression As Long   'ピクセルデータの圧縮形式
    biSizeImage As Long     'ピクセルデータのサイズ
    biXPelsPerMeter As Long '１mあたりの水平解像度
    biYPelsPerMeter As Long '１mあたりの垂直解像度
    biClrUsed As Long       '使用するカラーインデックスの数
    biClrImportant As Long  '表示に使用するカラーインデックスの数(通常は０)
End Type

'オブジェクトの種類を表す128ビット値
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type


'API関数 OleCreatePictureIndirect で使用する構造体
Private Type BITMAPPICTDESC
    cbSizeOfStruct As Long   '構造対のサイズ
    nPictType As PictureTypeConstants            '保持するハンドルの種類
    hBitMap As Long          'ビットマップのハンドル
    hPalette As Long         'パレットのハンドル
    OptionValue As Long      '０
End Type



'ハンドルからピクチャーオブジェクトに変換する
Private Declare Function OleCreatePictureIndirect Lib "Olepro32.dll" (ByRef lpPictDesc As BITMAPPICTDESC, _
                                           ByRef riid As GUID, ByRef fOwn As Long, ByRef pctRet As Picture) 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 SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long

'デバイスと互換性のあるデバイスコンテキストを作成する
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long

'デバイスコンテキストを破棄する
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long

'DIBを作成する
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hDC As Long, pBitmapInfo As Any, ByVal un As Long, _
                                         ByRef lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long

'DIBカラーテーブルを作成する
Private Declare Function SetDIBColorTable Lib "gdi32" (ByVal hDC As Long, ByVal un1 As Long, _
                                         ByVal un2 As Long, pcRGBQuad As OLE_COLOR) As Long


Public Const NO_ERROR As Integer = 0           '正常終了
Public Const ERR_NOT_BITMAP As Integer = 1     'ビットマップではない
Public Const ERR_NOT_FC_BITMAP As Integer = 2  'フルカラーのビットマップデータではない
                                               'SavePicture で保存すること
Public Const ERR_MAKE_DC As Integer = 3        'デバイスコンテキスト作成に失敗
Public Const ERR_CREATE_DIB_SEC As Integer = 4 'DIBビットマップ作成失敗
Public Const ERR_COLOR_OVER As Integer = 5     '色数が256色を超えている
Public Const ERR_OTHER_CASE As Integer = 6     'その他のエラー


'-------------------------------------------------------------------
' 機  能：ビットマップを２色(白黒)に変換する
' 引  数：(i) hDC ： ビットマップのデバイスコンテキストのハンドル
'          (i/o) ctrBitmap ： 変換のビットマップを表示するピクチャーボックス
' 返り値：定数各種
'-------------------------------------------------------------------
Public Function ConvertBitmap(ByVal hDC As Long, ByRef ctrBitmap As PictureBox) As Integer

    Dim udtGUID As GUID       'オブジェクトの種類を表す128ビット値の構造体
    Dim udtBFileHeader As BITMAPFILEHEADER 'ビットマップファイルヘッダー
    Dim udtBInfoHeader As BITMAPINFOHEADER 'ビットマップヘッダー
    Dim udtBitmapPicDesc As BITMAPPICTDESC 'ピクチャーオブジェクトを作成する

    Dim NewhDC As Long      'デバイスコンテキストのハンドル
    Dim hBitMap As Long     'ビットマップのハンドル
    Dim pBits As Long       'API関数用引数
    Dim hOldObj As Long     '以前のオブジェクトのハンドル

    Dim ObjPicture As Picture 'ピクチャーオブジェクト
    Dim OldScaleMode As Long  'ピクチャーボックスのScaleMode

    On Error GoTo ErrHandler

    'ピクチャーボックスをピクセル単位にする
    OldScaleMode = ctrBitmap.ScaleMode
    ctrBitmap.ScaleMode = vbPixels

    'デバイスと互換性のあるデバイスコンテキストを作成する
    NewhDC = CreateCompatibleDC(hDC)

    With udtBInfoHeader
        .biSize = Len(udtBInfoHeader)
        .biWidth = ctrBitmap.Width
        .biHeight = ctrBitmap.Height
        .biPlanes = 1   '常に１
        .biBitCount = 1 '変換する色数
    End With

    'ビットマップ作成
    hBitMap = CreateDIBSection(NewhDC, udtBInfoHeader, 0, pBits, 0, 0)

    'エラーハンドリング
    If hBitMap = 0 Then
        ConvertBitmap = ERR_CREATE_DIB_SEC
        Exit Function
    End If

    'ビットマップをセット
    hOldObj = SelectObject(NewhDC, hBitMap)

    'DIBカラーテーブルを作成する
    Call SetDIBColorTable(NewhDC, 1, 1, vbWhite)

    'ビットマップを転送する
    Call BitBlt(NewhDC, 0, 0, udtBInfoHeader.biWidth, udtBInfoHeader.biHeight, hDC, 0, 0, vbSrcCopy)

    'オブジェクトを削除する
    Call SelectObject(NewhDC, hOldObj)
    Call DeleteDC(NewhDC)

    'OleCreatePictureIndirect の引数用構造体
    With udtBitmapPicDesc
        .cbSizeOfStruct = Len(udtBitmapPicDesc)
        .nPictType = vbPicTypeBitmap
        .hBitMap = hBitMap
    End With

    'オブジェクトの種類を表す
    With udtGUID
        .Data1 = &H7BF80981
        .Data2 = &HBF32
        .Data3 = &H101A
        .Data4(0) = &H8B
        .Data4(1) = &HBB
        .Data4(2) = &H0
        .Data4(3) = &HAA
        .Data4(4) = &H0
        .Data4(5) = &H30
        .Data4(6) = &HC
        .Data4(7) = &HAB
    End With

    'ハンドルからピクチャーオブジェクトに変換する
    Call OleCreatePictureIndirect(udtBitmapPicDesc, udtGUID, 1, ObjPicture)

    'ピクチャーボックスを２色にする
    Set ctrBitmap.Picture = ObjPicture

    Set ObjPicture = Nothing

    'ピクチャーボックスのScaleModeを元に戻す
    ctrBitmap.ScaleMode = OldScaleMode

    '正常終了
    ConvertBitmap = NO_ERROR
Normal_Exit:
    Exit Function

ErrHandler:
    Call MsgBox("ｴﾗｰNo." & Err.Number & vbCrLf & vbCrLf & _
            Err.Description, vbExclamation, "２色変換 - エラー")
    ConvertBitmap = ERR_OTHER_CASE
End Function