<![CDATA[Серый форум — VBA: Динамический вызов WinAPI в Excel]]> 2010-08-25T20:25:37Z PunBB http://forum.script-coding.com/viewtopic.php?id=4870 <![CDATA[VBA: Динамический вызов WinAPI в Excel]]> Без гарантий. Используете на свой страх и риск.

Необязательно декларировать вызовы WinAPI в VBA (на примере Excel) с помощью Declare Function, можно вызывать WinAPI в VBA динамически, используя передачу управления коду с помощью функций CallWindowProc, либо EnumWindows:

1) Модуль DLLCALL_CallWindowProc.bas:


'
' Вызов WINAPI в EXCEL через CallWindowProcA
'
Option Explicit

Private Declare Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcA" (ByVal lpPrevWndFunc _
As Long, ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Private Declare Function FreeLibrary Lib "kernel32.dll" (ByVal hLibModule As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32.dll" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function LoadLibrary Lib "kernel32.dll" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long

Private Declare Sub MoveMem Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)

Private Const MAX_PARAMS As Long = 10

' Именованная коллекция адресов функций
Private ADDR As New Collection

Private Type POINT
x As Long
y As Long
End Type

Public sBuf As String

'//Вызов WINAPI//
Public Function CallFunction(ByVal LibName As String, ByVal FuncName As String, ParamArray p()) As Long

    Dim i As Long, hMem As Long, ofs As Long
    Dim hLib As Long
    Dim hAPI_Address As Long
    Dim pMem() As Byte
    Dim arg As Long
    
  
    ' Найти адрес WINAPI
    '-------------------------------------------------
    
    ' Извлечь адрес из коллекции, если таковой имется
    On Error GoTo GET_ADDR
    hAPI_Address = ADDR.Item(LibName & "_" & FuncName)
    'MsgBox "Извлечен адрес повторного вызова.", vbSystemModal + vbExclamation, "Reply"
    On Error GoTo 0
    GoTo CALL_DLL
    
GET_ADDR:

    hLib = LoadLibrary(LibName)
    If hLib = 0 Then Err.Raise 5: Exit Function
    
    hAPI_Address = GetProcAddress(hLib, FuncName)
    If hAPI_Address = 0 Then Err.Raise 5: Exit Function

    ' Добавить адрес в коллекцию
    ADDR.Add Item:=hAPI_Address, Key:=LibName & "_" & FuncName

CALL_DLL:
    
    ' Выделить и заполнить память
    '-------------------------------------------------
    ReDim pMem(0 To 5 * MAX_PARAMS + 5 + 3)
    hMem = VarPtr(pMem(0))
    ofs = 0
    
    ' Обратный порядок записи в стек для stdcall
    For i = UBound(p) To LBound(p) Step -1
        
        ' Команда PUSH
        pMem(ofs) = &H68 'asmPUSH_imm32
        ofs = ofs + 1
        
        ' Аргумент
        If VarType(p(i)) = vbString Then
            arg = CLng(StrPtr(p(i)))
        Else
            arg = CLng(p(i))
        End If
        SetDWord pMem(), ofs, arg
        ofs = ofs + 4
        
    Next
    
    ' Вызов функции
    pMem(ofs) = &HE8 ' asmCALL_rel32
    ofs = ofs + 1
    
    SetDWord pMem(), ofs, CLng(hAPI_Address - hMem - ofs - 4)
    ofs = ofs + 4
    
    ' Возврат с очисткой 0x0010 (16) байт стека
    ' ret 0x0010 - ret imm16 т.е. C2 1000, обратный порядок записи байт
    pMem(ofs) = &HC2
    ofs = ofs + 1
    
    SetWord pMem(), ofs, &H10
    ofs = ofs + 2
    
    CallFunction = CallWindowProc(hMem, 0, 0, 0, 0)
    
End Function

'//Заполнить память двойным словом (Long)//
Private Sub SetDWord(ByRef bMemArr() As Byte, ByVal i As Long, ByVal iData As Long)
    
    Dim k As Integer
    For k = 0 To 3
        bMemArr(i + k) = iData And &HFF
        iData = Int(iData / &H100)  ' Сдвиг вправо на 8 бит равносилен делению на 2^8
    Next
    
End Sub

'//Заполнить память словом (Integer)//
Private Sub SetWord(ByRef bMemArr() As Byte, ByVal i As Long, ByVal iData As Integer)
    
        bMemArr(i) = iData And &HFF
        iData = Int(iData / &H100)
        
        bMemArr(i + 1) = iData And &HFF
        
End Sub

'//Строковый буфер в области VBA//
Public Function GetStrBuf() As String
    GetStrBuf = sBuf
End Function
Public Function SetStrBuf(Lenght As Long) As Long
    sBuf = String(Lenght, Chr(0))
    SetStrBuf = StrPtr(sBuf)
End Function

