'================================================================
'= 表示できる色に最も近いカラー値を取得
'=    (GetNearestColor.bas)
'================================================================
#include "Windows.bi"

' 指定のカラー値に対して、デバイスが表示できる色に最も近いカラー値を取得
Declare Function Api_GetNearestColor& Lib "gdi32" Alias "GetNearestColor" (ByVal hDC&, ByVal crColor&)

' 指定のオブジェクトのタイプを取得
Declare Function Api_GetObjectType& Lib "gdi32" Alias "GetObjectType" (ByVal hgdiobj&)

' 指定されたデバイスコンテキストに関連するデバイスと互換性のあるメモリデバイスコンテキストを作成
Declare Function Api_CreateCompatibleDC& Lib "gdi32" Alias "CreateCompatibleDC" (ByVal hDC&)

' 指定された幅・高さ・色形式を持つビットマップを作成
Declare Function Api_CreateBitmap& Lib "gdi32" Alias "CreateBitmap" (ByVal nWidth&, ByVal nHeight&, ByVal nPlanes&, ByVal nBitCount&, lpBits As Any)

' 指定されたデバイスコンテキストのオブジェクトを選択
Declare Function Api_SelectObject& Lib "gdi32" Alias "SelectObject" (ByVal hDC&, ByVal hObject&)

' 論理オブジェクトを削除し、そのオブジェクトに関連付けられていたすべてのシステムリソースを解放
Declare Function Api_DeleteObject& Lib "gdi32" Alias "DeleteObject" (ByVal hObject&)

' 指定されたデバイスコンテキストを削除
Declare Function Api_DeleteDC& Lib "gdi32" Alias "DeleteDC" (ByVal hDC&)

' 指定されたウィンドウのクライアント領域または画面全体を表すディスプレイデバイスコンテキストのハンドルを取得
Declare Function Api_GetDC& Lib "user32" Alias "GetDC" (ByVal hWnd&)

' デバイスコンテキストを解放
Declare Function Api_ReleaseDC& Lib "user32" Alias "ReleaseDC" (ByVal hWnd&, ByVal hDC&)

#define OBJ_BITMAP 7                    'ビットマップ
#define OBJ_BRUSH 2                     'ブラシ
#define OBJ_DC 3                        'デバイスコンテキスト
#define OBJ_ENHMETADC 12                '拡張メタファイルのデバイスコンテキスト
#define OBJ_ENHMETAFILE 13              '拡張メタファイル
#define OBJ_EXTPEN 11                   '拡張ペン
#define OBJ_FONT 6                      'フォント
#define OBJ_MEMDC 10                    'メモリデバイスコンテキスト
#define OBJ_METADC 4                    'メタファイルのデバイスコンテキスト
#define OBJ_METAFILE 9                  'メタファイル
#define OBJ_PAL 5                       'パレット
#define OBJ_PEN 1                       'ペン
#define OBJ_REGION 8                    '領域
#define vbYellow &H00FFFF               '黄色のカラーコード

Var Shared Text1 As Object
Var Shared Text2 As Object
Var Shared Button1 As Object

Text1.Attach GetDlgItem("Text1") : Text1.SetFontSize 14
Text2.Attach GetDlgItem("Text2") : Text2.SetFontSize 14
Button1.Attach GetDlgItem("Button1") : Button1.SetFontSize 14

'================================================================
'=
'================================================================
Declare Sub Button1_on edecl ()
Sub Button1_on()
    Var hDC As Long
    Var nDC As Long
    Var nBitmap As Long
    Var MyStr As String
    Var Ret As Long

    '親ウィンドウのデバイスコンテキストを取得
    hDC = Api_GetDC(GethWnd)

    'デバイスコンテキストを作成
    nDC = Api_CreateCompatibleDC(hDC)

    'ビットマップを作成
    nBitmap = Api_CreateBitmap(10, 10, 1, 1, ByVal 0)

    'オブジェクトを選択
    Ret = Api_SelectObject(nDC, nBitmap)

    'オブジェクトタイプを取得
    Select Case Api_GetObjectType(nBitmap)
        Case OBJ_BITMAP
            MyStr = "Object Type: Bitmap"
        Case OBJ_BRUSH
            MyStr = "Object Type: Brush"
        Case OBJ_FONT
            MyStr = "Object Type: Font"
        Case OBJ_PAL
            MyStr = "Object Type: Pal"
        Case OBJ_PEN
            MyStr = "Object Type: Pen"
        Case OBJ_EXTPEN
            MyStr = "Object Type: ExtPen"
        Case OBJ_REGION
            MyStr = "Object Type: Region"
        Case OBJ_DC
            MyStr = "Object Type: Device Context"
        Case OBJ_MEMDC
            MyStr = "Object Type: Memory Device Context"
        Case OBJ_METAFILE
            MyStr = "Object Type: Metafile"
        Case OBJ_METADC
            MyStr = "Object Type: Metafile DC"
        Case OBJ_ENHMETAFILE
            MyStr = "Object Type: Enhanched Meatfile"
        Case OBJ_ENHMETADC
            MyStr = "Object Type: Enhanched Meatfile DC"
    End Select

    'オブジェクトタイプを表示
    Text1.SetWindowText MyStr

    '最も近いカラー値を取得
    Text2.SetWindowText "Nearest Color: &&H" & Hex$(Api_GetNearestColor(nDC, vbYellow))

    '解放
    Ret = Api_DeleteDC(nDC)
    Ret = Api_DeleteObject(nBitmap)
    Ret = Api_ReleaseDC(GethWnd, hDC)
End Sub

'================================================================
'=
'================================================================
While 1
    WaitEvent
Wend
Stop
End