VBScript
Win32API
発掘
Dynacall

発掘:今更でもDynaCall(G.Born氏製)をVBSで使おう


発掘の趣旨

G.Born氏製DynWrap.DLL向けのサンプルはここ www.geocities.jp/seiotaq/DynaHP/index.html しかなく、当時の記事がリンク切れである。

このページは2005年7月から2009年8月まで存在していた。

これではVBScriptからWin32APIの使用は進まない。

レイアウトはQiita表記にしたが、明らかに構造化されている。

またVBScriptの記述がものすごい。

この貴重な知見を今に伝えるべく、発掘するものである。

またDynaCall(DynaWrap)はPythonからも使われており、この記事は今なお意味があるものである。


今更でもDynaCall(G.Born氏製)をVBSで使おう By OtaQ


履歴

’05 7下 公開

’05 8上 3.6、7追加

’05 8中 HP内リンク追加

’05 9下 G.Born氏製DynWrap.DLL向けを明記、0を追加

' 05 10中 4.、4.1追加


表題の通りDynaCall(DynWrap.DLL)をVBS(VisualBasicScript)で使う方法を開陳する


留意事項

VBSおよびCOM、Win32APIについて理解してから読むことを強く勧める。

参考リンクは張っていないので検索サイトなどで各々調べて欲しい。当方へ

質問しても答えない。

当方の環境はWin98のみであるため、現在主流の環境ではこのサイトの情報を

確認していない。XP等はセキュリティ対策のメモリ保護機能に触れる可能性は高い。

しかし他の環境ではWin32APIの文字コードの扱いが異なる点以外はDynaCall実行において大きな違いは無いと考えている。

当HPの参照、サンプルの私用は各人自由に行って良い。連絡無用。

このサイトの記述は当方が調べた事を元にしている。必ず正しいとも安全とも

限らないので、それを実行した場合の結果に当方は責任を負えない。


目次

0.不具合修正版DynWrap.DLL

1.VBSでDynaCallを使うための基礎情報

2.VBS用のDynaCallフォロー関数サンプル

3.DynaCallフォロー関数を用いたWin32API使用サンプル

3.1 OS情報取得

3.2 マウスカーソル操作

3.3 ウインドウ操作

3.4 クリップボード操作

3.5 レジストリ列挙

3.6 ウインドウ列挙

3.7 マウスボタン操作

4.DynaCallフォロー関数を用いたDLL API使用サンプル

4.1 統合アーカイバUnLha32.DLLのコマンドラインパラメータによる使用


本編


0.不具合修正版DynWrap.DLL

 詳細は未確認ながら「DynamicWrapperの不具合を改善し、新たなメソッドを

追加」したDynWrap.DLLが存在する(’05 9下現在)。大幅に使い勝手が良くなっているようだが

G.Born氏による原版とは不具合の修正故に挙動が異なる。当方では原版を

対象にしている。


1.VBSでDynaCallを使うための基礎情報

 VBSでDynaCallを付属ドキュメント記述どおりに使用しても思うように

機能しない場合が多い。これはDynaCallの記憶領域の扱いが異常なためと

考えられる。また構造体を返すAPIを使用するために1まとまりの記憶領域を

APIに渡す必要がある。これらの問題を解消するため文字列の記憶領域を

直接APIに渡す方法が考えられる。この方法を試すべくDynacallおよびVBSの

文字列の扱いについて調べた結果を記す。


A.Win9x系とWinNT系

 Win32APIにおいてWin9x系はほとんどの文字列操作APIでANSICODEを用い

WinNT系はUNICODEを用いている。またVBS,JScriptではOSに限らずUNICODEを

文字列に用いている。Win9x用のDynaCallはこれらのため引数型の指定に

よりUNICODEからANSICODEへの変換を自動で行える(i="s")。またWin32APIの

文字列操作APIは関数名の終端にAまたはWをつけて文字コード毎にAPIを指定

できるが、関数名終端にA、Wどちらもついていない場合関数呼出しに失敗したら

関数名にAを付加して再度呼び出している。

 またWin9x系用のDynaCallはDynamicWrapperのインスタンスを呼び出す

DLL関数毎に作成する必要がある。


B.VARIANTとBSTR

 VBSでは変数をVARIANT型で保持している。先頭2バイトにVARIANT変数が

格納している型情報を持ち、先頭から8バイト目に格納したデータがそのサイズに応じて入っている。文字列変数の場合、実体がBSTR型でありそのアドレスがデータとしてVARIANT変数に入っている。これらの管理はVBSがCOM APIを使用して行っていると考えられるので型情報やBSTR型の文字列長書換え、取得したBSTRの記憶領域を超えたメモリのアクセス等は厳禁。しかしBSTR文字列自体は書換え可能である。よってBSTRのアドレスを取得すれば1まとまりの記憶領域として利用できる。


C.VBSの変数、定数

 Win9xでDynaCallがVBSの文字列に関してDLLにどのような引数を渡しているか調べたところ、以下が判明した。


C.a. 文字列定数(リテラル、Const定義識別子)

引数指定
結果

s
W->A変換後の文字列を渡す

w
変換せずにBSTRアドレスを渡す

r
W->A変換後の文字列を渡す


C.b. 文字列変数

