64ビットエクセルでのAPI宣言/PtrSafe

エクセルのInputboxで、入力された文字列を自動的にアスタリスクで隠すようにする方法を探し
http://oshiete.goo.ne.jp/qa/2371878.html
の回答No1のコードがまさに最適なコードで、これまで非常に助かっていました。

ところが、64bitのエクセルでは動かないことがわかりました。
表示されたエラーメッセージの言葉から調べて、PtrSafeという言葉を入れなければならないようなのでAPI宣言を以下のようにしてみました。

#If VBA7 And Win64 Then '64ビット版

Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As Long, _
ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long

Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long

Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _
(ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, _
ByVal dwThreadId As Long) As Long

Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long

Private Declare PtrSafe Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" _
(ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long

Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, _
ByVal lpClassName As String, _
ByVal nMaxCount As Long) As Long

Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long

#Else '32ビット版
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, _
ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long

Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long

Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _
(ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, _
ByVal dwThreadId As Long) As Long

Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long

Private Declare Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" _
(ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long

Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, _
ByVal lpClassName As String, _
ByVal nMaxCount As Long) As Long

Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
#End If

ところが、回答No1のコードで
Sub Report_Open()　を実行すると
Public Function InputBoxDK(Prompt, Optional Title, Optional Default, Optional XPos, _
Optional YPos, Optional HelpFile, Optional Context) As String
のところがハイライトされてエラーになります。

どう直せば良いのでしょうか？
全文のコードを乗せると字数制限に引っかかりますので、申し訳ありませんが宣言以外の部分は
http://oshiete.goo.ne.jp/qa/2371878.html
の回答No1のコードを見てくださいますようお願いします。

No.2 回答者： cj_mover 回答日時： 2014/05/27 13:40

（２／２）

Public Function InputBoxDK( _
　　　　Prompt As String, Optional Title, Optional Default, _
　　　　Optional XPos, Optional YPos, Optional HelpFile, Optional Context _
　　　　) As String
　　Dim lngModHwnd As LongPtr
　　Dim lngThreadID As LongPtr

　　lngThreadID = GetCurrentThreadId
　　lngModHwnd = GetModuleHandle(vbNullString)

　　hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID)

　　InputBoxDK = InputBox(Prompt, Title, Default, XPos, YPos, HelpFile, Context)
　　UnhookWindowsHookEx hHook

End Function

' ' 〓〓〓〓〓64ビット版、以上〓〓〓〓〓

#Else　 '〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓

' ' 〓〓〓〓〓32ビット版、以下〓〓〓〓〓

Private Declare Function CallNextHookEx Lib "user32" ( _
　　　　ByVal hHook As Long, ByVal ncode As Long, _
　　　　ByVal wParam As Long, lParam As Any _
　　　　) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" ( _
　　　　ByVal lpModuleName As String _
　　　　) As Long
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" ( _
　　　　ByVal idHook As Long, ByVal lpfn As Long, _
　　　　ByVal hmod As Long, ByVal dwThreadId As Long _
　　　　) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" ( _
　　　　ByVal hHook As Long _
　　　　) As Long
Private Declare Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" ( _
　　　　ByVal hDlg As Long, ByVal nIDDlgItem As Long, _
　　　　ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long _
　　　　) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" ( _
　　　　ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long _
　　　　) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long

Private Const VER64BIT = False

Private hHook As Long

Private Function NewProc(ByVal lngCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
　　Dim strClassName As String
　　Dim RetVal As Long
　　Dim lngBuffer As Long

　　If lngCode < HC_ACTION Then
　　　　NewProc = CallNextHookEx(hHook, lngCode, wParam, lParam)
　　　　Exit Function
　　End If

　　strClassName = String$(256, " ")
　　lngBuffer = 255

　　If lngCode = HCBT_ACTIVATE Then 'A window has been activated
　　　　RetVal = GetClassName(wParam, strClassName, lngBuffer)
　　　　If Left$(strClassName, CLng(RetVal)) = "#32770" Then 'Class name of the Inputbox
　　　　　　'This changes the edit control so that it display the password character *.
　　　　　　'You can change the Asc("*") as you please.
　　　　　　SendDlgItemMessage wParam, &H1324, EM_SETPASSWORDCHAR, Asc("*"), &H0
　　　　End If
　　End If

　　'This line will ensure that any other hooks that may be in place are
　　'called correctly.
　　CallNextHookEx hHook, lngCode, wParam, lParam

End Function

Public Function InputBoxDK( _
　　　　Prompt As String, Optional Title, Optional Default, _
　　　　Optional XPos, Optional YPos, Optional HelpFile, Optional Context _
　　　　) As String
　　Dim lngModHwnd As Long
　　Dim lngThreadID As Long

　　lngThreadID = GetCurrentThreadId
　　lngModHwnd = GetModuleHandle(vbNullString)

　　hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID)

　　InputBoxDK = InputBox(Prompt, Title, Default, XPos, YPos, HelpFile, Context)
　　UnhookWindowsHookEx hHook

End Function

' ' 〓〓〓〓〓32ビット版、以上〓〓〓〓〓

#End If　 '〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓




' ' 〓〓〓〓〓

Sub Report_Open()
　　If InputBoxDK("パスワードを入力して下さい") <> "password" Then
　　　　MsgBox "社員コードが間違っています。"
　　End If
'　　Debug.Print VER64BIT ' 確認用　64bit環境なら　True
End Sub

' ' 〓〓〓〓〓

この回答へのお礼

ありがとうございました。

お礼日時：2014/06/07 13:37

