Тема: 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