引数指定
結果

s
W->A変換後の文字列を渡す

w
変換せずにVARIANT変数アドレスを渡す

r
W->A変換後の文字列を渡す

 C.a.およびC.b.より引数型指定にwを用いればDLLにBSTRまたはVARIANTアドレスが渡る。

Win32APIのLstrcatは実行に成功すれば第一引数を返すのでこれを用いてBSTRまたはVARIANT文字列変数アドレスを取得できる。

またVBSでは全く同じ文字列定数が複数存在する場合同じ記憶領域の文字列を用いるのでバッファに文字列定数を用いる場合注意する必要がある。


2.VBS用のDynaCallフォロー関数サンプル

' 引数はデフォルトでByRefだが、ByRefを意識する部分は明示している

' VBS用のDynaCallフォロー関数サンプル

Const DynaCallFollowError=10000

' VARIANT変数の実体アドレス取得
' 引数変数を文字列変数に変換するので初期化していない変数を対象とする
' アドレス取得後に格納内容を変更してもVARIANT変数のアドレスは変化しない
Function VarPtr(ByRef v)
Dim dw
v=""
Set dw=CreateObject("DynamicWrapper")
dw.Register "kernel32.dll","lstrcat","f=s","i=ws","r=l"
VarPtr=dw.lstrcat(v,"")+8
End Function

' VARIANT変数の実体アドレス取得と実体初期化
Function VarPtrWithInit(ByRef v, init)
VarPtrWithInit=VarPtr(v)
v=init
End Function

' 文字列変数のBSTRアドレス取得
Function GetBSTRAddr(ByRef s)
Dim sp,rp
Dim dw, dw2
If VarType(s)<>vbString Then
GetBSTRAddr=0
err.raise DynaCallFollowError, "GetBSTRAddr", "文字列変数ではない"
Exit function
End If
Set dw=CreateObject("DynamicWrapper")
Set dw2=CreateObject("DynamicWrapper")
dw.Register "kernel32.dll","lstrcat","f=s","i=ws","r=l"
dw2.Register "kernel32.dll","RtlMoveMemory","f=s","i=lll","r=l"
sp=dw.lstrcat(s,"")
GetBSTRAddr=""
rp=dw.lstrcat(GetBSTRAddr,"")
GetBSTRAddr=CLng(0)
dw2.RtlMovememory rp+8, sp+8, 4
End Function

' 文字列変数内のバイトデータ取得
Function GetByteInBSTR(ByRef s, offset)
GetByteInBSTR=GetMemBySzInBSTR(s, offset, 1)
End Function

' 文字列変数内のワードデータ取得
Function GetIntInBSTR(ByRef s, offset)
GetIntInBSTR=GetMemBySzInBSTR(s, offset, 2)
End Function

' 文字列変数内のロングデータ取得
Function GetLngInBSTR(ByRef s, offset)
GetLngInBSTR=GetMemBySzInBSTR(s, offset, 4)
End Function

' 文字列変数内のバイト/ワード/ロングデータ取得
Function GetMemBySzInBSTR(ByRef s, offset, sz)
If VarType(s)<>vbString Then
GetMemBySzInBSTR=0
err.raise DynaCallFollowError, "GetMemBySzInBSTR", "文字列変数ではない"
Exit function
End If
If offset<0 Or Len(s)*2<offset+sz Then
GetMemBySzInBSTR=0
err.raise DynaCallFollowError, "GetMemBySzInBSTR", "範囲エラー"
Exit function
End If
GetMemBySzInBSTR=GetMemBySz(GetBSTRAddr(s), offset, sz)
End Function

' 指定メモリ領域のバイト/ワード/ロングデータ取得
Function GetMemBySz(sp, offset, sz)
Dim rp
Dim dw, dw2
If sz<>1 And sz<>2 And sz<>4 then
GetMemBySz=0
err.raise DynaCallFollowError, "GetMemBySz", "サイズエラー"
Exit function
End If
Set dw=CreateObject("DynamicWrapper")
Set dw2=CreateObject("DynamicWrapper")
dw.Register "kernel32.dll","lstrcat","f=s","i=ws","r=l"
dw2.Register "kernel32.dll","RtlMoveMemory","f=s","i=lll","r=l"
GetMemBySz=""
rp=dw.lstrcat(GetMemBySz,"")
Select Case sz
Case 1
GetMemBySz=Cbyte(0)
Case 2
GetMemBySz=Cint(0)
Case 4
GetMemBySz=Clng(0)
End Select
dw2.RtlMovememory rp+8, sp+offset, sz
End Function

' 文字列変数内へのバイトデータ書き込み
Sub SetByteInBSTR(ByRef s, offset, dt)
SetMemBySzInBSTR s, offset, 1, dt
End Sub

' 文字列変数内へのワードデータ書き込み
Sub SetIntInBSTR(ByRef s, offset, dt)
SetMemBySzInBSTR s, offset, 2, dt
End Sub

' 文字列変数内へのロングデータ書き込み
Sub SetLngInBSTR(ByRef s, offset, dt)
SetMemBySzInBSTR s, offset, 4, dt
End Sub

