『64bitのExcel対応 クリップボードを経由してのデータ取得』（Ｏ．Ｍ）
32bitのExcel2027〜2021で使用していたクリップボードを経由してのデータ取得が、
64bitのExcel2021でエラーになるようになってしまいました。
コードを書き換えてはみたのですが、
32bitではデータが取得できるのですが64bitになるとデータが取得できません。
下記サイト様やこちらのサイト様の過去ログは見たのですが
よくわからず、申し訳ございませんが教えていただきたいです。
https://qiita.com/7shi/items/61f4c4e132835b26b3ea
FunctionをPtrSafe Function
hWnd As Long を hWnd As LongPtr
hMem As LongPtr を hMem As LongPtr
にしました。
#If Win64 Then
'クリップボードを開く。
Private Declare PtrSafe Function OpenClipboard Lib "user32.dll" _
(ByVal hWnd As LongPtr) As Long
'クリップボードを閉じる。
Private Declare PtrSafe Function CloseClipboard Lib "user32.dll" () As Long
'クリップボードにあるデータを取得
Private Declare PtrSafe Function GetClipBoardData Lib "user32.dll" _
Alias "GetClipboardData" (ByVal wFormat As Long) As Long
'メモリブロックを確保する。
Private Declare PtrSafe Function GlobalAlloc Lib "kernel32.dll" _
(ByVal wFlags As Long, ByVal dwBytes As Long) As Long
'メモリブロックを開放する。
Private Declare PtrSafe Function GlobalFree Lib "kernel32.dll" _
(ByVal hMem As LongPtr) As Long
'グローバルメモリをロックしてポインタに変換する。
Private Declare PtrSafe Function GlobalLock Lib "kernel32.dll" _
(ByVal hMem As LongPtr) As Long
'グローバルメモリのロック解除
Private Declare PtrSafe Function GlobalUnlock Lib "kernel32.dll" _
(ByVal hMem As LongPtr) As Long
'グローバルメモリのサイズを取得する。
Private Declare PtrSafe Function GlobalSize Lib "kernel32.dll" _
(ByVal hMem As LongPtr) As Long
'メモリをコピーします
Private Declare PtrSafe Sub CopyMemory Lib "kernel32.dll" _
Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, _
ByVal Length As Long)
'現在クリップボード内に存在するデータが持つデータ形式を列挙する。
Private Declare PtrSafe Function EnumClipboardFormats Lib "user32.dll" _
(ByVal wFormat As Long) As Long
'登録されているデータ形式の形式名を取得する。
Private Declare PtrSafe Function GetClipboardFormatName Lib "user32.dll" _
Alias "GetClipboardFormatNameA" (ByVal wFormat As Long, _
ByVal lpString As String, ByVal nMaxCount As Long) As Long
'クリップボードを空にします。
Private Declare PtrSafe Function EmptyClipboard Lib "user32.dll" () As Long
'クリップボードにデータをセットします。
Private Declare Function SetClipboardData Lib "user32.dll" _
(ByVal wFormat As Long, ByVal hMem As LongPtr) As Long
'クリップボードにデータ形式を登録します。
Private Declare PtrSafe Function RegisterClipboardFormat Lib "user32.dll" _
Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long
#Else
'クリップボードを開く。
Private Declare Function OpenClipboard Lib "user32.dll" _
(ByVal hWnd As Long) As Long
'クリップボードを閉じる。
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
'クリップボードにあるデータを取得
Private Declare Function GetClipBoardData Lib "user32.dll" _
Alias "GetClipboardData" (ByVal wFormat As Long) As Long
'メモリブロックを確保する。
Private Declare Function GlobalAlloc Lib "kernel32.dll" _
(ByVal wFlags As Long, ByVal dwBytes As Long) As Long
'メモリブロックを開放する。
Private Declare Function GlobalFree Lib "kernel32.dll" _
(ByVal hMem As Long) As Long
'グローバルメモリをロックしてポインタに変換する。
Private Declare Function GlobalLock Lib "kernel32.dll" _
(ByVal hMem As Long) As Long
'グローバルメモリのロック解除
Private Declare Function GlobalUnlock Lib "kernel32.dll" _
(ByVal hMem As Long) As Long
'グローバルメモリのサイズを取得する。
Private Declare Function GlobalSize Lib "kernel32.dll" _
(ByVal hMem As Long) As Long
'メモリをコピーします
Private Declare Sub CopyMemory Lib "kernel32.dll" _
Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, _
ByVal Length As Long)
'現在クリップボード内に存在するデータが持つデータ形式を列挙する。
Private Declare Function EnumClipboardFormats Lib "user32.dll" _
(ByVal wFormat As Long) As Long
'登録されているデータ形式の形式名を取得する。
Private Declare Function GetClipboardFormatName Lib "user32.dll" _
Alias "GetClipboardFormatNameA" (ByVal wFormat As Long, _
ByVal lpString As String, ByVal nMaxCount As Long) As Long
'クリップボードを空にします。
Private Declare Function EmptyClipboard Lib "user32.dll" () As Long
'クリップボードにデータをセットします。
Private Declare Function SetClipboardData Lib "user32.dll" _
(ByVal wFormat As Long, ByVal hMem As Long) As Long
'クリップボードにデータ形式を登録します。
Private Declare Function RegisterClipboardFormat Lib "user32.dll" _
Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long
#End If
また、
https://www.excel.studio-kazu.jp/kw/20240205135924.html?t=193659
のスレッドで白茶様に教えていただいた件に関しては理解できておらず申し訳ございません。
64bitのExcelを使用するようになって
FunctionをPtrSafe Function、hWnd As LongをhWnd As Longptrにしないと
エラーで動かなくなるので64bitのエクセルと32bitのエクセルでコードを分けたつもりでした。
＜ 使用 Excel：Excel2021、使用 OS：Windows11 ＞
Office 2021 : 64bit 版使用者です。
>コードを書き換えてはみたのですが、 >32bitではデータが取得できるのですが64bitになるとデータが取得できません。
ご自身が提示されたコードは、元は何処から？参考にされて利用 されていたコードなのでしょうか？もし、URLを載せれるのなら 上げてください。一部だけ見せられてもわかりません。
パット見で、解りそうな箇所だけですが
>'クリップボードにデータをセットします。 > Private Declare Function SetClipboardData Lib "user32.dll" _ > (ByVal wFormat As Long, ByVal hMem As LongPtr) As Long
上記は、PtrSafe の記述が抜けていませんか？ とですが、下記のメソッド部分も無いのが気になります。
Rem 指定されたデータ形式のデータがクリップボードに格納されているかどうかを調べます。 Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long Rem 指定のメモリ領域をある場所から別の場所に移動する Private Declare PtrSafe Sub MoveMemory Lib "kernel32.dll" Alias "RtlMoveMemory" _ (ByVal Destination As LongPtr, ByVal Source As LongPtr, ByVal Length As LongPtr)
無しでも、動作に問題が無いのならすみません。
>下記サイト様やこちらのサイト様の過去ログは見たのですが >よくわからず、申し訳ございませんが教えていただきたいです。 >https://qiita.com/7shi/items/61f4c4e132835b26b3ea
上記の、●●@7shi さんのマクロですが、ちゃんとこちらの環境では 動作しましたよ。( 全文だと長いので、64bit版に必要な記述だけ提示します。)
Option Explicit Private Declare PtrSafe Function OpenClipboard Lib "user32.dll" (ByVal hWnd As LongPtr) As Long Private Declare PtrSafe Function EmptyClipboard Lib "user32.dll" () As Long Private Declare PtrSafe Function CloseClipboard Lib "user32.dll" () As Long Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32.dll" (ByVal wFormat As Long) As Long Private Declare PtrSafe Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As LongPtr Private Declare PtrSafe Function SetClipboardData Lib "user32.dll" (ByVal wFormat As Long, ByVal hMem As LongPtr) As Long Private Declare PtrSafe Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As LongLong) As LongPtr Private Declare PtrSafe Function GlobalLock Lib "kernel32.dll" (ByVal hMem As LongPtr) As LongPtr Private Declare PtrSafe Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As LongPtr) As Long Private Declare PtrSafe Function GlobalSize Lib "kernel32.dll" (ByVal hMem As LongPtr) As LongLong Private Declare PtrSafe Sub MoveMemory Lib "kernel32.dll" Alias "RtlMoveMemory" _ (ByVal Destination As LongPtr, ByVal Source As LongPtr, ByVal Length As LongLong)
Sub GetClipboard_txt() '取得
Dim txt As String
txt = GetClipboard
[A1] = GetClipboard
Debug.Print txt
End Sub
Sub SetClipboard_txt() '送信
Dim txt As String
txt = "送信しました"
SetClipboard txt
End Sub
Public Sub SetClipboard(sUniText As String)
Dim iStrPtr As LongPtr
Dim iLen As LongLong
Dim iLock As LongPtr
Const GMEM_MOVEABLE As Long = &H2
Const GMEM_ZEROINIT As Long = &H40
Const CF_UNICODETEXT As Long = &HD
OpenClipboard 0&
EmptyClipboard
iLen = LenB(sUniText)
iStrPtr = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, iLen + 2&)
iLock = GlobalLock(iStrPtr)
MoveMemory iLock, StrPtr(sUniText), iLen
GlobalUnlock iStrPtr
SetClipboardData CF_UNICODETEXT, iStrPtr
CloseClipboard
End Sub
Public Function GetClipboard() As String
Dim iStrPtr As LongPtr
Dim iLen As LongLong
Dim iLock As LongPtr
Dim sUniText As String
Const CF_UNICODETEXT As Long = 13&
OpenClipboard 0&
If IsClipboardFormatAvailable(CF_UNICODETEXT) Then
iStrPtr = GetClipboardData(CF_UNICODETEXT)
If iStrPtr Then
iLock = GlobalLock(iStrPtr)
iLen = GlobalSize(iStrPtr)
sUniText = String$(CLng(iLen) \ 2& - 1&, vbNullChar)
MoveMemory StrPtr(sUniText), iLock, LenB(sUniText)
GlobalUnlock iStrPtr
End If
GetClipboard = sUniText
End If
CloseClipboard
End Function
尚、てすとするなら新規BOOKでしてください。A1セルに取得した文章も入りますので 取得する前に、マクロで送信するか、適当に文章をコピーしてください。 （あみな） 2024/02/10(土) 08:05:36
ご指摘の部分は間違って修正途中の古いデータを貼り付けてしまってしまったせいでした、
失礼いたしました。
62bitのExcelと32bitのExcelで併用がしたく、
教えていただいたサイトの内容を参考にどう書き換えればいいのかと四苦八苦しています。
64bit用に書き換えてみたら32bitで動かないなど、
具体的な書き換えポイントがわからず質問させていただきまいた。
#If Win64 Then
Private Declare PtrSafe Function GlobalSize Lib "kernel32.dll" (ByVal hMem As LongPtr) As LongLong
#Else
Private Declare Function GlobalSize Lib "kernel32.dll" (ByVal hMem As Long) As Long
#End IF
とした場合、変数宣言の際に
#If Win64 Then
Dim hWnd As LongPtr
#Else
Dim hWnd As Long
#End If
とすれば()内のLongをlongPtrに変更部分は共用で使用できるようになるのですが、
おそらく)の後のLongLongの部分で引っかかってエラーになっているのを
どう直せばいいのかがわからないという点でつまずいていました。
わからないけれどLongのままなら両方でエラーは出ずに
動いているように見えるのでそのままといった形にしてしまっていました。
それで、直さなければいけない部分がどこか
および直し方を教えていただけないかなという希望および、
その他の気が付いていない間違いもあるかと考えて
具体性のない質問の仕方をしてしまいました、失礼いたしました。
括弧のあとをLongLongにすると処理がわからないという部分のわからないと思ったポイントですが、
GlobalSize hMem
とすると変数を宣言する部分もないし)の後ろの型式の
LongとLongLongをどう切り替えるのかわからないといった考え方だったのですが、
白茶さんにいただいたご説明を見返して気が付いたので
#If Win64 Then
Dim GloSi As LongLong
#Else
Dim GloSi As Long
#End If
GloSi = GlobalSize(hMem)
のように、代入したりして処理するのかなと気が付いたので
いろいろいじってみたいと思います。
ご指摘の部分に関しては32bitのExcelでは処理できています。
教えていただいたコードのため理解不足があるかもしれないのですが、
Rem 指定されたデータ形式のデータがクリップボードに格納されているかどうかを調べます。 Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
の部分は、
'データのあるクリップボード番号のリストを返します。
Public Function GetClipBoardNumber() As Long()
Dim lngClipBoardFormat As Long
Dim lngEnumClipboardFormats As Long
ReDim lngClipBoardNumber(0) As Long
lngClipBoardFormat = 0
'クリップボードをオープン
'データのある場合
If OpenClipboard(ByVal 0) <> 0 Then
クリップボード番号を取得
Do
'データ形式を取得
lngEnumClipboardFormats = EnumClipboardFormats(lngClipBoardFormat)
'データ形式が存在
If lngEnumClipboardFormats <> 0 Then
の部分で処理を行っていると思います。
（Ｏ．Ｍ） 2024/02/10(土) 09:46:37
基本的にOffice2010以降であれば、64bitでも32bitでも宣言をかき分ける必要はありません。 64bit用の宣言のみでOKです。32bitで使用するときに自動で32bit用に変換してくれます。 (例えば LongPtr は、32bitでは Long に変換して解釈される。)
ただし、例外的にかき分ける必要のあるAPIがありますが、ほんの一部です。めったに使うことはないです。
下記リンク先から64bit対応のAPI宣言が網羅されたテキストファイルをダウンロードできますので、確認できます。 https://www.microsoft.com/en-us/download/details.aspx?id=9970
Office2007以前にも対応させたい場合は、かき分ける必要がありますが、 すでにサポートの修了しているOffice2007を使用する可能性はありますか。
下記に詳細に解説されてますので、ご参考に。
WindowsAPI をOffice64bit版または32bit版のVBAで使うには | hatena chips https://hatena19.com/use-win-api-with-office-64bit-or-32bit-vba/
（hatena） 2024/02/10(土) 15:37:14
WindowsAPI をOffice64bit版または32bit版のVBAで使うには | hatena chips https://hatena19.com/use-win-api-with-office-64bit-or-32bit-vba/
をみてなんとなく理解ができた気がします。
質問をあげた件のコードを#If VBA7 Thenにしたところ、
64bit用のつもりで記載したコードの部分で32bitのExcelも動きました。
大変失礼いたしました。
肝心の64bitExcelではデータが取得できなかったので別の間違いがあると思いますので調べてみます。
（データ形式や設定部分までは取得できるのですが、
記述された線や文字のデータが取得できない状態で取得が途中までしかできない症状でした）
別件でta32.dllでの解凍が上手くできず64bit版でtar62.dll使用するようにしたりしたのですが、
クリップボードの場合は別途ダウンロードして設定したわけではないので
Libの後の部分で変更の必要のある個所はないのでしょうか？
tar32.dllの部分もなにか別の方法があれば教えていただきたいです。
https://www.madobe.net/archiver/lib/tar32.html
'ファイルの圧縮、解凍を実行します
#If Win64 Then
Public Declare PtrSafe Function Tar Lib "Tar64" (ByVal hWnd As LongPtr _ , ByVal szCmdLine As String, ByVal szOutPut As String, ByVal dwsize As LongPtr) As Long #Else Public Declare Function Tar Lib "Tar32" (ByVal hWnd As Long _ , ByVal szCmdLine As String, ByVal szOutPut As String, ByVal dwsize As Long) As Long #End If
（Ｏ．Ｍ） 2024/02/10(土) 18:21:24
下記リンク先から64bit対応のAPI宣言が網羅されたテキストファイルをダウンロードできますので、確認できます。 https://www.microsoft.com/en-us/download/details.aspx?id=9970
でダウンロードを行ってみたのですが、
exeファイルを実行した後にTextファイルがどこに保存されるのかがわからず
https://vbabeginner.net/howto-use-win32-api/
のサイト様から
https://vbabeginner.net/data/Win32API_PtrSafe.TXT
の
リンクへ飛んで中身を見てコードを書き換えてみました。
@7shiさんのコードとの違いなどもあったのですが、
何が違うかわからずWin32API_PtrSafe.TXTのほうを優先して使用しコードを書き換えました。
違っていた部分の１部ですが
@7shiさんのコード
Private Declare PtrSafe Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As LongPtr
Private Declare PtrSafe Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As LongLong) As LongPtr
Private Declare PtrSafe Sub MoveMemory Lib "kernel32.dll" Alias "RtlMoveMemory" _
(ByVal Destination As LongPtr, ByVal Source As LongPtr, ByVal Length As LongLong)
Win32API_PtrSafe.TXT
Declare PtrSafe Function GetClipboardData Lib "user32" Alias "GetClipboardDataA" (ByVal wFormat As Long) As LongPtr
Declare PtrSafe Function GlobalAlloc Lib "kernel32" Alias "GlobalAlloc" (ByVal wFlags As Long, ByVal dwBytes As LongPtr) As LongPtr
Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
※@7shiさんのコードではMoveMemoryとあったのですが、
Win32API_PtrSafe.TXTではMoveMemoryはなくCopyMemoryがあり、
私が使用していたコードにある記載もCopyMemoryだったため、
Win32API_PtrSafe.TXTのHPのほうを優先して採用して直していきました。
@IF vb7 Then で条件を分けて32bitの2021のexcelで実行すると動いたのですが
条件分けを消して64bit用と思って記載したコードのみにすると
「エントリ"GetClipboardDataA"がDLLファイルuser32.dllの中に見つかりません」
となるため、@IF vb7 Thenで分岐してもPtrSafeのない方の宣言に進んでいるようで、
考えていたものと違った動きをするため、理解できていなかったようです。
64bitのExcelは会社にしかないため、火曜日に会社で64bitの場合の動作を確認してみたいと思います。
（Ｏ．Ｍ） 2024/02/11(日) 00:24:14
落ち着いて見比べれば自己解決に至るとは思いますが、ちょっとだけお手伝い。^^;
宣言文を途中で改行し過ぎると、記述誤りや記述洩れを見落としがちです。 まずはストレートに書いてみた方がイイと思います。
冒頭にご提示された宣言文と[Win32API_PtrSafe.TXT]の記述を、ざっと比較してみました。
(上がご提示の宣言文、下が[Win32API_PtrSafe.TXT])
私の目から見て「ココは違う(足りない)」と思ったところにアンダーバー付けてます。
(あと「#Else」以降の古い宣言文は必要ないので見てません)
↓ ↓
Private Declare PtrSafe Function GetClipBoardData Lib "user32.dll" Alias "GetClipboardData_" (ByVal wFormat As Long) As Long___
Declare PtrSafe Function GetClipboardData Lib "user32" Alias "GetClipboardDataA" (ByVal wFormat As Long) As LongPtr
↓ ↓
Private Declare _______ Function SetClipboardData Lib "user32.dll" (ByVal wFormat As Long, ByVal hMem As LongPtr) As Long___
Declare PtrSafe Function SetClipboardData Lib "user32" Alias "SetClipboardDataA" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr
↓ ↓
Private Declare PtrSafe Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As Long___) As Long___
Declare PtrSafe Function GlobalAlloc Lib "kernel32" Alias "GlobalAlloc" (ByVal wFlags As Long, ByVal dwBytes As LongPtr) As LongPtr
↓
Private Declare PtrSafe Function GlobalFree Lib "kernel32.dll" (ByVal hMem As LongPtr) As Long___
Declare PtrSafe Function GlobalFree Lib "kernel32" Alias "GlobalFree" (ByVal hMem As LongPtr) As LongPtr
↓
Private Declare PtrSafe Function GlobalLock Lib "kernel32.dll" (ByVal hMem As LongPtr) As Long___
Declare PtrSafe Function GlobalLock Lib "kernel32" Alias "GlobalLock" (ByVal hMem As LongPtr) As LongPtr
↓
Private Declare PtrSafe Function GlobalSize Lib "kernel32.dll" (ByVal hMem As LongPtr) As Long___
Declare PtrSafe Function GlobalSize Lib "kernel32" Alias "GlobalSize" (ByVal hMem As LongPtr) As LongPtr
↓
Private Declare PtrSafe Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long___)
Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( Destination As Any, Source As Any, ByVal Length As LongPtr)
↑ここは設計方針に寄ります↑
▼
×実行時エラー453になる宣言例
Declare PtrSafe Function TimeGetTime Lib "winmm.dll" () As Long
~ココが大文字
...Aliasを省略した状態で、関数名にDLL内での正式名を使わない
Declare PtrSafe Function timeGetTime Lib "winmm.dll" Alias "TimeGetTime" () As Long
~ココが大文字
...AliasでDLL内での正式名を書かない
○有効な宣言例
Declare PtrSafe Function timeGetTime Lib "winmm.dll" () As Long 'Aliasを省略する場合は関数名にはDLL内での正式名を使う(大文字小文字も使い分ける)
Declare PtrSafe Function TimeGetTime Lib "winmm.dll" Alias "timeGetTime" () As Long 'Aliasを省略せずちゃんとDLL内での正式名を指定してあげれば関数名は任意に命名可能なので
Declare PtrSafe Function testFunc1 Lib "winmm.dll" Alias "timeGetTime" () As Long '←例えばこんなテキトウな名前でも機能する。
（白茶） 2024/02/13(火) 10:46:43
○有効な宣言例 Declare PtrSafe Function timeGetTime Lib "winmm.dll" () As Long 'Aliasを省略する場合は関数名にはDLL内での正式名を使う(大文字小文字も使い分ける) Declare PtrSafe Function TimeGetTime Lib "winmm.dll" Alias "timeGetTime" () As Long 'Aliasを省略せずちゃんとDLL内での正式名を指定してあげれば関数名は任意に命名可能なので Declare PtrSafe Function testFunc1 Lib "winmm.dll" Alias "timeGetTime" () As Long '←例えばこんなテキトウな名前でも機能する。
の部分が大変参考になりました、ありがとうございます。
@IF vb7 Then で条件を分けて32bitの2021のexcelで実行すると動いたのですが
条件分けを消して64bit用と思って記載したコードのみにすると
「エントリ"GetClipboardDataA"がDLLファイルuser32.dllの中に見つかりません」
となるため、@IF vb7 Thenで分岐してもPtrSafeのない方の宣言に進んでいるようで、
考えていたものと違った動きをするため、理解できていなかったようです。
と書いた部分ですが、PtrSafeのない方の宣言に進んだのは書いたまんまのミスで
#IF VBA7 と #IF VB7の記述間違いでした。
※参考にさせていただいた
https://hatena19.com/use-win-api-with-office-64bit-or-32bit-vba/
のページで
＞#If vb7 Then の意味は、VBAのバージョンが 7.0 以降という意味になります。
＞ネットの情報をみると、#If win64 Then を使ったり、 #If VBA7 And Win64 then で
＞切り分けるというコードをみかけます。これでもエラーなく動作はします。
とVB7とVBA7両方の記述があって、
それを見ながら記述していて最初に試した際はVBA7、後に試した際はVB7で記載していました。
「エントリ"GetClipboardDataA"がDLLファイルuser32.dllの中に見つかりません」
の部分はいまだにわかっていないのですが、
Win32API_PtrSafe.TXT の記述は
Declare PtrSafe Function GetClipboardData Lib "user32" Alias "GetClipboardDataA" (ByVal wFormat As Long) As LongPtr
なのですが、それで記載してしまうと32bitの2021のVBAでは
「エントリ"GetClipboardDataA"がDLLファイルuser32.dllの中に見つかりません」
とエラーになり動かなくなってしまうのですが、
"GetClipboardDataA"を"GetClipboardData"と書き換えるとモジュール上で自動で
Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
と書き換えられ、試してみると2021の32bitのExcelでも動くようになりました。
※当初コードが"user32.dll"だったので、手書きで.dllを書き加えて使用しようと考えています。
※64bitではまだ試せていません。
@7shiさんのコードを真似てうまくいかないなと思っていた件に関しては、
@7shiさんが条件分けを
#If VBA7 And Win64 Then
としているのに、私が条件分けを#If VBA7で済ませようとしてしまって、
LongLongは32bitエクセルで使用できないのでそこで引っかかってしまってエラーだったのではないかと
予想しています。
"GetClipboardDataA"を"GetClipboardData"と書き換えて2021の64bitのエクセルでも動くかどうかを
明日確認します。
（Ｏ．Ｍ） 2024/02/13(火) 21:27:19
Win32API_PtrSafe.TXT の記述で
Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
だった部分は、コード内の呼び出しが
CopyMemory Destination Source Length
といった使用方法でしたので、Anyでも当初のlongにptrをつけてLongptrにしたものでもどちらでも
動きました。
※当初コード
'メモリをコピーします
Private Declare PtrSafe Sub CopyMemory Lib "kernel32.dll" _
Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, _
ByVal Length As Long)
（Ｏ．Ｍ） 2024/02/13(火) 21:50:37
前トピ([[20240205135924]])にもリンク貼ってますけど、「VB7」というコンパイラ定数は無さそうですね。^^; コンパイラ定数 (VBA) | Microsoft Learn https://learn.microsoft.com/ja-jp/office/vba/language/concepts/getting-started/compiler-constants > "GetClipboardDataA"を"GetClipboardData"と書き換えて2021の64bitのエクセルでも動くかどうか なるほど。言われてみれば・・・ そういや「GetClipboardData」でエイリアスなしのまま使うことの方が多い気がします。 それに "GetClipboardDataW" って書いてあるのも見た事がありません。
GetClipboardData 関数 (winuser.h) - Win32 apps | Microsoft Learn
https://learn.microsoft.com/ja-jp/windows/win32/api/winuser/nf-winuser-getclipboarddata
↑この近辺にもANSI バージョンの同名の関数は見当たらないですし、 これは「Win32API_PtrSafe.TXT」の方が間違いなのかも知れませんね、
指定された DLL 関数が見つかりません (エラー 453) | Microsoft Learn
https://learn.microsoft.com/ja-jp/office/vba/language/reference/user-interface-help/specified-dll-function-not-found-error-453
> 一部の 32 ビット DLL には、 Unicode 文字列と ANSI 文字列の両方に対応するために、バージョンが若干異なる関数が含まれています。 > 関数名の末尾にある "A" は、ANSI バージョンを指定します。 > 関数名の末尾にある "W" は、Unicode バージョンを指定します。
Windows API AとWどちらがお得？ #Windows - Qiita
https://qiita.com/kawasaki3/items/6f7b64617680b138fcc4
> AとWの違い > Aはマルチバイト文字を扱い、Wはユニコード文字を扱います。 > charはサイズが1byteであり、wchar_tは2byteです。 > charでも表現に2byteが必要な日本語などを扱う事はできますが、(〜中略〜)環境依存文字を扱う事ができません。 > よって、日本でお仕事をするなら、Wを使用する事が求められます。
（白茶） 2024/02/14(水) 09:06:56
ついでに...
RtlMoveMemory 関数 (Wdm.h) - Win32 apps | Microsoft Learn
https://learn.microsoft.com/ja-jp/windows/win32/devnotes/rtlmovememory
によるとLengthは「SIZE_T型」と言うことです。「符号なし整数」という抽象的な型ですね。 「OSで扱えるメモリの最大サイズに依存するからね」って意味なんでしょうから、まあ「LongPtr」が妥当なんでしょう。 どちらかというと「上限」を意識した制限だと思いますので、 「そんなデカいメモリサイズの移動なんかしないよ」って事なら、別にLong決め打ちでも差し支えは無いと思います。
それと、Any ってのは何らかのポインタが入る想定ですので、型としては結局 LongPtr と同じ意味です。 違いはByValなのかByRefなのかも含めての「なんでも」として定義する必要がある時に使うモノな様です。 (値渡しをしたい時は、関数を使うタイミングで引数に「ByVal」を付けて渡す)
（白茶） 2024/02/14(水) 10:13:10
いろいろとありがとうございます。
複数の間違いを同時に行ってしまって大混乱でした。
何がわかっていないのかもわかっていないような状態でしたので、
ご説明いただき大変助かりました、ありがとうございます。
32bitのコードでは動いていたのですが、
64bitでは型が一致しないというエラーが出てしまい悩まされまくったのですが
配列を使用しており
、
https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q13272119478
https://learn.microsoft.com/en-us/openspecs/microsoft_general_purpose_programming_languages/ms-vbal/d5418146-0bd2-45eb-9c7a-fd9502722c74
に記載のある、
・配列のBoundはLong型の範囲
・LongLong型はVariant型以外への暗黙の変換ができず明示的な変換が必要
に引っかかっていたのが原因でした。
※LongPtrにしていた部分が、32bitではLong、64bitではLongLongとなり、
64bitの場合配列のサイズオーバーでエラーだったのだと思います。
原因は下記のような部分でした。
#If VBA7 Then
Dim lngDataSize As LongPtr #Else Dim lngDataSize As Long #End If
lngDataSize = GlobalSize(lngMemoryHandle)
ReDim bytClipBoardData(lngDataSize)
64bitでLongLong(Longptr)になるように絶対に直さないとエラーが出るのは下記だと思っており
FunctionをPtrSafe Function
hWnd As Long を hWnd As LongPtr
hMem As Long を hMem As LongPtr
白茶様のご指摘のように扱うデータ量が少ないならLongでも大丈夫な場合があるのではと考えて
使用しているコードの配列に関連する部分をLongPtrからLongに書き換えてみたところ希望動作で動きました。
変更した部分はGlobalSizeで
Win32API_PtrSafe.TXT の記載が
Declare PtrSafe Function GlobalSize Lib "kernel32" Alias "GlobalSize" (ByVal hMem As LongPtr) As LongPtr
となっていた部分を下記の記述に修正しました。
Private Declare PtrSafe Function GlobalSize Lib "kernel32.dll" (ByVal hMem As LongPtr) As Long
"GetClipboardDataA"の件は、64bitのExcelでも32bitのExcelと同様に"GetClipboardDataA"だとエラーとなり動かなかったため、
Private Declare PtrSafe Function GetClipboardData Lib "user32.dll" _
(ByVal wFormat As Long) As LongPtr
にしました。
理解度でいうとまだまだ低い状態だとは思いますが、希望動作ができるようになりましたので、
こちらで質問を終了したいと思います。
ありがとうございました。
（Ｏ．Ｍ） 2024/02/14(水) 12:04:06
解決したご様子なので蛇足となってしまいますが・・・
ご提示の知恵袋でも回答が付いてますけど、 CLng関数でlngDataSizeをLong型に変換すれば配列のサイズ指定には使えると思います。
> ReDim bytClipBoardData(lngDataSize)
↓
ReDim bytClipBoardData(CLng(lngDataSize))
GlobalSizeの戻り値もRtlMoveMemoryと同じく「SIZE_T型」で値の意味も「バイト単位のサイズ」という事ですから CLngでオーバーフロー食らっちゃう数値が入る事もたぶん無いでしょう。
まぁ「だったらLongでええやん」とも言えますので結論に変わりはないですが ^^;
（白茶） 2024/02/14(水) 15:55:28
丁寧に教えていただきありがとうございます。
理解したつもりになっていたのですが類似の内容で変換が上手くいかないため、
教えていただきたいです。
フォント一覧を記載するコードなのですが、
32bitのExcelで動いていたものを64bitのExcelで動かすことができません。
取得したいのは日本語(ShiftJIS)の TrueTypeフォント一覧です。
※Jw_cad for Windowsというソフトで使用できるフォント一覧を取得したいという意図です。
※取得できれば手段は問わないので、
同じ結果になる別の方法も探したのですが同じ結果になる方法が探せませんでした。
下記サイトのコードがすっきりしていていいとは思ったのですが、
取得するフォントの種類が多く希望結果にならず、
日本語(ShiftJIS)の TrueTypeフォント一覧にフォント種別を絞る方法が
わかりませんでした。
https://vbabeginner.net/get-the-available-font-types/
標準モジュールに下記内容を記載して32bitのExcelでTest1を実行したさいに記載されるフォントが得たい結果になります。
Option Explicit
Public Const LF_FACESIZE = 32
Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(1 To LF_FACESIZE) As Byte
End Type
Type TEXTMETRIC
tmHeight As Long
tmAscent As Long
tmDescent As Long
tmInternalLeading As Long
tmExternalLeading As Long
tmAveCharWidth As Long
tmMaxCharWidth As Long
tmWeight As Long
tmOverhang As Long
tmDigitizedAspectX As Long
tmDigitizedAspectY As Long
tmFirstChar As Byte
tmLastChar As Byte
tmDefaultChar As Byte
tmBreakChar As Byte
tmItalic As Byte
tmUnderlined As Byte
tmStruckOut As Byte
tmPitchAndFamily As Byte
tmCharSet As Byte
ntmFlags As Long
ntmSizeEM As Long
ntmCellHeight As Long
ntmAveWidth As Long
End Type
Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, _
ByVal hdc As Long) As Long
Declare Function EnumFonts Lib "gdi32" Alias "EnumFontsA" _
(ByVal hdc As Long, _
ByVal lpsz As String, _
ByVal lpFontEnumProc As Long, _
ByVal lParam As Long) As Long
Public JwwFontList As Variant
Public JwwFontType As Boolean
Public Const TMPF_TRUETYPE = &H4
Public Function EnumFontsProc(lplf As LOGFONT, _
lptm As TEXTMETRIC, _
ByVal dwType As Long, _
ByVal lParam As Long) As Long
'フォント名を表示
If (lptm.tmCharSet = 128) And (lptm.tmPitchAndFamily And 4) Then
If JwwFontList(0) = Empty Then
If JwwFontType = False Or JwwFontType = True And (Left(StrConv(lplf.lfFaceName(), vbUnicode), 1) <> "@") Then
JwwFontList(0) = StrConv(lplf.lfFaceName(), vbUnicode)
End If
Else
If JwwFontType = False Or JwwFontType = True And (Left(StrConv(lplf.lfFaceName(), vbUnicode), 1) <> "@") Then
ReDim Preserve JwwFontList(UBound(JwwFontList) + 1)
JwwFontList(UBound(JwwFontList)) = StrConv(lplf.lfFaceName(), vbUnicode)
End If
End If
End If
EnumFontsProc = True
End Function
Sub Test1()
Dim lngDc As Long, i As Long
Dim st As Worksheet
Dim rn As Range
Set st = ThisWorkbook.ActiveSheet
Set rn = st.Cells(1, 1)
i = st.Cells(Rows.Count, 1).End(xlUp).row
'フォントリスト取得
JwwFontType = True 'True:@タイプ文字を取得しない 'False：@タイプ文字を取得する
ReDim JwwFontList(0)
lngDc = GetDC(Application.hWnd)
'EnumFonts関数で列挙
Call EnumFonts(lngDc, vbNullString, AddressOf EnumFontsProc, 0)
Call ReleaseDC(Application.hWnd, lngDc)
'JwwFontTypeの配列にjwwで使用できる文字が取得されるので好きに使用する
rn.Resize(i, 1).ClearContents
rn.Value = "フォント一覧"
rn.Offset(1, 0).Resize(UBound(JwwFontList) + 1, 1) = Application.Transpose(JwwFontList)
End Sub
64bitのExcelと兼用にしたいのですが、
AddressOf EnumFontsProcの部分の変更方法がわからずうまく動かせません。
※私が考えた64bit用のコードですと、ブックが強制終了されて壊れてセーフモード起動になってしまいました。
Call EnumFonts(lngDc, vbNullString, AddressOf EnumFontsProc, 0)
Public Function EnumFontsProc(lplf As LOGFONT, _
lptm As TEXTMETRIC, _
ByVal dwType As Long, _
ByVal lParam As Long) As Long
'フォント名を表示
If (lptm.tmCharSet = 128) And (lptm.tmPitchAndFamily And 4) Then
If JwwFontList(0) = Empty Then
If JwwFontType = False Or JwwFontType = True And (Left(StrConv(lplf.lfFaceName(), vbUnicode), 1) <> "@") Then
JwwFontList(0) = StrConv(lplf.lfFaceName(), vbUnicode)
End If
Else
If JwwFontType = False Or JwwFontType = True And (Left(StrConv(lplf.lfFaceName(), vbUnicode), 1) <> "@") Then
ReDim Preserve JwwFontList(UBound(JwwFontList) + 1)
JwwFontList(UBound(JwwFontList)) = StrConv(lplf.lfFaceName(), vbUnicode)
End If
End If
End If
EnumFontsProc = True
End Function
上記の部分はどのように書き換えたらよいのでしょうか？
64bitのExcelで試して失敗するコードは下記のようなコードなどです。
※会社で失敗して自宅に戻って思い出しながら修正したので（自宅は32biのため試せない）
別の場所でも64bit用に修正できていない箇所があるかもしれません。
Option Explicit
Public Const LF_FACESIZE = 32
Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(1 To LF_FACESIZE) As Byte
End Type
Type TEXTMETRIC
tmHeight As Long
tmAscent As Long
tmDescent As Long
tmInternalLeading As Long
tmExternalLeading As Long
tmAveCharWidth As Long
tmMaxCharWidth As Long
tmWeight As Long
tmOverhang As Long
tmDigitizedAspectX As Long
tmDigitizedAspectY As Long
tmFirstChar As Byte
tmLastChar As Byte
tmDefaultChar As Byte
tmBreakChar As Byte
tmItalic As Byte
tmUnderlined As Byte
tmStruckOut As Byte
tmPitchAndFamily As Byte
tmCharSet As Byte
ntmFlags As Long
ntmSizeEM As Long
ntmCellHeight As Long
ntmAveWidth As Long
End Type
#If Win64 Then
Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, _
ByVal hdc As LongPtr) As Long
Declare PtrSafe Function EnumFonts Lib "gdi32" Alias "EnumFontsA" _
(ByVal hdc As LongPtr, _
ByVal lpsz As String, _
ByVal lpFontEnumProc As LongPtr, _
ByVal lParam As LongPtr) As Long
#Else
Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, _
ByVal hdc As Long) As Long
Declare Function EnumFonts Lib "gdi32" Alias "EnumFontsA" _
(ByVal hdc As Long, _
ByVal lpsz As String, _
ByVal lpFontEnumProc As Long, _
ByVal lParam As Long) As Long
#End If
Public JwwFontList As Variant
Public JwwFontType As Boolean
Public Const TMPF_TRUETYPE = &H4
Public Function EnumFontsProc(lplf As LOGFONT, _
lptm As TEXTMETRIC, _
ByVal dwType As Long, _
ByVal lParam As Long) As LongPtr
'フォント名を表示
If (lptm.tmCharSet = 128) And (lptm.tmPitchAndFamily And 4) Then
If JwwFontList(0) = Empty Then
If JwwFontType = False Or JwwFontType = True And (Left(StrConv(lplf.lfFaceName(), vbUnicode), 1) <> "@") Then
JwwFontList(0) = StrConv(lplf.lfFaceName(), vbUnicode)
End If
Else
If JwwFontType = False Or JwwFontType = True And (Left(StrConv(lplf.lfFaceName(), vbUnicode), 1) <> "@") Then
ReDim Preserve JwwFontList(UBound(JwwFontList) + 1)
JwwFontList(UBound(JwwFontList)) = StrConv(lplf.lfFaceName(), vbUnicode)
End If
End If
End If
EnumFontsProc = True
End Function
Sub Test1()
Dim i As Long
Dim st As Worksheet
Dim rn As Range
#If Win64 Then
Dim lngDc As LongPtr
#Else
Dim lngDc As Long
#End If
Set st = ThisWorkbook.ActiveSheet
Set rn = st.Cells(1, 1)
i = st.Cells(Rows.Count, 1).End(xlUp).row
'フォントリスト取得
JwwFontType = True 'True:@タイプ文字を取得しない 'False：@タイプ文字を取得する
ReDim JwwFontList(0)
lngDc = GetDC(Application.hWnd)
'EnumFonts関数で列挙
Call EnumFonts(lngDc, vbNullString, AddressOf EnumFontsProc, 0)
Call ReleaseDC(Application.hWnd, lngDc)
'JwwFontTypeの配列にjwwで使用できる文字が取得されるので好きに使用する
rn.Resize(i, 1).ClearContents
rn.Value = "フォント一覧"
rn.Offset(1, 0).Resize(UBound(JwwFontList) + 1, 1) = Application.Transpose(JwwFontList)
End Sub
（Ｏ．Ｍ） 2024/02/15(木) 20:38:47
結論を先に言っておきますと「分かりませんでした」^^;
ざっと見、特に致命的なのは見受けられなかった様に思うのですが・・・ (64bit/32bit どちらでも動くのは動くと思う) こっちでも試してみましたけどクラッシュまではしませんでした。まぁ、そこは「コールバックあるある」ですね ^^;
したがって、その辺直してみたところで状況変わらない可能性が高い気がしますが、 一応気になったところだけ手を加えてみました。(API宣言に関する箇所のみです。全体の内容は理解してません。^^; )
今回も「#If Win64 Then」の分岐が要らない、ってのがメインですね。(書くならこの場合「#If VBA7 Then」です) hatenaさんの chips に対してもう少し理解を進めないとイケませんネー そこに関しては前トピから続く本トピの発端でもありますし。
Option Explicit
Public Const LF_FACESIZE = 32
Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(1 To LF_FACESIZE) As Byte
End Type
Type TEXTMETRIC
tmHeight As Long
tmAscent As Long
tmDescent As Long
tmInternalLeading As Long
tmExternalLeading As Long
tmAveCharWidth As Long
tmMaxCharWidth As Long
tmWeight As Long
tmOverhang As Long
tmDigitizedAspectX As Long
tmDigitizedAspectY As Long
tmFirstChar As Byte
tmLastChar As Byte
tmDefaultChar As Byte
tmBreakChar As Byte
tmItalic As Byte
tmUnderlined As Byte
tmStruckOut As Byte
tmPitchAndFamily As Byte
tmCharSet As Byte '←◆ホントは[TEXTMETRIC]の場合はここまでらしいです
ntmFlags As Long '←◆ここから下の部分が追加されているのは[NEWTEXTMETRIC]だとか書いてあったっス
ntmSizeEM As Long
ntmCellHeight As Long
ntmAveWidth As Long
End Type
'▼▼▼ 分岐不要です ******************************************************************************************************▼
'#If Win64 Then '書くんならこの場合「#If VBA7 Then」
Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hdc As LongPtr) As Long
Declare PtrSafe Function EnumFonts Lib "gdi32" Alias "EnumFontsA" (ByVal hdc As LongPtr, ByVal lpsz As String, ByVal lpFontEnumProc As LongPtr, ByVal lParam As LongPtr) As Long
'#Else
' Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
' Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
' Declare Function EnumFonts Lib "gdi32" Alias "EnumFontsA" (ByVal hdc As Long, ByVal lpsz As String, ByVal lpFontEnumProc As Long, ByVal lParam As Long) As Long
'#End If
'▲▲▲______________________________________________________________________________________________________________________▲
Public JwwFontList As Variant
Public JwwFontType As Boolean
Public Const TMPF_TRUETYPE = &H4
'▼▼▼ 一部修正しました (でもたぶん、あんまり関係ないと思う)**************************************************************▼
'Public Function EnumFontsProc(lplf As LOGFONT, lptm As TEXTMETRIC, ByVal dwType As Long, ByVal lParam As Long) As LongPtr
Public Function EnumFontsProc(lplf As LOGFONT, lptm As TEXTMETRIC, ByVal dwType As Long, ByVal lParam As LongPtr) As Long
'▲▲▲______________________________________________________________________________________________________________________▲
'フォント名を表示
If (lptm.tmCharSet = 128) And (lptm.tmPitchAndFamily And 4) Then
If JwwFontList(0) = Empty Then
If JwwFontType = False Or JwwFontType = True And (Left(StrConv(lplf.lfFaceName(), vbUnicode), 1) <> "@") Then
JwwFontList(0) = StrConv(lplf.lfFaceName(), vbUnicode)
End If
Else
If JwwFontType = False Or JwwFontType = True And (Left(StrConv(lplf.lfFaceName(), vbUnicode), 1) <> "@") Then
ReDim Preserve JwwFontList(UBound(JwwFontList) + 1)
JwwFontList(UBound(JwwFontList)) = StrConv(lplf.lfFaceName(), vbUnicode)
End If
End If
End If
EnumFontsProc = True
End Function
Sub Test1()
#If Win64 Then '*** 確認用に追記 *************{
Debug.Print Now; "Running in 64-bit ver"
#Else
Debug.Print Now; "Running in 32-bit ver"
#End If '}____________________________________/
Dim i As Long
Dim st As Worksheet
Dim rn As Range
'▼▼▼ 分岐不要です ********************************▼
' #If Win64 Then '書くんならこの場合「#If VBA7 Then」
Dim lngDc As LongPtr
' #Else
' Dim lngDc As Long
' #End If
'▲▲▲________________________________________________▲
Set st = ThisWorkbook.ActiveSheet
Set rn = st.Cells(1, 1)
i = st.Cells(Rows.Count, 1).End(xlUp).Row
'フォントリスト取得
JwwFontType = True 'True:@タイプ文字を取得しない 'False：@タイプ文字を取得する
ReDim JwwFontList(0)
lngDc = GetDC(Application.hWnd)
'EnumFonts関数で列挙
Call EnumFonts(lngDc, vbNullString, AddressOf EnumFontsProc, 0)
Call ReleaseDC(Application.hWnd, lngDc)
'JwwFontTypeの配列にjwwで使用できる文字が取得されるので好きに使用する
rn.Resize(i, 1).ClearContents
rn.Value = "フォント一覧"
rn.Offset(1, 0).Resize(UBound(JwwFontList) + 1, 1) = Application.Transpose(JwwFontList)
End Sub
（白茶） 2024/02/15(木) 23:16:18
LongPtrが32bit ExcelでLong、64bitのExcelでLongLongなので
LongPtrで記載するなら32bit、64bit兼用できるのでWin64で分岐させる必要はなく、
Excel2007以前のExcelはLongPtrが使用できないので
If VBA7で分岐させるという話だとは理解しているつもりです。
ただ、現状32bitのExcelでは動いているので
動いているのはそのままにした方が思いがけないミスも減って怖くない気がしてしまうのと、
32bitExcelはLongPtrはLongになるので変更してもLongPtrにしても
結局は64bitのExcelでの動作が検証ができないので、
それならWin64でいいのではないかという気がしまして、Win64で分岐としました。
Excel2007以前では使用できなくていいと思ったら分岐自体を消してしまえばいいかなと…。
動作の異なる（エラーの出る）Win64だけで分岐させたい、
win64で分岐はさせるが将来Excel2007以前の使用をあきらめるなら分岐自体をなくすので、
Win64分岐ではあるがLongLongではなくLongPtrを使いたいといった感じです…すみません。
（Ｏ．Ｍ） 2024/02/15(木) 23:51:13
#IF Win64 Then
64bitのExcel用のコード ただし、将来IFでの分岐をなくす場合のために 64bit用のLongLongではなく64bitと32bit兼用のLongptrで記載 #Else Excel2007(Excel2003でも使用できたらうれしいが未検証）〜の 64bit以外のExcelの場合コード #End IF
という認識でコードを書いていました。
（Ｏ．Ｍ） 2024/02/16(金) 00:00:56
意図は分かりました。↓こちらの記事が参考になるんじゃないかと思います。
WinAPIの64bit化で出てくるPtrSafe､LongLong､LongPtrってなんなのさ？ - えくせるちゅんちゅん
https://www.excel-chunchun.com/entry/20200809-vba-declare-ptrsafe-longlong-longptr
> #If Win64 Then > '64bit限定 ※Excel2010以降限定 > Declare PtrSafe Function SetForegroundWindow Lib "User32" (ByVal hWnd As LongLong) As Long > #ElseIf VBA7 Then > '32bit限定 ※Excel2010以降限定 > Declare PtrSafe Function SetForegroundWindow Lib "User32" (ByVal hWnd As Long) As Long > #Else > '32bit限定 ※Excel2007以前対応 > Declare Function SetForegroundWindow Lib "User32" (ByVal hWnd As Long) As Long > #End If
> (LongLongが無い)32bit環境のためにWin64で分岐し、(PtrSafe・LongPtrが無い)Excel2007以前のためにVBA7で分岐しなければならない。 > これは、あまりにも冗長すぎるのではないだろうか？ > 同じ関数のために3回も同じようなことを書く羽目になっている。 > 3つ目は古いExcel用のため切り捨てられるとしても、最初の2つは書かないといけない。 > Microsoftは、これが未来永劫続くのを防ぐためにLongPtrを実装したのではないかと考られる。
段階を追って検証なさりたいと言うことでしたら、あえて↑の様に書けば良いのではないでしょうか? (要するにLongPtr型エイリアスの使用を一旦避けて通ってみる)
（白茶） 2024/02/16(金) 08:43:30
話題的にはちょっと逸れてしまうかも知れませんが、ついでにEnumFontsの第４引数[lParam]を活用した書き方の例。 ローカル変数でコールバックとのデータ受け渡しが出来るので、変数のスコープ広げたくない派の人はこっちですかね。
Option Explicit
'Logical Font
Private Const LF_FACESIZE = 32
Private Const LF_FULLFACESIZE = 64
'EnumFonts Masks
Private Const RASTER_FONTTYPE = &H1
Private Const DEVICE_FONTTYPE = &H2
Private Const TRUETYPE_FONTTYPE = &H4
'文字セット識別子
Private Const ANSI_CHARSET = 0
Private Const DEFAULT_CHARSET = 1
Private Const SYMBOL_CHARSET = 2
Private Const SHIFTJIS_CHARSET = 128
Private Const HANGEUL_CHARSET = 129
Private Const CHINESEBIG5_CHARSET = 136
Private Const OEM_CHARSET = 255
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(1 To LF_FACESIZE) As Byte
End Type
Private Type NEWTEXTMETRIC
tmHeight As Long
tmAscent As Long
tmDescent As Long
tmInternalLeading As Long
tmExternalLeading As Long
tmAveCharWidth As Long
tmMaxCharWidth As Long
tmWeight As Long
tmOverhang As Long
tmDigitizedAspectX As Long
tmDigitizedAspectY As Long
tmFirstChar As Byte
tmLastChar As Byte
tmDefaultChar As Byte
tmBreakChar As Byte
tmItalic As Byte
tmUnderlined As Byte
tmStruckOut As Byte
tmPitchAndFamily As Byte
tmCharSet As Byte
ntmFlags As Long
ntmSizeEM As Long
ntmCellHeight As Long
ntmAveWidth As Long
End Type
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
Private Declare PtrSafe Function EnumFonts Lib "gdi32" Alias "EnumFontsA" (ByVal hDC As LongPtr, ByVal lpsz As String, ByVal lpFontEnumProc As LongPtr, ByVal lParam As Collection) As Long
Rem -------------------------------------------------------------------------------------------------------------------------------
Private Function EnumFontsProc(lplf As LOGFONT, lptm As NEWTEXTMETRIC, ByVal dwType As Long, ByVal lParam As Collection) As Long
Rem *** 定数オプション***********************
' True: @タイプ文字を取得しない
' False：@タイプ文字を取得する
Const JwwFontType As Boolean = True
Rem _________________________________________
Dim fn As String
If (lptm.tmCharSet = SHIFTJIS_CHARSET) And (lptm.tmPitchAndFamily And TRUETYPE_FONTTYPE) Then
fn = StrConv(lplf.lfFaceName(), vbUnicode)
If Not JwwFontType Or (JwwFontType And (Left(fn, 1) <> "@")) Then lParam.Add fn
End If
EnumFontsProc = 1
End Function
Sub Test2()
Dim rtnColl As New Collection, v(), i As Long
Dim lngDc As LongPtr
lngDc = GetDC(Application.hwnd)
Call EnumFonts(lngDc, vbNullString, AddressOf EnumFontsProc, rtnColl)
Call ReleaseDC(Application.hwnd, lngDc)
If rtnColl.Count Then
Columns(1).ClearContents
Cells(1, 1).Value = "フォント一覧"
ReDim v(1 To rtnColl.Count, 1 To 1)
For i = 1 To rtnColl.Count
v(i, 1) = rtnColl.Item(i)
Next
Cells(2, 1).Resize(rtnColl.Count) = v
Else
MsgBox "該当なし", vbExclamation
End If
End Sub
（白茶） 2024/02/16(金) 11:37:25
提示いただきました両方のコードで64bitで動きました。
後から書いていただいたコードはまだしっかりと理解はできていないのですが、
どうすればよいか分からず無理やり気味なコードにしていた箇所が
スッキリしたコードとなっているので頑張って勉強させていただきます。
ありがとうございます。
最初のコードの
Private Function EnumFontsProc(lplf As LOGFONT, lptm As NEWTEXTMETRIC, ByVal dwType As Long, ByVal lParam As Collection) As Long
の部分は64bitの場合は
Private Function EnumFontsProc(lplf As LOGFONT, lptm As NEWTEXTMETRIC, ByVal dwType As Long, ByVal lParam As Collection) As Longptr
でも動きました。
※LongptrにするとExcel2007以前は動かないと思っています。
また、私が64bitで動かないと記載したコードも64bitのExcelで動きました。
ブックが破損したものをセーフモードで復旧して使用していたので何を試してもエラーが出ていたか、
誤字があったのかなにか別の理由でエラーになっていたようです。
どう書き換えてもだめだったのが、
実際に使用するデータの破損前の少し古いデータを書き換えたらあっさり動きました。
失礼いたしました。
※破損する少し前のExcelデータを書き直したらあさり動きました。
#IF Win64 Then
64bitのExcel用のコード ただし、将来IFでの分岐をなくす場合のために 64bit用のLongLongではなく64bitと32bit兼用のLongptrで記載 #Else Excel2007(Excel2003でも使用できたらうれしいが未検証）〜の 32bitのExcel #End IF
の分け方で、
#If Win64 Then
Dim lngDc As LongPtr
#Else
Dim lngDc As Longptr
#End If
と間違えて記載してしまうとExcel2007以前で動かないという事はあると思うので、
エラーが出たら確認して
#If Win64 Then
Dim lngDc As LongPtr
#Else
Dim lngDc As Long
#End If
に書き直すといった方法で作業するといった想定で運用していました。
（Ｏ．Ｍ） 2024/02/16(金) 13:51:00
最終的に「動くんならどっちでもイイよ」とするならそれはそれではありますが、^^;
> 〜略〜) As Longptr > でも動きました。
についてだけ一応。
EnumFontsA 関数 (wingdi.h) - Win32 apps | Microsoft Learn
https://learn.microsoft.com/ja-jp/windows/win32/api/wingdi/nf-wingdi-enumfontsa
EnumFontsProc callback function (Windows) | Microsoft Learn
https://learn.microsoft.com/ja-jp/previous-versions/dd162623(v=vs.85)
によると、
> 構文(C++) > int EnumFontsA( > [in] HDC hdc, > [in] LPCSTR lpLogfont, > [in] FONTENUMPROCA lpProc, > [in] LPARAM lParam > );
> Syntax(C++) > int CALLBACK EnumFontsProc( > _In_ const LOGFONT *lplf, > _In_ const TEXTMETRIC *lptm, > _In_ DWORD dwType, > _In_ LPARAM lpData > );
と「int型」で定義されていますし、
> 意味は、アプリケーションによって定義されます。
とも書いてあります。 書き手が自分で決める範疇のものであって、OSに依存する内容ではないものと思われます。
少なくとも「型エイリアス」で定義する意味はありません。
また 【C言語/C++】データ型のサイズ・範囲の一覧【32bit/64bit環境】 | MaryCore https://marycore.jp/prog/c-lang/data-type-ranges-and-bit-byte-sizes/ を見ても、 Windows64bit環境は「LLP64」とかいうデータモデルに当たるので、 上記構文の「int」は 4バイトとして解釈するのが妥当かと思います。
（白茶） 2024/02/16(金) 15:02:10
難しいことは全然わかっておらず、おそらく白茶様の想定外の考え方をしてしまっていると思います。
”送った側と受ける側の型式を合わせる”ことができればエラーが出ない、
CLngnなどで型式を合うように変換することもできるというほわっとした思考です。
CLng関数は、引数を評価して整数型「-2,147,483,648 〜 2,147,483,647」を返します。
CLngに関しては引数を評価という部分がどういう事なのかわからず、
Variant型で数字以外のデータが入っていたり、
LongLongで数値よりも大きい数になってしまうとエラーになるのかなと考えていました。
LongPtrでもLongでも動いたと書いた部分ですが、
Declare PtrSafe Function EnumFonts Lib "gdi32" Alias "EnumFontsA" (ByVal hdc As LongPtr, ByVal lpsz As String, ByVal lpFontEnumProc As LongPtr, ByVal lParam As LongPtr) As Long
で３番目の引数のByVal lpFontEnumProc As LongPtrがLongPtrなので、
Call EnumFonts(lngDc, vbNullString, AddressOf EnumFontsProc, 0)
呼び出しの３番目のAddressOf EnumFontsProcはlongPtrで合わせないといけないという認識だったため、
Public Function EnumFontsProc(lplf As LOGFONT, lptm As TEXTMETRIC, ByVal dwType As Long, ByVal lParam As Long) As LongPtr
とかいて
EnumFontsProc() As LongPtrでEnumFontsProcの戻り値？をLongPtrにすると動くのではという認識でした。
※それだとExcel2007以前のExcelでコードを走らせたときにLongptrの部分でエラーという認識は
ありました。
AddressOfの意味がわからず、調べても
＞引数リストの特定の位置で関数ポインターを受け取る API プロシージャに対して、
＞この演算子の後に指定されたプロシージャのアドレスを渡す単項演算子。
となあったのですがどういう事を言ってるのかがわからず最初に質問にあげさせていただきました…。
（何が原因だったかしっかりとした原因はわからないのですが３番目の引数をLongで統一してみたり
いろいろ書き換えて試しても、上記のコード部分で止まってブックが破損になって
セーフモードになっていたのでAddressOfでセルのアドレスみたいなデータが入るのだろうかと
最初にこの件で質問した時点では思考が迷走していました）
型式をLongかLongPtrで合わすという認識があったので、
ByVal lpFontEnumProc As LongPtr と EnumFontsProc() As LongPtr
で動いて
ByVal lpFontEnumProc As LongPtr と EnumFontsProc() As Long
でも動いたのでどうしてなのかわからないけどAddressOfが何か作用しているのかなと思い、
どちらでも動いたと記載しました。
という感じの非常に理解不足な状態の手探り作業です…。
張っていただいたページの用語が例えるなら中国語みたいな
呼んでもわかるようなわからないような外国語に見えるような状態で
全然理解ができておりません、申し訳ございません。
（Ｏ．Ｍ） 2024/02/16(金) 20:33:37
(遅くなってしまった。もう見てらっしゃらないかなぁ... ^^;)
こちらこそ、なんか一方的にベラベラとスミマセンでした。 現段階ではあんま気にしなくてもいい所だったかもしれませんけどね、つい... ^^;
要するに 「戻り値に関してはLongPtrじゃなくてLong決め打ちだと思いますよ」と言いたかっただけです。
仮にEnumFontsもEnumFontsProcも両方「As LongPtr」として定義したとしましょう。 で、 64ビット版でEnumFontsProcの戻り値に「&HFFFFFFFF00000001^」をセットしたとします。 でも最終的にEnumFontsが返す戻り値は下位32ビットだけ(つまり「&H00000001」)です。 上位半分は無視されます。 戻り値については64ビットで定義しても意味ありません。って事ですね。
※ ※ ※
ついでにもう少し。(もうココから先は聞き流して頂いて結構です ^^;)
今回のコールバックは戻り値が「ゼロ以外の値」であれば何でも良かったので 当初ご提示されたコールバック関数は戻り値に「True」を入れてらっしゃいますが、 > EnumFontsProc = True
これ、整数型に変換すると「-1」なんですよね。 Integerでは &HFFFF% Longなら &HFFFFFFFF& LongLongだと &HFFFFFFFFFFFFFFFF^
数値としては同じ「-1」なんですけど、バイナリとしては結構な違いです。 APIを使ってると(だけじゃないですが)そういう部分も気にしないといけない場面が度々出てくると思います。
ご承知の通り、VBAは符号なし整数型をサポートしてません。 仰るところの > 整数型「-2,147,483,648 〜 2,147,483,647」 これ16進数表記すると 前半(下半分)が正数 0 〜 2,147,483,647 (&H0 〜 &H7FFFFFFF) で 後半(上半分)が負数 -2,147,483,648 〜 -1 (&H80000000 〜 &HFFFFFFFF) なんですね。 1ずつ足して行ったら半分超えた時点でマイナスの一番小さい値にジャンプして、 んで、更に1ずつ足して行ったらゼロ方向に向かって「-1」まで増えていきます。
対してAPIでよく登場するDWORD型なんかは「32ビット符号なし整数」なので 範囲は 0 〜 4,294,967,295 半分より上の大きい値は、Long型に入れると負数として受け取っているかの様な状況になります。 後続の処理で取得した値を「大小比較」する様な場合は要注意ですね。
それこそ先に例示させて頂いた「timeGetTime」なんかは(Longで受け取ると)PC起動から25日経過したら負数を返すようになります。 タイマー的な使い方してるプログラムでこれ考慮してないと、25日目に動かなくなったりするんですよね ^^;
あと「DWORD値なんだけどLongPtrで受け取るヤツ」とか、 32ビット環境では「正数か負数か」で判断してりゃ良かった仕組みが、 64ビット環境ではそうはいかなくなってビット演算や変換関数が必要になったりとか... (これについては元々「正数か負数か」で判断していたのが間違だったと言わざるを得ないですが)
（白茶） 2024/02/19(月) 22:57:35
いろいろと丁寧にありがとうございます。
＞仮にEnumFontsもEnumFontsProcも両方「As LongPtr」として定義したとしましょう。
で、 ＞ 64ビット版でEnumFontsProcの戻り値に「&HFFFFFFFF00000001^」をセットしたとします。 ＞でも最終的にEnumFontsが返す戻り値は下位32ビットだけ(つまり「&H00000001」)です。 ＞上位半分は無視されます。 ＞戻り値については64ビットで定義しても意味ありません。って事ですね。
こちらはなんとなくわかったような気がします。
それ以下は思っていたより難しいということがやっと分かった程度で
しっかりとは理解できておらず申し訳ございません。
いま現在悩んでいる浮動小数点演算誤差もデータ型が関係していると思うので
理解は必要だと思うのですがなかなか頭が追いつかず…。
何度もご丁寧な説明をくださり本当にありがとうございました。
見返したときに意味が分かるようになれるよう少しずつ勉強します。
（Ｏ．Ｍ） 2024/02/20(火) 21:11:59
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.