GDIplusCODE


	
'☆UserForm1モジュール - コマンドボタンを一個置く
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hndw As Long) As Boolean

Dim myPalette As Class1
Dim ccHwnd As Long

Private Sub CommandButton1_Click()
  Me.CommandButton1.BackColor = myPalette.colorCode
End Sub

Private Sub UserForm_Initialize()
  Set myPalette = New Class1
  Set myPalette.parent = Me
  Set myPalette.dataSheet = ThisWorkbook.Sheets(1)
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
  Dim lngRet As Long
  
  'Dialogが消えないままUserFormを消した時の対策
  'Dialogが消える時まで,Class1のterminateが実行されない様である 
  ccHwnd = FindWindow(vbNullString, "色の設定")
  If ccHwnd Then DestroyWindow (ccHwnd)
  Set myPalette = Nothing
End Sub

'☆Class1 モジュール
Option Explicit

'========================================================
'色選択のダイアログを表示して、色コードを取得するクラス
'クラスの中ではdeclare function,type 共にprivateに設定する必要あり
'プロパティ　colorCode　に色のコードを与える
  
'------ C ------
'Color_Choose関数
Private Declare Function Color_Choose Lib "comdlg32.dll" Alias "ChooseColorA" _
                                (pChoosecolor As YCHOOSECOLOR) As Long
Private Type YCHOOSECOLOR
    lStructSize As Long 'この構造体の長さ
    hwndOwner As Long 'ダイアログボックスを持つウインドウハンドル
    hInstance As Long 'モジュールのインスタンスハンドル
    rgbResult As Long '呼び出す前は初期色、終了時は、ユーザーが選択した色
    lpCustColors As Long 'カスタムカラーの配列のポインタ
    flags As Long '初期化フラグ
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type
 
'Color_Choose flagsの定数
Private Const CC_ANYCOLOR = &H100 '使用可能な全ての色を表示する
Private Const CC_ENABLEHOOK = &H10 'フックプロシージャを使う
Private Const CC_ENABLETEMPLATE = &H20 'テンプレートを使う
Private Const CC_ENABLETEMPLATEHANDLE = &H40 'hInstanceを有効にする
Private Const CC_FULLOPEN = &H2 '色作成部分も表示
Private Const CC_PREVENTFULOPEN = &H4 '色作成部分は表示しない
Private Const CC_RGBINIT = &H1 'rgbResultで指定したカラー値をデフォルトにする
Private Const CC_SHOWHELP = &H8 'ヘルプボタンをつける
Private Const CC_SOLDCOLOR = &H80 'ソリッドカラーのみ選択可能にする
 
'------ G ------
'GlobalAlloc関数 ＝＞メモリブロックを確保してそのハンドルを取得
'引数　wFlags：定数（GHND_××参照）,dwBytes:確保するバイト数
'戻り値 メモリブロックのハンドル
'＊使用後はGlobalFreeで解放すること
Private Declare Function GlobalAlloc Lib "kernel32" _
                    (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Const GMEM_MOVEABLE = &H2       '利用可能なメモリを確保
Private Const GMEM_ZEROINIT = &H40        '新しく確保するメモリブロックの内容を0で初期化
Private Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)
 
'GlobalFree関数＝＞メモリブロックのロックを解放する
'引数 hMem: メモリブロックのハンドル
'戻り値 正常終了0
'＊メモリブロックのハンドルはGlobalAllocで取得

Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
'GlobalLock関数 ＝＞グローバルヒープに確保されたメモリブロックをロックする
'引数 hMem: GlobalAllocで戻ったハンドル
'戻り値: メモリブロックの先頭を示すアドレス
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long

'GlobalUnlock関数＝＞メモリブロックのロックを解除する
'引数 hMem: グローバルメモリブロックのハンドル
'戻り値: 解除された時0
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long

'------ M ------
'MoveMemory関数＝＞メモリの指定領域をコピーする
'引数 Dest: コピー先のポインタ,source: コピー元のポインタ,length: コピーするバイト数
'戻り値: なし
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" _
            (Destination As Any, Source As Any, ByVal length As Long)
'------ W ------
'Retrieves the window handle that corresponds to a particular instance of an IAccessible interface.
Private Declare Function WindowFromObject Lib "oleacc" Alias "WindowFromAccessibleObject" (ByVal pacc As Object, phwnd As Long) As Long