' 文字列変数内へのバイト/ワード/ロングデータ書き込み
Sub SetMemBySzInBSTR(ByRef s, offset, sz, dt)
If VarType(s)<>vbString Then
err.raise DynaCallFollowError, "SetMemBySzInBSTR", "文字列変数ではない"
Exit Sub
End If
If offset<0 Or Len(s)*2<offset+sz Then
err.raise DynaCallFollowError, "SetMemBySzInBSTR", "範囲エラー"
Exit sub
End If
SetMemBySz GetBSTRAddr(s), offset, sz, dt
End Sub

' 指定メモリ領域へのバイト/ワード/ロングデータ書き込み
Sub SetMemBySz(sp, offset, sz, dt)
Dim rdt
Dim w1, w2, wkbuf
Dim dw
If sz<>1 And sz<>2 And sz<>4 then
err.raise DynaCallFollowError, "SetMemBySz", "サイズエラー"
Exit Sub
End If
Set dw=CreateObject("DynamicWrapper")
dw.Register "kernel32.dll","RtlMoveMemory","f=s","i=lll","r=l"
Select Case sz
Case 1
rdt=CByte(dt)
w1=rdt and &h000000ff&
wkbuf=chrw(w1)
Case 2
rdt=Cint(dt)
w1=rdt and &h0000ffff&
wkbuf=chrw(w1)
Case 4
rdt=Clng(dt)
w1=Fix(rdt/&h10000) and &h0000ffff&
w2=rdt and &h0000ffff&
wkbuf=chrw(w2) & chrw(w1)
End Select
dw.RtlMovememory sp+offset, GetBSTRAddr(wkbuf), sz
End Sub

Const CP_ACP= 0
Const CP_OEMCP= 1
Const CP_MACCP= 2
Const CP_THREAD_ACP= 3
Const CP_SYMBOL= 42
Const CP_UTF7= 65000
Const CP_UTF8= 65001

Const MB_PRECOMPOSED= &h00000001
Const MB_COMPOSITE= &h00000002
Const MB_USEGLYPHCHARS= &h00000004
COnst MB_ERR_INVALID_CHARS= &h00000008

' UNICODE -> ANSI 変換
Function W2A(ByRef s, ByRef d)
Dim w1,w2
Dim dw, dw2
Set dw=CreateObject("DynamicWrapper")
dw.Register "kernel32.dll","WideCharToMultiByte","f=s","i=llllllll","r=l"
W2A=dw.WideCharToMultiByte(CP_ACP, 0, GetBSTRAddr(s), -1, GetBSTRAddr(d), Len(d)*2, 0, 0)
End Function

' ANSI -> UNICODE 変換
' dの文字列長を再設定していないので当関数呼出後に余分な初期値を削除して文字列長を設定する
Function A2W(ByRef s, ByRef d)
Dim w1,w2
Dim dw, dw2
Set dw=CreateObject("DynamicWrapper")
dw.Register "kernel32.dll","MultiByteToWideChar","f=s","i=llllll","r=l"
A2W=dw.MultiByteToWideChar(CP_ACP, 0, GetBSTRAddr(s), -1, GetBSTRAddr(d), Len(d)*2)
End Function

' ANSI(アドレス指定) -> UNICODE 変換
Function Ap2W(sp, ByRef d)
Dim w1,w2
Dim dw, dw2
Set dw=CreateObject("DynamicWrapper")
dw.Register "kernel32.dll","MultiByteToWideChar","f=s","i=llllll","r=l"
Ap2W=dw.MultiByteToWideChar(CP_ACP, 0, sp, -1, GetBSTRAddr(d), Len(d)*2)
End Function

' Get*InBSTR, Set*InBSTR テスト
If 1=-1 Then
Dim s2
s2=String(4,Chr(0))
SetByteInBSTR s2, 0, &h80
wscript.echo Hex(GetByteInBSTR(s2, 0))
wscript.echo Hex(GetLngInBSTR(s2, 0))
SetIntInBSTR s2, 0, &h8000
wscript.echo Hex(GetIntInBSTR(s2, 0))
wscript.echo Hex(GetLngInBSTR(s2, 0))
SetLngInBSTR s2, 0, &h10000
wscript.echo Hex(GetLngInBSTR(s2, 0))
End If

' VARIANT変数の書き換え テスト
' VBS内部まで調査していないので安全性は不明
If 1=-1 Then
Dim o2, o2p, o3 ,o3p, oc
o2p=VarPtr(o2)
o3p=VarPtr(o3)
Set o2=CreateObject("wscript.shell")
Set o3=CreateObject("scripting.dictionary")
MsgBox "Dispatch I/F Addr:" & Hex(GetMemBySz(o2p, 0, 4))
MsgBox "Dispatch I/F Addr:" & Hex(GetMemBySz(o3p, 0, 4))
oc=GetMemBySz(o3p, 0, 4)
SetMemBySz o3p, 0, 4, GetMemBySz(o2p, 0, 4)
o3.Popup "Copied Wscript.Shell"
SetMemBySz o3p, 0, 4, oc
End If

' W2A A2W テスト
If 1=-1 Then
Dim ss1, ss2, ss3
ss1="てすとtestテスト"
ss2=String(Len(ss1),Chr(0))
ss3=String(Len(ss1),Chr(0))
W2A ss1, ss2
A2W ss2, ss3
ss3=replace(ss3, Chr(0), "")
MsgBox ss3
End If


