none
ACCESS2016(64)でのChooseColor(comdlg32.dll)について RRS feed

  • 質問

  • いつも参考にさせていただいています。

    win8.1/Access2016で動作させるので元々あった32bit dll呼び出しソースに対し、システム条件分岐修正を行いました。

    win8.1/Access2016で動作させたのですが、色選択ダイアログが表示されません。

    Access2016(32bit)では”longret2 = ChooseColor(COL)”でダイアログが表示されています。

    原因、対応方法が分からない状態です、ご教授いただけませんでしょうか。


    '(Standerd Module)---------------------------------------------------------------------------------------------

    #If VBA7 And Win64 Then
    '「色指定」コモンダイアログを呼び出す
        Declare PtrSafe Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As YCHOOSECOLOR) As Long
    #Else
    '「色指定」コモンダイアログを呼び出す
        Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As YCHOOSECOLOR) As Long
    #End If

    Type YCHOOSECOLOR
        lStructSize As Long         'この構造体の長さ
        hwndOwner As LongPtr        'ダイアログボックスを持つウインドウハンドル
        hInstance As LongPtr        'モジュールのインスタンスハンドル
        rgbResult As Long           '呼び出す前は初期色、終了時は、ユーザーが選択した色
        lpCustColors As LongPtr        'カスタムカラーの配列のポインタ
        flags As Long               '初期化フラグ
        lCustData As LongPtr
        lpfnHook As LongPtr
        lpTemplateName As String
    End Type

    'Flagsの設定値
    Public Const CC_ENABLEHOOK = &H10           'lpfnHoolで指定されたフック関数を有効にする
    Public Const CC_ENABLETEMPLATE = &H20       'hInstanceとlpTemplateNameで指定されたダイアログテンプレートを使って作成する
    Public Const CC_ENABLETEMPLATEHANDLE = &H40 'hInstanceがロード済みのテンプレートを含むメモリブロックを差す
    Public Const CC_FULLOPEN = &H2              'ダイアログボックス作成時にダイアログ全体を表示する
    Public Const CC_PREVENTFULLOPEN = &H4       '[色作成]ボタンを無効にする
    Public Const CC_RGBINIT = &H1               'rgbResultで初期設定カラーとして指定されたカラーをダイアログに表示する
    Public Const CC_SHOWHELP = &H8              '[ヘルプ]ボタンを表示する

    #If VBA7 And Win64 Then
    ' ヒープからメモリブロックを確保する
        Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As LongPtr) As LongPtr
    #Else
    ' ヒープからメモリブロックを確保する
        Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
    #End If

    Public Const GMEM_MOVEABLE = &H2 ' 移動可能メモリの割当て
    Public Const GMEM_ZEROINIT = &H40 ' メモリ内容を0で初期化する
    Public Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)

    #If VBA7 And Win64 Then
    'グローバルヒープに確保されたメモリブロックをロックする
        Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr

    'メモリブロックを移動する。
        Private Declare PtrSafe Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
       
    'グローバルヒープにロードされたメモリブロックを解放する
        Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long

    'グローバルヒープに確保されていたメモリブロックを解放する
        Private Declare PtrSafe Function GlobalFree Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
    #Else
    'グローバルヒープに確保されたメモリブロックをロックする
        Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long

    'メモリブロックを移動する。
        Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

    'グローバルヒープにロードされたメモリブロックを解放する
        Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long

    'グローバルヒープに確保されていたメモリブロックを解放する
        Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
    #End If

    Public Function LsGetColorDialog(ByRef color As Long, fm As Form) As Long
    '***********************************************************
    '機能 : 「色指定」ダイアログを表示する
    '戻り値: 1:色が選択された 0:[キャンセル]ボタンを押された
    '     引数colorに選択された色コードをセットします
    '***********************************************************

        Dim COL As YCHOOSECOLOR
        Dim longret As LongPtr
        Dim longret2 As Long
        Dim custcol(15) As Long
        Dim rescol As Long
        Dim i As Integer
        Dim colorsize As LongPtr
        Dim colorAddress As LongPtr
        Dim memHAndle As LongPtr

        rescol = 0
        longret2 = 0
        For i = 0 To 15
            custcol(i) = &HFFFFFF
        Next


    'カスタムカラーに必要なメモリのサイズを得る。
        colorsize = Len(custcol(0)) * 16
    'カスタムカラーのメモリブロックを確保
        memHAndle = GlobalAlloc(GHND, colorsize)
        If memHAndle Then
    'カスタムカラーののググローバルメモリブロックロックする
            colorAddress = GlobalLock(memHAndle)

            If colorAddress Then
            'カスタムカラーのグローバルメモリブロックを配列にコピーする
                Call MoveMemory(ByVal colorAddress, custcol(0), colorsize)

                With COL
                    .lStructSize = Len(COL)
                    .hwndOwner = fm.hwnd
                    .hInstance = 0&
                    .rgbResult = rescol
                    .lpCustColors = colorAddress
                    .flags = CC_RGBINIT
                    .lCustData = 0&
                    .lpfnHook = 0&
                    .lpTemplateName = 0&
                End With

                longret2 = ChooseColor(COL)
            'メモリブロックロック解除
                longret = GlobalUnlock(memHAndle)
            'メモリブロック解放
                longret = GlobalFree(memHAndle)

            Else
            'メモリブロック解放
                longret = GlobalFree(memHAndle)
            End If
        End If
        color = COL.rgbResult
        LsGetColorDialog = longret2
    End Function
    '-----------------------------------------------------------------------------------------------------------------------

    【フォームからの呼び出し】

    '****************************************************************
    '   色検索ボタン
    '****************************************************************
    Private Sub BTN_色検索_Click()
        Dim color As Long
       
        ' 色の選択ダイアログ
        If LsGetColorDialog(color, Me) = 1 Then
            Me![COCODE] = color
        End If

    End Sub

    よろしくお願いいたします。

    2020年6月26日 5:53

回答

  • 以下3か所の修正でどうでしょう。

    ---------

       Private Declare PtrSafe Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)

        Private Declare PtrSafe Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Any, ByVal Source As Any, ByVal Length As LongPtr)

    ---------

    Call MoveMemory(ByVal colorAddress, custcol(0), colorsize)

    Call MoveMemory(colorAddress, VarPtr(custcol(0)), colorsize)

    ---------

    .lStructSize = Len(COL)

    .lStructSize = LenB(COL)

    2020年6月28日 3:53

すべての返信

  • それが原因かはわかりませんが、とりあえず、CHOOSECOLORA Structure と見比べるとメンバーが一個足りていないように見えました。
    2020年6月27日 12:35
  • あまり知られていませんがAzuleanさんの挙げたドキュメントはMac版Windowsについてでして、通常のWindowsであれば質問に投稿された定義であってそうです。
    2020年6月28日 0:57
  • 以下3か所の修正でどうでしょう。

    ---------

       Private Declare PtrSafe Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)

        Private Declare PtrSafe Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Any, ByVal Source As Any, ByVal Length As LongPtr)

    ---------

    Call MoveMemory(ByVal colorAddress, custcol(0), colorsize)

    Call MoveMemory(colorAddress, VarPtr(custcol(0)), colorsize)

    ---------

    .lStructSize = Len(COL)

    .lStructSize = LenB(COL)

    2020年6月28日 3:53
  • Azuleanさま 佐祐理さま minmin312さま 返信ありがとうございます。

    minmin312さま の指摘されている箇所の修正でダイアログが表示されました。

    ありがとうございます。

    これからもよろしくお願いいたします。

    2020年6月29日 0:14