No.1 ベストアンサー 回答者： cj_mover 回答日時： 2014/05/27 13:38

（１／２）

こんにちは。
暫く回答お休み中で、質問を読むこともないこの頃なのですが、
たまたま馴染みのアバターをお見かけしましたので、このご質問だけレスしてみます。

Win32 API コールバック、と、64|32bit環境互換については
今の時点での情報が少な過ぎてこちらも確信を持てるものは書けません。
必要な手当てをして、動作確認はしましたが、もっとスマートなやり方があるかも知れません。
お求めに寄り添った直接的な回答として、２回の投稿で記述を掲げますが、
そもそもの方法として、これが唯一のものではないことを知っておいてください。
リンクを張られた質問スレ（元スレ）においては、
「恐らくAccess VBAついての質問であろう」とう前提で回答が付いています。
今回は、Excel カテゴリに書かれた質問ですから、
PasswordCharプロパティを * に設定したTextBoxを配置したユーザーフォーム
（他にPromptを表示するLabel、OKボタンにあたるCommandButton）を用意しておいて、
' ' 標準モジュール
Public rtn
Sub Report_Open()
　　UserForm1.Show vbModal
　　If rtn <> "password" Then
　　　　MsgBox "社員コードが間違っています。"
　　End If
End Sub
' ' ユーザーフォームモジュール
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
　　rtn = TextBox1
End Sub
Private Sub CommandButton1_Click()
　　Unload Me
End Sub
のようなものを奨めるのがExcel VBA的には本筋だと考えています。
この場合はバージョン互換を意識する必要はありませんし、デザインが自在ですし、
何よりシンプルです。

本題に戻って、、、
AddressOf演算子に渡すFunctionの型は明示的である必要があります。
64bitでは
Function NewProc(...) As LongPtr
32bitでは
Function NewProc(...) As Long
なので、各関数を丸ごと条件付きコンパイルの内側で書き分けてあげる必要があります。

もしも仮に32bit互換を捨てて、64bit環境に限った話としては、
64bit用のDeclare文のすべてと、
各Functionの戻り型、引数、変数について、
Long型の宣言をLongPtr型に（今回必要な記述に関してのみ）
ご提示の記述から全置換すれば期待の動作にはなります。

64bit版については、明らかにLongLong型である場合でも、
LongPtr型で統一して解り易い（編集し易い）ように書いています。

以下、お求めの記述。
' ' ///

Option Explicit

'Constants to be used in our API functions
Private Const EM_SETPASSWORDCHAR = &HCC
Private Const WH_CBT = 5
Private Const HCBT_ACTIVATE = 5
Private Const HC_ACTION = 0

#If VBA7 And Win64 Then　 '〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓

' ' 〓〓〓〓〓64ビット版、以下〓〓〓〓〓

Private Declare PtrSafe Function CallNextHookEx Lib "user32" ( _
　　　　ByVal hHook As LongPtr, ByVal ncode As LongPtr, _
　　　　ByVal wParam As LongPtr, lParam As Any _
　　　　) As LongPtr
Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" ( _
　　　　ByVal lpModuleName As String _
　　　　) As LongPtr
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" ( _
　　　　ByVal idHook As LongPtr, ByVal lpfn As LongPtr, _
　　　　ByVal hmod As LongPtr, ByVal dwThreadId As LongPtr _
　　　　) As LongPtr
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" ( _
　　　　ByVal hHook As LongPtr _
　　　　) As LongPtr
Private Declare PtrSafe Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" ( _
　　　　ByVal hDlg As LongPtr, ByVal nIDDlgItem As LongPtr, _
　　　　ByVal wMsg As LongPtr, ByVal wParam As LongPtr, ByVal lParam As LongPtr _
　　　　) As LongPtr
Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" ( _
　　　　ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As LongPtr _
　　　　) As LongPtr
Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As LongPtr

Private Const VER64BIT = True

Private hHook As LongPtr

Private Function NewProc(ByVal lngCode As LongPtr, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
　　Dim strClassName As String
　　Dim RetVal As LongPtr
　　Dim lngBuffer As LongPtr

　　If lngCode < HC_ACTION Then
　　　　NewProc = CallNextHookEx(hHook, lngCode, wParam, lParam)
　　　　Exit Function
　　End If

　　strClassName = String$(256, " ")
　　lngBuffer = 255

　　If lngCode = HCBT_ACTIVATE Then 'A window has been activated
　　　　RetVal = GetClassName(wParam, strClassName, lngBuffer)
　　　　If Left$(strClassName, CLng(RetVal)) = "#32770" Then 'Class name of the Inputbox
　　　　　　'This changes the edit control so that it display the password character *.
　　　　　　'You can change the Asc("*") as you please.
　　　　　　SendDlgItemMessage wParam, &H1324, EM_SETPASSWORDCHAR, Asc("*"), &H0
　　　　End If
　　End If

　　'This line will ensure that any other hooks that may be in place are
　　'called correctly.
　　CallNextHookEx hHook, lngCode, wParam, lParam

End Function

この回答へのお礼

cj_mover さん、いつもありがとうございます。
アバタじゃなくてえくぼ、いやホクロなんですが・・・なんて冗談はおいときまして、さっそく64bitエクセルで試したところ当然ですがちゃんと作動してくれました。
助かりました。

本当はおっしゃるようにユーザーフォームを使用するべきなんですね。ただユーザーフォームってこれまでつかったことがないのでなんとなく尻込みしていました。
ユーザーフォームの方も試してみて、またわからないことがありましたら質問させていただきます。
ありがとうございました。

お礼日時：2014/05/29 14:56