4.DynaCallフォロー関数を用いたDLL API使用サンプル


' DynaCallフォロー関数を用いたDLL API使用サンプル
' 統合アーカイバUnLha32.DLLのコマンドラインパラメータによる使用
' コマンドラインパラメータはUnLha32.DLLドキュメントを参照
Function UnLha(ByVal cmdlinebuf)
Dim dw, buf, bufp
Set dw=CreateObject("DynamicWrapper")
dw.Register "C:\Program Files\ArchiverDll\UNLHA32\UNLHA32.DLL", "Unlha", "i=llll", "f=s", "r=l"
buf=String(Len(cmdlinebuf), Chr(0))
W2A cmdlinebuf, buf
UnLha=dw.Unlha(0, GetBSTRAddr(buf), 0, 0)
End Function

' UnLha32.DLLのテスト
' カレントディレクトリの全ファイルを圧縮して書庫ファイルarc.lzhに格納する
If 1=-1 Then
Dim cmdbuf
cmdbuf="a arc.lzh *.*"
UnLha cmdbuf
End If


3.DynaCallフォロー関数を用いたWin32API使用サンプル


' DynaCallフォロー関数を用いたWin32API使用サンプル

Const Win32APICallError=20000

' OS情報取得
Function GetVersionEx(ByRef major, ByRef minor, ByRef build, ByRef platform, ByRef csdversion)
Dim o
Dim dw
Set dw=CreateObject("DynamicWrapper")
dw.Register "kernel32.dll","GetVersionExA","f=s","i=l","r=l"
o=String(74, Chr(0))
SetLngInBSTR o, 0, 148
If dw.GetVersionExA(GetBSTRAddr(o))=0 Then
GetVersionEx=false
Exit function
End If
major=GetLngInBSTR(o,4)
minor=GetLngInBSTR(o,8)
build=GetLngInBSTR(o,12)
platform=GetLngInBSTR(o,16)
csdversion=String(64,Chr(0))
Ap2W GetBSTRAddr(o)+20, csdversion
csdversion=replace(csdversion, Chr(0), "")
GetVersionEx=true
End Function

' OS情報取得 テスト
If 1=-1 Then
Dim major,minor,build,platform, csd
GetVersionEx major,minor,build,platform, csd
MsgBox "majot:" & Hex(major) & " Minor:" & Hex(minor) & " Build:" & Hex(build) & " Platform:" & Hex(platform) & "CSD:" & csd
End If

' マウス位置取得
Function GetMousePos(ByRef x, ByRef y)
Dim dw, o
Set dw=CreateObject("DynamicWrapper")
dw.Register "user32.dll","GetCursorPos","f=s","i=l","r=l"
o=String(4,Chr(0))
If dw.GetCursorPos(GetBSTRAddr(o))=0 Then
GetCursorPos=false
Exit function
End If
x=GetLngInBSTR(o, 0)
y=GetLngInBSTR(o, 4)
GetMousePos=true
End Function

' マウス位置設定
Function SetMousePos(x, y)
Dim dw
Set dw=CreateObject("DynamicWrapper")
dw.Register "user32.dll","SetCursorPos","f=s","i=ll","r=l"
SetMousePos=dw.SetCursorPos(x, y)
End Function

' マウスカーソル操作 テスト
If 1=-1 Then
Dim x, y, i
GetMousePos x, y
For i=0 To 100 Step 10
SetMousePos x+i, y+i
wscript.sleep 200
Next
End If

' ウィンドウ検索
Function FindWindow(ByVal s)
Dim buf
Dim dw
Set dw=CreateObject("DynamicWrapper")
dw.Register "user32.dll","FindWindow","f=s","i=ll","r=l"
buf=String(Len(s),Chr(0))
W2A s, buf
FindWindow=dw.FindWindow(0,GetBSTRAddr(buf))
End Function

' ウィンドウサイズ取得
Function GetWindowRect(hwnd, ByRef aleft, ByRef atop, ByRef aright, ByRef abottom)
Dim o
Dim dw
Set dw=CreateObject("DynamicWrapper")
dw.Register "user32.dll","GetWindowRect","f=s","i=ll","r=l"
o=String(8, Chr(0))
GetWindowRect=dw.GetWindowRect(hwnd, GetBSTRAddr(o))
If GetWindowRect=0 Then Exit function
aleft=GetLngInBSTR(o,0)
atop=GetLngInBSTR(o,4)
aright=GetLngInBSTR(o,8)
abottom=GetLngInBSTR(o,12)
End Function

Const HWND_TOP= 0
Const HWND_BOTTOM= 1
Const HWND_TOPMOST= -1
Const HWND_NOTOPMOST= -2

const SWP_NOSIZE= &h0001
const SWP_NOMOVE = &h0002
const SWP_NOZORDER= &h0004
const SWP_NOREDRAW = &h0008
const SWP_NOACTIVATE= &h0010
const SWP_FRAMECHANGED= &h0020
const SWP_SHOWWINDOW= &h0040
const SWP_HIDEWINDOW = &h0080
const SWP_NOCOPYBITS = &h0100
const SWP_NOOWNERZORDER= &h0200
const SWP_NOSENDCHANGING= &h0400
const SWP_DRAWFRAME = &h0020
const SWP_NOREPOSITION= &h0200
const SWP_DEFERERASE = &h2000
const SWP_ASYNCWINDOWPOS= &h4000

