はっきり言ってよく分からないコードになっている。OSによっては動かないかもしれない。

Private Type ICONINFO
    fIcon As Long
    xHotspot As Long
    yHotspot As Long
    hbmMask As Long
    hbmColor As Long
End Type

Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type

'デバイスコンテキストを取得する
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 CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long

'オブジェクトの描画対象を設定・選択する
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long

'指定したDCにあるBMPと互換のビットマップオブジェクトを作成する
'Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight 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 SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor 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 SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long

'アイコンに変換し、ハンドルを返す
Private Declare Function CreateIconIndirect Lib "user32" (piconinfo As ICONINFO) 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 GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long

Private Const IMAGE_BITMAP = 0
Private Const IMAGE_ICON = 1
Private Const IMAGE_CURSOR = 2
Private Const IMAGE_ENHMETAFILE = 3

'---------------------------------------------------------------------------
' 関数名： CreateIconFromBitmap
' 機能  ： ビットマップハンドルからアイコンを作る
' 引数  ： (in)hBitmap … ビットマップハンドル
' 返り値： アイコンのハンドル
'---------------------------------------------------------------------------
Public Function CreateIconFromBitmap(ByVal hBitmap As Long) As Long

    Dim hDesktopDC As Long           'デスクトップのデバイスコンテキスト
    Dim hDCColor&, hDCMask As Long   '作成するデバイスコンテキスト
    Dim hNewColor&, hNewMask As Long '作成するイメージのハンドル
    Dim OldhNewColor&, OldhNewMask As Long '変更前のハンドル
    Dim udtICONINFO As ICONINFO
    Dim i As Long
    Dim ICON_WIDTH, ICON_HEIGHT As Long

    'アイコンの幅・高さ
    ICON_WIDTH = 16: ICON_HEIGHT = 16

#If 1 Then
    Dim udtBITMAP As BITMAP

    'ビットマップのサイズ取得
    Call GetObject(hBitmap, Len(udtBITMAP), udtBITMAP)

    ICON_WIDTH = udtBITMAP.bmWidth
    ICON_HEIGHT = udtBITMAP.bmHeight
#End If

    'hDC取得
    hDesktopDC = GetDC(0&)

    '転送先ビットマップ作成
    hDCColor = CreateCompatibleDC(hDesktopDC)
    hNewColor = CopyImage(hBitmap, IMAGE_BITMAP, ICON_WIDTH, ICON_HEIGHT, 0&)
    OldhNewColor = SelectObject(hDCColor, hNewColor)

    'マスク用ビットマップ作成
    hDCMask = CreateCompatibleDC(hDesktopDC)
    hNewMask = CreateBitmap(ICON_WIDTH, ICON_HEIGHT, 1, 1, ByVal 0&)
    'hNewMask = CreateCompatibleBitmap(hDCMask, IconWidth, IconWidth)
    OldhNewMask = SelectObject(hDCMask, hNewMask)

    '背景をマスクカラーに設定(無くても動く？)
    'Call SetBkColor(hDCColor, MaskColor)

    '準備は整った!! マスク用にビットブリット発動!!
    'WinNT系？
    Call BitBlt(hDCMask, 0, 0, ICON_WIDTH, ICON_HEIGHT, hDCColor, 0, 0, vbSrcCopy)
    'Win95はこれで良かった↓
    'Call BitBlt(hDCMask, 0, 0, ICON_WIDTH, ICON_HEIGHT, hDCColor, 0, 0, vbSrcAnd)

    '転送先のビットマップを設定
    Call SetBkColor(hDCColor, vbBlack)         '背景セット
    Call SetTextColor(hDCColor, &HFFFFFF)      '文字色セット

    'マスク処理
    Call BitBlt(hDCColor, 0, 0, ICON_WIDTH, ICON_HEIGHT, hDCMask, 0, 0, vbSrcAnd)

    'オブジェクトを元に戻す
    Call SelectObject(hDCColor, OldhNewColor)
    Call SelectObject(hDCMask, OldhNewMask)

    'アイコンの設定もしないとね
    With udtICONINFO
        .fIcon = True
        .xHotspot = 0
        .yHotspot = 0
        .hbmColor = hNewColor
        .hbmMask = hNewMask
    End With

    'ビットマップ→アイコン変換
    CreateIconFromBitmap = CreateIconIndirect(udtICONINFO)

    '後処理
    Call DeleteObject(hNewColor)
    Call DeleteDC(hDCColor)
    Call DeleteObject(hNewMask)
    Call DeleteDC(hDCMask)
    Call ReleaseDC(0, hDesktopDC)

End Function

フォームの AutoRedraw プロパティを True にし、ボタンとピクチャーボックスを配置する。ピクチャーボックスには適当な16Ｘ16の画像を設定する。そうしたら以下のコードを書く。ボタンを押すと32×32サイズのアイコンが表示されるはず。

Private Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal hIcon As Long) As Long

Private Sub Command1_Click()
    Dim hIcon As Long
    hIcon = CreateIconFromBitmap(Picture1.Picture.handle)
    Call DrawIcon(Me.hdc, 0, 0, hIcon)
    Me.Refresh
End Sub