発掘:今更でも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からも使われており、この記事は今なお意味があるものである。

#今更でもＤｙｎａＣａｌｌ（G.Born氏製）をＶＢＳで使おう　By OtaQ
##履歴
’０５　７下　公開
’０５　８上　３．６、７追加
’０５　８中　ＨＰ内リンク追加
’０５　９下　G.Born氏製DynWrap.DLL向けを明記、０を追加
' ０５　１０中　４．、４．１追加

##表題の通りDynaCall（DynWrap.DLL）をVBS（VisualBasicScript）で使う方法を開陳する
##留意事項
VBSおよびCOM、Win32APIについて理解してから読むことを強く勧める。

参考リンクは張っていないので検索サイトなどで各々調べて欲しい。当方へ
質問しても答えない。
当方の環境はWin98のみであるため、現在主流の環境ではこのサイトの情報を
確認していない。XP等はセキュリティ対策のメモリ保護機能に触れる可能性は高い。
しかし他の環境ではWin32APIの文字コードの扱いが異なる点以外はDynaCall実行において大きな違いは無いと考えている。
当ＨＰの参照、サンプルの私用は各人自由に行って良い。連絡無用。
このサイトの記述は当方が調べた事を元にしている。必ず正しいとも安全とも
限らないので、それを実行した場合の結果に当方は責任を負えない。

##目次
０．不具合修正版DynWrap.DLL
１．VBSでDynaCallを使うための基礎情報
２．VBS用のDynaCallフォロー関数サンプル
３．DynaCallフォロー関数を用いたWin32API使用サンプル
３．１　ＯＳ情報取得
３．２　マウスカーソル操作
３．３　ウインドウ操作
３．４　クリップボード操作
３．５　レジストリ列挙
３．６　ウインドウ列挙
３．７　マウスボタン操作
４．DynaCallフォロー関数を用いたDLL API使用サンプル
４．１　統合アーカイバUnLha32.DLLのコマンドラインパラメータによる使用
##本編
###０．不具合修正版DynWrap.DLL
　詳細は未確認ながら「DynamicWrapperの不具合を改善し、新たなメソッドを
追加」したDynWrap.DLLが存在する（’０５　９下現在）。大幅に使い勝手が良くなっているようだが
G.Born氏による原版とは不具合の修正故に挙動が異なる。当方では原版を
対象にしている。
###１．VBSでDynaCallを使うための基礎情報

　VBSでDynaCallを付属ドキュメント記述どおりに使用しても思うように
機能しない場合が多い。これはDynaCallの記憶領域の扱いが異常なためと
考えられる。また構造体を返すAPIを使用するために1まとまりの記憶領域を
APIに渡す必要がある。これらの問題を解消するため文字列の記憶領域を
直接APIに渡す方法が考えられる。この方法を試すべくDynacallおよびVBSの
文字列の扱いについて調べた結果を記す。
####Ａ．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関数毎に作成する必要がある。

####Ｂ．VARIANTとBSTR
　VBSでは変数をVARIANT型で保持している。先頭2バイトにVARIANT変数が
格納している型情報を持ち、先頭から8バイト目に格納したデータがそのサイズに応じて入っている。文字列変数の場合、実体がBSTR型でありそのアドレスがデータとしてVARIANT変数に入っている。これらの管理はVBSがCOM APIを使用して行っていると考えられるので型情報やBSTR型の文字列長書換え、取得したBSTRの記憶領域を超えたメモリのアクセス等は厳禁。しかしBSTR文字列自体は書換え可能である。よってBSTRのアドレスを取得すれば１まとまりの記憶領域として利用できる。
####Ｃ．VBSの変数、定数
　Win9xでDynaCallがVBSの文字列に関してDLLにどのような引数を渡しているか調べたところ、以下が判明した。
#####Ｃ.a. 文字列定数（リテラル、Const定義識別子）

引数指定	結果
s	W->A変換後の文字列を渡す
w	変換せずにBSTRアドレスを渡す
r	W->A変換後の文字列を渡す

#####Ｃ.b. 文字列変数

引数指定	結果
s	W->A変換後の文字列を渡す
w	変換せずにVARIANT変数アドレスを渡す
r	W->A変換後の文字列を渡す

　Ｃ.a.およびＣ.b.より引数型指定にwを用いればDLLにBSTRまたはVARIANTアドレスが渡る。
Win32APIのLstrcatは実行に成功すれば第一引数を返すのでこれを用いてBSTRまたはVARIANT文字列変数アドレスを取得できる。
またVBSでは全く同じ文字列定数が複数存在する場合同じ記憶領域の文字列を用いるのでバッファに文字列定数を用いる場合注意する必要がある。

２．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

###４．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

###３．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