' ウィンドウ配置設定
Function SetWindowPos(hwnd, hWndInsertAfter, x, y, cx, cy, uFlags)
Dim dw
Set dw=CreateObject("DynamicWrapper")
dw.Register "user32.dll","SetWindowPos","f=s","i=lllllll","r=l"
SetWindowPos=dw.SetWindowPos(hwnd, hWndInsertAfter, x, y, cx, cy, uFlags)
End Function

' ウインドウ操作 テスト
If 1=-1 Then
Dim atop,aleft,aright,abottom, hwnd
Dim aax, aay
Dim o
Set o=CreateObject("Internetexplorer.Application")
o.navigate "about:blank"
o.visible=True
wscript.sleep 2000
hwnd=FindWindow("about:blank - MicroSoft Internet Explorer")
GetWindowRect hwnd, aleft,atop,aright,abottom
MsgBox " Left:" & aleft & "Top:" & atop & " Right:" & aright & " Bottom:" & abottom
For aax=0 To 200 Step 10
SetWindowPos hwnd, HWND_TOP, aleft+aax, atop+aax, 0, 0, SWP_NOSIZE
wscript.sleep 100
Next
o.quit
End If

Const GMEM_MOVEABLE= 2
Const GMEM_ZEROINIT =&h40
Const GHND= &h42
Const GMEM_SHARE= &h2000

Const CF_TXT= 1

' クリップボードテキスト設定(ANSIのみ)
Sub SetClipBoardText(s)
Dim dw, dw2, dw3, dw4, dw5
Dim dw6, dw7, dw8, dw9, dwA
Dim gmemp, clpH, buf
Set dw=CreateObject("DynamicWrapper")
Set dw2=CreateObject("DynamicWrapper")
Set dw3=CreateObject("DynamicWrapper")
Set dw4=CreateObject("DynamicWrapper")
Set dw5=CreateObject("DynamicWrapper")
Set dw6=CreateObject("DynamicWrapper")
Set dw7=CreateObject("DynamicWrapper")
Set dw8=CreateObject("DynamicWrapper")
Set dw9=CreateObject("DynamicWrapper")
Set dwA=CreateObject("DynamicWrapper")

dw.Register "kernel32.dll","GlobalAlloc","f=s","i=ll","r=l"
dw2.Register "kernel32.dll","GlobalLock","f=s","i=l","r=l"
dw3.Register "kernel32.dll","GlobalUnlock","f=s","i=l","r=l"
dw4.Register "kernel32.dll","GlobalFree","f=s","i=l","r=l"
dw5.Register "user32.dll","OpenClipboard","f=s","i=l","r=l"
dw6.Register "user32.dll","EmptyClipboard","f=s","r=l"
dw7.Register "user32.dll","SetClipboardData","f=s","i=ll","r=l"
dw8.Register "user32.dll","CloseClipboard","f=s","r=l"
dw9.Register "user32.dll","IsClipboardFormatAvailable","f=s","i=l","r=l"

dwA.Register "kernel32.dll","lstrcpy","f=s","i=ls","r=l"

If dw5.OpenCilpboard(0)=0 then
err.raise Win32APICallError, "SetClipBoardText", "クリップボードオープン失敗"
Exit sub
End If
If dw6.EmptyClipboard()=0 then
dw8.CloseClipboard
err.raise Win32APICallError, "SetClipBoardText", "クリップボード所有権取得失敗"
Exit sub
End If
clpH=dw.GlobalAlloc(GHND Or GMEM_SHARE, (Len(s)+1)*2)
If clpH=0 Then
dw8.CloseClipboard
err.raise Win32APICallError, "SetClipBoardText", "内部メモリ取得失敗"
Exit sub
End If
gmemP=dw2.GlobalLock(clpH)
If gmemP=0 Then
dw4.GlobalFree clpH
dw8.CloseClipboard
err.raise Win32APICallError, "SetClipBoardText", "内部メモリ取得失敗"
Exit sub
End If
dwA.lstrcpy gmemP, CStr(s)
dw3.GlobalUnLock clpH
If dw7.SetClipboardData(CF_TXT, clpH)=0 then
dw8.CloseClipboard
dw4.GlobalFree clpH
err.raise Win32APICallError, "SetClipBoardText", "クリップボード書込み失敗"
Exit sub
End If
dw8.CloseClipboard
dw4.GlobalFree clpH
End Sub

' クリップボードテキスト取得(ANSIのみ)
Sub GetClipBoardText(ByRef txt)
Dim dw, dw2, dw3, dw4, dw5
Dim dw6, dw7, dw8
Dim clpH, gmemP, gmemPlen, txtP

Set dw=CreateObject("DynamicWrapper")
Set dw2=CreateObject("DynamicWrapper")
Set dw3=CreateObject("DynamicWrapper")
Set dw4=CreateObject("DynamicWrapper")
Set dw5=CreateObject("DynamicWrapper")
Set dw6=CreateObject("DynamicWrapper")
Set dw7=CreateObject("DynamicWrapper")
Set dw8=CreateObject("DynamicWrapper")