Private myColorCode As Long
Private col As YCHOOSECOLOR
Private custcol(15) As Long
Private memhandle As Long
Private colorAddress As Long
Private colorsize As Long
Private myColorDataSheet As Worksheet
Private parentHwnd As Long
    
'==============================================
'色指定のダイアログボックスを呼び出す関数
Private Function ColorDialog(ByRef color As Long) As Long
  '戻り値は、1の場合は色の選択、0の場合はキャンセルボタンのクリックになります。
    '引数colorに選択された色コードをセットします。
    Dim longret2 As Long
    
    '参照渡しで色を取得するので、これは成功したかどうかを示す戻り値
    longret2 = 0

     '⑥コモンダイアログを表示
    'Color_Choose関数の戻り値をlongret2に得る
    longret2 = Color_Choose(col)
 
    '取得した色は、YCHOOSECOLOR構造体のrgbResultに得られる
    color = col.rgbResult
    'Color_Choose関数の戻り値をを戻す 0:キャンセル、1:色が選択された
    ColorDialog = longret2
End Function
'==============================================
'ダイアログを表示して、色コードを取得する
Public Property Get colorCode() As Long
    Dim ret As Long
 
    ret = ColorDialog(myColorCode)
    colorCode = myColorCode
End Property

Private Sub Class_Initialize()
  '戻り値は、1の場合は色の選択、0の場合はキャンセルボタンのクリックになります。
    '引数colorに選択された色コードをセットします。
    Dim longret As Long
    Dim i As Integer
    Dim rescol As Long
 
    rescol = 0
    '①カスタムカラーに必要なメモリのサイズを取得
    '白で初期化。。
    For i = 0 To 15
        'BGRである。
        custcol(i) = &HFFFFFF
    Next
    'カスタムカラーを設定してみる Web Safe Colorで検索すると親切なサイトが多々ある
'    custcol(1) = RGB(&HCC, &HCC, &HFF)
    colorsize = Len(custcol(0)) * 16
    '②カスタムカラーのメモリブロックを確保
    'こんな面倒をしないで、VarPtrで済ましているコードもある
    
    'メモリーブロックを確保して、ハンドルを取得
    memhandle = GlobalAlloc(GHND, colorsize)
    'ハンドルが取得できたときの処理
    If memhandle Then
        '③カスタムカラーののグローバルメモリブロックロックする
        'メモリーブロックをロックして、先頭アドレスを取得
         colorAddress = GlobalLock(memhandle)
         If colorAddress Then
            '④配列からメモリブロックにコピーする
            Call MoveMemory(ByVal colorAddress, custcol(0), colorsize)
            '⑤YCHOOSECOLOR構造体に値をセット
            With col
                .lStructSize = Len(col)
                .hwndOwner = parentHwnd
                .hInstance = 0&
                .rgbResult = rescol
                .lpCustColors = colorAddress
                .flags = CC_RGBINIT Or CC_ANYCOLOR
                .lCustData = 0&
                .lpfnHook = 0&
                .lpTemplateName = 0&
            End With
        Else
            longret = GlobalFree(memhandle)
        End If
    End If
End Sub

Private Sub Class_Terminate()
  Dim longret As Long
  Dim i As Long
  Dim strColor As String
  
  'カスタムカラーを配列に書き戻す
  Call MoveMemory(custcol(0), ByVal colorAddress, colorsize)
  If Not myColorDataSheet Is Nothing Then
    With myColorDataSheet
      For i = 0 To 15
        .Cells(i + 1, 1).Value = Right("000000" & Hex(custcol(i)), 6)
      Next i
    End With
  End If
  '⑦メモリロック解除
  longret = GlobalUnlock(memhandle)
  '⑧メモリ解放
  longret = GlobalFree(memhandle)
End Sub

Public Property Set dataSheet(newSheet As Worksheet)
  Dim i As Long

  Set myColorDataSheet = newSheet
  '最小限のエラー処理
  If myColorDataSheet.Cells(1).Value <> "" Then
    With myColorDataSheet
      For i = 0 To 15
        custcol(i) = CLng("&H" & .Cells(i + 1, 1).Value)
      Next i
    End With
    '配列からメモリブロックにコピーする
    Call MoveMemory(ByVal colorAddress, custcol(0), colorsize)
  End If
End Property

Public Property Set parent(newObject As Object)
  Dim lngRet As Long
  
  lngRet = WindowFromObject(newObject, parentHwnd)
End Property
色指定のダイアログを表示して色を取得