'//Протестировать вызов WINAPI//
Public Sub Load()

    Dim pid, res As Long
    Dim pt As POINT
    Dim sTempPath As String
    
    sTempPath = String(256, Chr(0))
    '-------------------------
    pid = CallFunction("kernel32.dll", "GetCurrentProcessId")
    MsgBox "Excel PID:" & Chr(32) & pid, vbInformation + vbOKOnly + vbSystemModal
    
    '-------------------------
    res = CallFunction("user32.dll", "MessageBoxA", 0, StrConv("Некоторое сообщение...", vbFromUnicode), StrConv("Заголовок", vbFromUnicode), vbInformation + vbSystemModal)
    
    '-------------------------
    res = CallFunction("user32.dll", "GetCursorPos", VarPtr(pt))
    MsgBox "Положение курсора: " & pt.x & "__" & pt.y, vbInformation + vbSystemModal
    
    '-------------------------
    res = CallFunction("kernel32.dll", "GetTempPathW", Len(sTempPath), StrPtr(sTempPath))
    MsgBox "Temp Path:" & Chr(32) & sTempPath, vbInformation + vbOKOnly + vbSystemModal
    
End Sub

2) Модуль DLLCALL_EnumWindows.bas:
EnumWindows передает управление CALLBACK функции, в роли которой и выступает заданная WinAPI, которая вызывается однократно.


'
' Вызов WINAPI в EXCEL через EnumWindows. WinAPI выступает в роли CALLBACK, которой и передается управление
'
Option Explicit

Private Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long

Private Declare Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcA" (ByVal lpPrevWndFunc _
As Long, ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Private Declare Function FreeLibrary Lib "kernel32.dll" (ByVal hLibModule As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32.dll" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function LoadLibrary Lib "kernel32.dll" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function LocalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function LocalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function LocalUnlock Lib "kernel32" (ByVal hMem As Long) As Boolean

Private Declare Sub MoveMem Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)

Private Const LMEM_FIXED = &H0
Private Const LMEM_MOVEABLE = &H2
Private Const LMEM_NOCOMPACT = &H10
Private Const LMEM_NODISCARD = &H20
Private Const LMEM_ZEROINIT = &H40
Private Const LMEM_MODIFY = &H80
Private Const LMEM_DISCARDABLE = &HF00
Private Const LMEM_VALID_FLAGS = &HF72
Private Const LMEM_INVALID_HANDLE = &H8000

Private Const MAX_PARAMS As Long = 10

' Именованная коллекция адресов функций
Private ADDR As New Collection

Private Type POINT
x As Long
y As Long
End Type

'//Вызов WINAPI//
Public Function CallFunction(ByVal LibName As String, ByVal FuncName As String, ParamArray p()) As Long

    Dim i As Long, hMem As Long
    Dim ofs As Long
    Dim hLib As Long
    Dim hAPI_Address As Long
    Dim pMem() As Byte
    Dim arg As Long
    Dim bRes As Long
    
  
    ' Найти адрес WINAPI
    '-------------------------------------------------
    
    ' Извлечь адрес из коллекции, если таковой имется
    On Error GoTo GET_ADDR
    
    hAPI_Address = ADDR.Item(LibName & "_" & FuncName)
    'MsgBox "Извлечен адрес повторного вызова.", vbSystemModal + vbExclamation, "Reply"
    On Error GoTo 0
    GoTo CALL_DLL
    
GET_ADDR:

    hLib = LoadLibrary(LibName)
    If hLib = 0 Then Err.Raise 5: Exit Function
    
    hAPI_Address = GetProcAddress(hLib, FuncName)
    If hAPI_Address = 0 Then Err.Raise 5: Exit Function
    
    ' Добавить адрес в коллекцию
    ADDR.Add Item:=hAPI_Address, Key:=LibName & "_" & FuncName

CALL_DLL:
    
    ' Выделить и заполнить память
    '-------------------------------------------------
    hMem = LocalAlloc(LMEM_ZEROINIT + LMEM_FIXED, 5 * MAX_PARAMS + 5 + 5 + 5 + 3)
    If hMem = 0 Then Err.Raise 7: Exit Function
    
    hMem = LocalLock(hMem)
    ofs = hMem
    
    ' Обратный порядок записи в стек для stdcall
    For i = UBound(p) To LBound(p) Step -1
        
        MoveMem ByVal ofs, &H68, 1 'asmPUSH_imm32
        ofs = ofs + 1
      
        ' Аргумент
        If VarType(p(i)) = vbString Then
            arg = CLng(StrPtr(p(i)))
        Else
            arg = CLng(p(i))
        End If
        
        MoveMem ByVal ofs, arg, 4
        ofs = ofs + 4
    Next
    
    ' Вызов функции (относительный)
    MoveMem ByVal ofs, &HE8, 1 ' asmCALL_rel32
    ofs = ofs + 1
    
    MoveMem ByVal ofs, CLng(hAPI_Address - ofs - 4), 4
    ofs = ofs + 4
        
    ' Записать результат API(eax) в возврат функции CallFunction
    ' mov [ptr],eax
    CallFunction = CLng(0)
    
    MoveMem ByVal ofs, &HA3, 1
    ofs = ofs + 1
    
    MoveMem ByVal ofs, VarPtr(CallFunction), 4
    ofs = ofs + 4
    
    ' Результат работы EnumWindows = false
    ' mov eax,0
    MoveMem ByVal ofs, &HB8, 1
    ofs = ofs + 1
    ofs = ofs + 4
    
    'Возврат с удалением 8 байт из стека
    'ret 0008
    MoveMem ByVal ofs, &HC2, 1
    ofs = ofs + 1
    
    MoveMem ByVal ofs, &H8, 2
    ofs = ofs + 2
    
    ' Передать управление через EnumWindows CALLBACK
    bRes = EnumWindows(hMem, 0)
    
    LocalUnlock hMem
    LocalFree hMem
   