dw.Register "kernel32.dll","GlobalLock","f=s","i=l","r=l"
dw2.Register "kernel32.dll","GlobalUnlock","f=s","i=l","r=l"
dw3.Register "user32.dll","OpenClipboard","f=s","i=l","r=l"
dw5.Register "user32.dll","CloseClipboard","f=s","r=l"
dw6.Register "user32.dll","IsClipboardFormatAvailable","f=s","i=l","r=l"
dw7.Register "user32.dll","GetClipboardData","f=s","i=l","r=l"
dw8.Register "kernel32.dll","lstrlen","f=s","i=l","r=l"

If dw3.OpenCilpboard(0)=0 then
err.raise Win32APICallError, "GetClipBoardText", "クリップボードオープン失敗"
Exit sub
End If
clpH=dw7.GetClipboardData(CF_TXT)
If clpH=0 Then
dw5.CloseClipboard
txt=""
Exit sub
End If
gmemP=dw.GlobalLock(clpH)
If gmemP=0 Then
dw5.CloseClipboard
err.raise Win32APICallError, "GetClipBoardText", "内部メモリ取得失敗"
Exit sub
End If
gmemPlen=dw8.lstrlen(gmemP)
txt=String(gmemPlen,Chr(0))
Ap2W gmemp, txt
txt=replace(txt, Chr(0), "")
dw2.GlobalUnLock clpH
dw5.CloseClipboard
End Sub

' クリップボード操作 テスト
If 1=-1 Then
Dim s
SetClipBoardText String(6,"あ")
GetClipBoardText s
MsgBox s
End If

Const HKEY_CLASSES_ROOT =&h80000000
Const HKEY_CURRENT_USER =&h80000001
Const HKEY_LOCAL_MACHINE =&h80000002
Const HKEY_USERS =&h80000003
Const HKEY_PERFORMANCE_DATA =&h80000004
Const HKEY_CURRENT_CONFIG =&h80000005
Const HKEY_DYN_DATA =&h80000006
Const HKCR =&h80000000
Const HKCU =&h80000001
Const HKLM =&h80000002

Const REG_NONE =0
Const REG_SZ =1
Const REG_EXPAND_SZ =2
Const REG_BINARY =3
Const REG_DWORD =4
Const REG_DWORD_LITTLE_ENDIAN =4
Const REG_DWORD_BIG_ENDIAN =5
Const REG_LINK =6
Const REG_MULTI_SZ =7
Const REG_RESOURCE_LIST =8
Const REG_FULL_RESOURCE_DESCRIPTOR =9
Const REG_RESOURCE_REQUIREMENTS_LIST =10
Const REG_QWORD =11
Const REG_QWORD_LITTLE_ENDIAN =11

Const ERROR_SUCCESS =0

Const KEY_QUERY_VALUE= &h0001
Const KEY_SET_VALUE= &h0002
Const KEY_CREATE_SUB_KEY= &h0004
Const KEY_ENUMERATE_SUB_KEYS= &h0008
Const KEY_NOTIFY= &h0010
Const KEY_CREATE_LINK= &h0020
Const KEY_READ= &h20019
Const KEY_WRITE= &h20006
Const KEY_EXECUTE= &h20000
Const KEY_ALL_ACCESS= &h20037
Const READ_CONTROL= &h00020000
Const STANDARD_RIGHTS_READ= &h00020000
Const STANDARD_RIGHTS_WRITE= &h00020000
Const STANDARD_RIGHTS_EXECUTE= &h00020000
Const STANDARD_RIGHTS_ALL= &h001F0000
Const SYNCHRONIZE= &h00100000

' レジストリキーのオープン
Function RegOpenKeyEx(topkey, subkey)
Dim dw3
Dim buf, phk
Set dw3=CreateObject("DynamicWrapper")
dw3.Register "advapi32.dll","RegOpenKeyExA","f=s","i=lllll","r=l"
buf=String(Len(subkey), Chr(0))
W2A subkey, buf
phk=VarPtrWithInit(RegOpenKeyEx, CLng(0))
If dw3.RegOpenKeyExA(topkey, GetBSTRAddr(buf), 0, KEY_ENUMERATE_SUB_KEYS, phk)<>ERROR_SUCCESS Then
RegOpenKeyEx=0
End If
End Function

' レジストリキーのクローズ
Function RegCloseKey(hkey)
Dim dw
Set dw=CreateObject("DynamicWrapper")
dw.Register "advapi32.dll","RegCloseKey","f=s","i=l","r=l"
RegCloseKey=dw.RegCloseKey(hkey)
End Function

' レジストリキーの列挙
Function RegEnumKeyEx(topkey, subkey, byref retarray())
Const MAX_PATH=255, MAX_VALUE_NAME=255
Dim hKey
Dim achKey,cchKey
Dim achClass, cchClassName
Dim cSubKeys
Dim cbMaxSubKey
Dim cchMaxClass
Dim cValues
Dim cchMaxValue
Dim cbMaxValueData
Dim cbSecurityDescriptor
Dim ftLastWriteTime
Dim achValue, cchValue
Dim achBuff
Dim i
Dim retCode
Dim dw, dw2
Set dw=CreateObject("DynamicWrapper")
Set dw2=CreateObject("DynamicWrapper")
dw.Register "advapi32.dll","RegEnumKeyExA","f=s","i=llllllll","r=l"
dw2.Register "advapi32.dll","RegQueryInfoKeyA","f=s","i=llllllllllll","r=l"
achClass=String(MAX_PATH, Chr(0))
ftLastWriteTime=String(4, Chr(0))

