Jeans & Development コンピューターのことなどを綴ったメモ (旧：目から鱗 w/SQLite)

　VB.NET版DynaCallが完成した。次のようなvbscriptのコードで、MessageBoxAが呼び出せる。

set dc=CreateObject("dwtools.NET.dynacall")
dc.Push 1
dc.Push dc.AnsiString("テスト")
dc.Push dc.AnsiString("DynaCall.NET")
dc.Push 0
call dc.CallAPI("user32","MessageBoxA")

実行結果は、前の記事と同じで以下の通り。


　パラメータをクラスのPush関数で与え、戻り値はクラスのeax, edxプロパティで取得するようにした。この辺りは、アセンブラの仕様を残してある。ソースは、以下の通り。

option strict on
Imports System
Imports System.Runtime.InteropServices
Imports Microsoft.VisualBasic

Namespace dwtools.NET
public class DynaCall

  Declare Function EnumWindows Lib "user32" (x As Integer, y As Integer) As Integer
  Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Integer 
  Declare Function GetProcAddress  Lib "kernel32" Alias "GetProcAddress" (ByVal ModuleHandle As Integer, ByVal ProcName As String) As Integer
  Declare Function FreeLibrary Lib "kernel32" (ByVal hDll As Integer) As Integer
  Declare Function GetLastError Lib "kernel32" () As Integer
  Private DllFiles() as string, hDlls() as integer
  Private DllFileNum as integer=0

  'stack preparation
  Public eax as integer, edx as integer
  Public Stack() as integer
  Private StackNum as integer=0
  Public Sub PopAll()
    StackNum=0
    AnsiStringNum=0
    Redim Stack(-1)
    Redim AnsiStringObj(-1)
  End Sub
  Public Sub Push(i as integer)
    Redim Preserve Stack(StackNum)
    Stack(StackNum)=i
    StackNum=StackNum+1
  End Sub
  
  Public LastError as integer
  Private Function WithError() as boolean
    LastError=GetLastError()
    return false
  End Function
  
  Public Function CallAPI(ByVal lpFileName as string, ByVal lpProcName as string) as boolean
    lpFileName=lcase(lpFileName)
    if right(lpFileName,4)=".dll" then lpFileName=left(lpFileName,len(lpFileName)-4)
  
    'Load DLL and resolve Proc Address
    Dim i as integer
    Dim hDll as integer=0
    Dim ProcAddress as integer=0
    for i=0 to DllFileNum
      if i=DllFileNum then 'when not found
        hDll=LoadLibrary(lpFileName)
        if hDll=0 then return WithError()
        Redim Preserve DllFiles(DllFileNum), hDlls(DllFileNum)
        DllFiles(DllFileNum)=lpFileName
        hDlls(DllFileNum)=hDll
        DllFileNum=DllFileNum+1
        exit for
      elseif DllFiles(i)=lpFileName then 
        hDll=hDlls(i)
        exit for
      end if
    next i
    ProcAddress=GetProcAddress(hDll,lpProcName)
    if ProcAddress=0 then return WithError()
    
    'Prepare buffer for getting return code from API
    Dim Res(1) as integer
    Dim gch as GCHandle=GCHandle.Alloc(Res, GCHandleType.Pinned)
    
    'Call the machine code through EnumWindws
    EnumWindows(TheCode(Stack,gch.AddrOfPinnedObject().ToInt32()),ProcAddress)
    eax=Res(0)
    edx=Res(1)
    gch.free()
    
    PopAll()
    return true
    
  End Function
  
  private GchAsmCode as GCHandle
  private AsmCode() as byte
  private AsmCodeSize as integer
  Private Function TheCode(Params() as integer,AddrOfRes as integer) as integer
    Dim i as integer
    
    'Initialize buffer
    On error resume next
    GchAsmCode.free()
    On error goto 0
    AsmCodeSize=0
    
    AddByte(&H58)                   'pop       eax           //contains return address
    AddByte(&H58)                   'pop       eax           //contains hWnd
    AddByte(&H58)                   'pop       eax           //contains lParam (address of API)
    AddByte(&H83,&Hec,&H0c)         'sub       esp,0000000c  //return to original stack position
    for i=0 to Params.Length-1
      AddByte(&H68)
      AddInt(Params(i))             'push      Params(i)     //create the stack for API
    next i
    AddByte(&Hff,&Hd0)              'call      eax           //call API
    AddByte(&Hbb):AddInt(AddrOfRes) 'mov       ebx,AddrOfRes
    AddByte(&H89,&H03)              'mov       [ebx],eax     //put the return code (eax)
    AddByte(&H89,&H53,&h04)         'mov       [ebx+4],edx   //put the return code (edx)
    AddByte(&H33,&Hc0)              'xor       eax,eax       //eax=0 (return code is 0)
    AddByte(&Hc2,&H08,&H00)         'ret       0008          //remove 8 bytes from stack and return
    GchAsmCode = GCHandle.Alloc(AsmCode, GCHandleType.Pinned)
    return GchAsmCode.AddrOfPinnedObject().ToInt32()
  End Function

  Private Sub AddByte(b1 as byte)
    Redim Preserve AsmCode(AsmCodeSize)
    AsmCode(AsmCodeSize)=b1
    AsmCodeSize=AsmCodeSize+1
  End Sub
  Private Sub AddByte(b1 as byte,b2 as byte)
    AddByte(b1)
    AddByte(b2)
  End Sub
  Private Sub AddByte(b1 as byte,b2 as byte,b3 as byte)
    AddByte(b1)
    AddByte(b2)
    AddByte(b3)
  End Sub
  Private Sub AddByte(b1 as byte,b2 as byte,b3 as byte,b4 as byte)
    AddByte(b1)
    AddByte(b2)
    AddByte(b3)
    AddByte(b4)
  End Sub
  Private Sub AddInt(i1 as integer)
    Dim T as string=right("00000000"+hex(i1),8)
    AddByte(cByte("&H"+mid(T,7,2)))
    AddByte(cByte("&H"+mid(T,5,2)))
    AddByte(cByte("&H"+mid(T,3,2)))
    AddByte(cByte("&H"+mid(T,1,2)))
  End Sub
  
  'Make a buffer and keep ANSI string in it
  Private AnsiStringObj() as AnsiStringClass
  Private AnsiStringNum as integer=0
  Public Function AnsiString(T as string) as integer
    Redim Preserve AnsiStringObj(AnsiStringNum)
    AnsiStringObj(AnsiStringNum)=new AnsiStringClass(T)
    AnsiString=AnsiStringObj(AnsiStringNum).address
    AnsiStringNum=AnsiStringNum+1
  End Function
  
  Private Class AnsiStringClass
    Private gch as GCHandle
    Private buff(0) as byte
    Public Sub New(T as string)
      dim i as integer, b as integer
      dim buffLen as integer=0
      for i=1 to len(T)
        b=asc(mid(T,i,1))
        if 0<=b and b<=255 then
          Redim Preserve buff(buffLen)
          buff(buffLen)=cByte(b)
          buffLen=buffLen+1
        else 'Two byte code
          if b<0 then b=b+65536
          Redim Preserve buff(buffLen+1)
          buff(buffLen)=cByte(b \ 256)
          buff(buffLen+1)=cByte(b mod 256)
          buffLen=buffLen+2
        end if
      next i
      Redim Preserve buff(buffLen)
      buff(buffLen)=0
      gch=GCHandle.Alloc(buff, GCHandleType.Pinned)
    End Sub
    Public Function Address() as integer
      Return gch.AddrOfPinnedObject().ToInt32()
    End Function
    Protected Overrides Sub Finalize()
      On error resume next
      gch.Free()
    end sub
  End Class 'AnsiString

End Class 'DynaCall
End Namespace 'dwtools.NET

ここからダウンロードできます。