End Function

'//Строковый буфер в области VBA//
Public Function GetStrBuf() As String
    GetStrBuf = sBuf
End Function
Public Function SetStrBuf(Lenght As Long) As Long
    sBuf = String(Lenght, Chr(0))
    SetStrBuf = StrPtr(sBuf)
End Function

'//Протестировать вызов WINAPI//
Public Sub Load()

    Dim pid, res As Long
    Dim pt As POINT
    Dim sTempPath As String
    
    sTempPath = String(256, Chr(0))
    '-------------------------
    pid = CallFunction("kernel32.dll", "GetCurrentProcessId")
    MsgBox "Excel PID:" & Chr(32) & pid, vbInformation + vbOKOnly + vbSystemModal
    
    '-------------------------
    res = CallFunction("user32.dll", "MessageBoxA", 0, StrConv("Некоторое сообщение...", vbFromUnicode), StrConv("Заголовок", vbFromUnicode), vbInformation + vbSystemModal)
    
    '-------------------------
    res = CallFunction("user32.dll", "GetCursorPos", VarPtr(pt))
    MsgBox "Положение курсора: " & pt.x & "__" & pt.y, vbInformation + vbSystemModal
    
    '-------------------------
    res = CallFunction("kernel32.dll", "GetTempPathW", Len(sTempPath), StrPtr(sTempPath))
    MsgBox "Temp Path:" & Chr(32) & sTempPath, vbInformation + vbOKOnly + vbSystemModal
    
End Sub


Можно вызывать WinAPI из VBScript, используя Excel как сервер автоматизации, понадобится xlsm-документ(здесь - "DLL_CALL.xlsm") расположенный рядом со скриптом и содержащий модули DLLCALL_CallWindowProc.bas и DLLCALL_EnumWindows.bas:

VBScript:


 
 '
 ' Вызов WinAPI из VbScript, используя Excel как сервер автоматизации
 ' VBScript
 '
 '
 
 Option Explicit

 Dim objExcel, objWorkBook
 Dim sPath, sTempPath

 Const sWorkBookName = "DLL_CALL.xlsm"

 sPath = WScript.ScriptFullName
 sPath = Left(sPath, InStrRev(sPath, "\")) & sWorkBookName


 ' /Попытаться использовать уже существующий процесс Excel как сервер автоматизации/
 '-------------------------------------------
 On Error Resume Next
 Set objExcel = GetObject(,"Excel.Application")

 If IsObject(objExcel) Then 

	' /Попытаться обнаружить рабочую книгу содержащую VBA-модуль вызова API/
	Set objWorkBook = objExcel.Workbooks.Item(sWorkBookName)
	If Not IsObject(objWorkBook) Then 
		Set objWorkBook = objExcel.Workbooks.Open(sPath)
	End If
 Else
	Set objExcel = CreateObject("Excel.Application")
	objExcel.Application.Visible = False
	Set objWorkBook = objExcel.Workbooks.Open(sPath) 
 End If
 On Error GoTo 0

 ' Протестировать вызов WINAPI
 '-------------------------------------------
 WinAPITest "DLLCALL_CallWindowProc"
 WinAPITest "DLLCALL_EnumWindows"
 WScript.Quit()


 ' Вызов WINAPI через Excel (sModuleName - имя модуля содержащего вызов WinAPI в книге Excel)
 '-------------------------------------------
 Sub WinAPITest(ByVal sModuleName)

	Dim sTitle, hRES, p1 		 
	sTitle = sModuleName
	With objWorkBook.Application

		hRES = .Run(sModuleName & ".CallFunction", "user32.dll", "MessageBoxW", 0, "Процесс Excel не будет остановлен после выполнения этого сценария.", sTitle, vbExclamation + vbSystemModal)
		p1 = .Run(sModuleName & ".SetStrBuf", 255) 
		hRES = .Run(sModuleName & ".CallFunction", "kernel32.dll", "GetTempPathW", 255, p1)
		sTempPath = .Run(sModuleName & ".GetStrBuf") 

	End With
	MsgBox sTempPath, vbSystemModal + vbExclamation, sTitle
 End Sub
]]> http://forum.script-coding.com/profile.php?id=83 2010-08-25T20:25:37Z http://forum.script-coding.com/viewtopic.php?pid=38910#p38910