hKey=RegOpenKeyEx(topkey, subkey)
If hKey=0 Then
RegEnumKeyEx=-1
err.raise Win32APICallError, "RegEnumKeyEx", "レジストリオープン失敗"
Exit function
End If
If dw2.RegQueryInfoKeyA(hKey, _
GetBSTRAddr(achClass), _
VarPtrWithInit(cchClassName,CLng(MAX_PATH)), _
0, _
VarPtrWithInit(cSubKeys,CLng(0)), _
VarPtrWithInit(cbMaxSubKey,CLng(0)), _
VarPtrWithInit(cchMaxClass,CLng(0)), _
VarPtrWithInit(cValues,CLng(0)), _
VarPtrWithInit(cchMaxValue,CLng(0)), _
VarPtrWithInit(cbMaxValueData,CLng(0)), _
VarPtrWithInit(cbSecurityDescriptor,CLng(0)),_
GetBSTRAddr(ftLastWriteTime))<>ERROR_SUCCESS Then
RegCloseKey hKey
RegEnumKeyEx=-1
err.raise Win32APICallError, "RegQueryInfoKey", "失敗"
Exit function
End If
If 0<cSubKeys Then
ReDim retarray(cSubKeys-1)
For i=0 To cSubKeys-1
achKey=String(MAX_PATH, Chr(0))
achBuff=String(255, Chr(0))
retCode = dw.RegEnumKeyExA(hKey, _
i, _
GetBSTRAddr(achKey), _
VarPtrWithInit(cchKey, CLng(MAX_PATH)), _
0, _
0, _
0, _
GetBSTRAddr(ftLastWriteTime))
If retCode=ERROR_SUCCESS Then
If A2W(achKey, achBuff)=0 Then
achBuff=""
End If
retarray(i)=replace(achBuff, Chr(0), "")
Else
retarray(i)=""
End If
Next
End If
RegCloseKey hKey
RegEnumKeyEx=cSubKeys
End Function

' レジストリ値の列挙
Function RegEnumValue(topkey, subkey, retarray())
Const MAX_PATH=255, MAX_VALUE_NAME=255
Dim hKey
Dim achClass, cchClassName
Dim cSubKeys
Dim cbMaxSubKey
Dim cchMaxClass
Dim cValues
Dim cchMaxValue
Dim cbMaxValueData
Dim cbSecurityDescriptor
Dim ftLastWriteTime
Dim achValue, cchValue
Dim achBuff
Dim i
Dim retValue
Dim dw, dw2
Set dw=CreateObject("DynamicWrapper")
Set dw2=CreateObject("DynamicWrapper")
dw.Register "advapi32.dll","RegEnumValueA","f=s","i=llllllll","r=l"
dw2.Register "advapi32.dll","RegQueryInfoKeyA","f=s","i=llllllllllll","r=l"
achClass=String(MAX_PATH, Chr(0))
ftLastWriteTime=String(4, Chr(0))

hKey=RegOpenKeyEx(topkey, subkey)
If hKey=0 Then
RegEnumValue=-1
err.raise Win32APICallError, "RegEnumValue", "レジストリオープン失敗"
Exit function
End If
If dw2.RegQueryInfoKeyA(hKey, _
GetBSTRAddr(achClass), _
VarPtrWithInit(cchClassName,CLng(MAX_PATH)), _
0, _
VarPtrWithInit(cSubKeys,Clng(0)), _
VarPtrWithInit(cbMaxSubKey,Clng(0)), _
VarPtrWithInit(cchMaxClass,Clng(0)), _
VarPtrWithInit(cValues,Clng(0)), _
VarPtrWithInit(cchMaxValue,Clng(0)), _
VarPtrWithInit(cbMaxValueData,Clng(0)), _
VarPtrWithInit(cbSecurityDescriptor,Clng(0)),_
GetBSTRAddr(ftLastWriteTime))<>ERROR_SUCCESS Then
RegCloseKey hKey
RegEnumValue=-1
err.raise 10000, "RegQueryInfoKey", "失敗"
Exit function
End If

If 0<cValues Then
ReDim retarray(cValues-1)
For i=0 To cValues-1
achValue=String(MAX_VALUE_NAME, Chr(0))
achBuff=String(255, Chr(0))
retValue = dw.RegEnumValueA(hKey, _
i, _
GetBSTRAddr(achValue), _
VarPtrWithInit(cchValue, CLng(MAX_VALUE_NAME)), _
0, _
0, _
0, _
0)
If retValue=ERROR_SUCCESS Then
If A2W(achValue, achBuff)=0 then
achBuff=""
End If
retarray(i)=replace(achBuff, Chr(0), "")
Else
retarray(i)=""
End If
Next
End If
RegCloseKey hKey
RegEnumValue=cValues
End Function

' レジストリキーの列挙 テスト
If 1=-1 Then
Dim enumkey(), sz
sz=RegEnumKeyEx(HKCU, "Control Panel", enumkey)
If 0<sz then
MsgBox join(enumkey, vbcrlf)
Else
MsgBox "No Enum Key"
End If
End If

' レジストリ値の列挙 テスト
If 1=-1 Then
Dim sz2, enumval()
sz2=RegEnumValue(HKCU, "Control Panel\Accessibility", enumval)
If 0<sz2 then
MsgBox join(enumval, vbcrlf)
Else
MsgBox "No Enum Val"
End If
End If

' 前面ウィンドウのハンドル取得
Function GetForegroundWindow()
Dim dw
Set dw=CreateObject("DynamicWrapper")
dw.Register "user32.dll","GetForegroundWindow","f=s","r=h"
GetForegroundWindow=dw.GetForegroundWindow()
End Function

' ウィンドウタイトルの取得
Function GetWindowText(hwnd, byref ttl)
Const TTL_MAX=1024
Dim ttlbuf, l
Dim dw
Set dw=CreateObject("DynamicWrapper")
dw.Register "user32.dll","GetWindowTextA","f=s","i=hll","r=l"
ttlbuf=String(TTL_MAX, Chr(0))
l=dw.GetWindowTextA(hwnd, GetBSTRAddr(ttlbuf), Len(ttlbuf)*2)
If 0<l Then
ttl=String(l, Chr(0))
A2W ttlbuf, ttl
ttl=replace(ttl, Chr(0), "")
GetWindowText=l
Else
GetWindowText=0
End If
End Function

Const GW_HWNDFIRST =0
Const GW_HWNDLAST =1
Const GW_HWNDNEXT =2
Const GW_HWNDPREV =3
Const GW_OWNER =4
Const GW_CHILD =5

' 指定ウィンドウの次ウィンドウハンドル取得
Function GetWindow(hwnd)
Dim dw
Set dw=CreateObject("DynamicWrapper")
dw.Register "user32.dll","GetWindow","f=s","i=hl","r=l"
GetWindow=dw.GetWindow(hwnd, GW_HWNDNEXT)
End Function

' 可視ウインドウチェック
Function IsWindowVisible(hwnd)
Dim dw
Set dw=CreateObject("DynamicWrapper")
dw.Register "user32.dll","IsWindowVisible","f=s","i=h","r=l"
IsWindowVisible=dw.IsWindowVisible(hwnd)
End Function

' 全可視ウインドウのハンドル取得
Function GetAllVisibleWindow(byref retarray)
Const WND_MAX=1000
Dim chwnd
Dim hwndcount
chwnd=GetForegroundWindow()
If chwnd=0 Then
GetAllVisibleWindow=0
Exit Function
End If
ReDim retarray(WND_MAX)
retarray(0)=chwnd
hwndcount=1
Do
chwnd=GetWindow(chwnd)
If chwnd=0 Then Exit Do
If IsWindowVisible(chwnd) Then
retarray(hwndcount)=chwnd
hwndcount=hwndcount+1
End If
Loop
ReDim preserve retarray(hwndcount-1)
GetAllVisibleWindow=hwndcount
End Function

' 全可視ウインドウのハンドル取得 テスト
If 1=-1 Then
Dim hwndarray, hwndarraysz
Dim wttlbuf, i4, wttllist
hwndarraysz=GetAllVisibleWindow(hwndarray)
wttllist=""
For i4=0 To hwndarraysz-1
If GetWindowText(hwndarray(i4), wttlbuf)<>0 Then
wttllist=wttllist & hwndarray(i4) & ":" & wttlbuf & vbcrlf
End If
Next
msgbox wttllist
End If

Const MOUSEEVENTF_MOVE =&h0001;
Const MOUSEEVENTF_LEFTDOWN =&h0002;
Const MOUSEEVENTF_LEFTUP =&h0004;
Const MOUSEEVENTF_RIGHTDOWN =&h0008;
Const MOUSEEVENTF_RIGHTUP =&h0010;
Const MOUSEEVENTF_MIDDLEDOWN =&h0020;
Const MOUSEEVENTF_MIDDLEUP =&h0040;
Const MOUSEEVENTF_XDOWN =&h0080;
Const MOUSEEVENTF_XUP =&h0100;
Const MOUSEEVENTF_WHEEL =&h0800;
Const MOUSEEVENTF_ABSOLUTE =&h8000;

' マウス ボタン押下、カーソル移動
Function Mouse_Event(flag, x, y, data)
Dim dw
Dim buf
Set dw=CreateObject("DynamicWrapper")
dw.Register "user32.dll","mouse_event","f=s","i=lllll","r=l"
dw.mouse_event flag, x, y, data, VarPtrWithInit(buf, String(2, Chr(0)))
End Function

' マウス ボタン押下、カーソル移動 テスト
If 1=-1 Then
Mouse_Event MOUSEEVENTF_LEFTDOWN, 0,0,0
Mouse_Event MOUSEEVENTF_LEFTUP, 0,0,0
Mouse_Event MOUSEEVENTF_RIGHTDOWN, 0,0,0
Mouse_Event MOUSEEVENTF_RIGHTUP, 0,0,0
End If