如何使用 Win32 API 从 Excel VBA 中的非"Single-Threaded Apartment"线程调用 InternetGetProxyInfo
How to call InternetGetProxyInfo from a non "Single-Threaded Apartment" thread from Excel VBA using Win32 APIs
我正在开发一个 Excel VBA 程序，在某些时候，我需要在访问特定 url 时使用代理，该代理是从我公司提供的 .pac 文件计算出来的。为此，我打算使用WinINet(我知道我也可以更轻松地使用WinHTTP，甚至如何使其工作(
我知道我在我的示例中缺少一些清理(InternetDeInitializeAutoProxyDll等(，但现在，我只是尝试成功检索代理信息。
步骤 1 - C++
我找到了这个，它给了我一个样本开始：
在调用 InternetGetProxyInfo(( 之前应该进行什么初始化？
接受的答案给出了 2 种方法。但我认为：
- 第一个是错误的，它不允许从PAC文件中检索自动代理。
- 第二个也是部分错误的，因为不需要提供任何辅助函数，有些是默认提供的并在内部使用。
无论如何，以下C++示例允许我检索包含要用于特定 url 的代理的字符串：
char *str = 0;
DWORD len = 0;
pfnInternetInitializeAutoProxyDll pIIAPD;
pfnInternetGetProxyInfo pIGPI;
HMODULE hModJS;
hModJS = LoadLibrary(TEXT("jsproxy.dll"));
pIIAPD = (pfnInternetInitializeAutoProxyDll)GetProcAddress(hModJS, "InternetInitializeAutoProxyDll");
pIGPI = (pfnInternetGetProxyInfo)GetProcAddress(hModJS, "InternetGetProxyInfo");
BOOL b;
DWORD dw;
b = pIIAPD(0, "D:\Users\SC5071\Desktop\proxy.pac", 0, 0, 0);
dw = GetLastError();
b = pIGPI("https://www.google.fr/", sizeof(URL) - 1, "www.google.fr", sizeof(HOST) - 1, &str, &len);
dw = GetLastError();
return 0;
工作正常，str包含以下内容：
代理 123.123.55.55：10455;代理 123.123.56.56：10455;直接
第 2 步 - VBA
使用 Win32 API 函数的Declare语句从 C++ 移动到 Excel VBAInternetInitializeAutoProxyDll和InternetGetProxyInfo。
[我现在不在这里发布代码]
InternetGetProxyInfo失败，错误代码ERROR_CAN_NOT_COMPLETE (1003L)
第 3 步 - ASM
起初，我认为这可能与Excel VBA加载和调用DLL函数的方式有关，因为MSDN forInternetGetProxyInfo指出：
此函数只能通过动态链接到"JSProxy.dll"来调用。
所以我制作了自己的 x86 汇编代码来进行调用(__stdcall约定(：
Private Declare Function GetModuleHandleW Lib "kernel32.dll" (ByVal moduleName As String) As Long
Private Declare Function GetModuleHandleA Lib "kernel32.dll" (ByVal moduleName As String) As Long
Private Declare Function LoadLibraryExW Lib "kernel32.dll" (ByVal lpFileName As String, ByVal hFile As Long, ByVal dwFlags As Integer) As Long
Private Declare Function LoadLibraryExA Lib "kernel32.dll" (ByVal lpFileName As String, ByVal hFile As Long, ByVal dwFlags As Integer) As Long
Private Declare Function LoadLibraryW Lib "kernel32.dll" (ByVal lpFileName As Long) As Long
Private Declare Function LoadLibraryA Lib "kernel32.dll" (ByVal lpFileName As Long) As Long
Private Declare Function FreeLibrary Lib "kernel32.dll" (ByVal hModule As Long) As Integer
Private Declare Function VirtualAlloc Lib "kernel32.dll" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Private Declare Function VirtualFree Lib "kernel32.dll" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32.dll" (ByVal hModule As Long, ByVal lpProcName As Long) As Long
Private Declare Function GetProcAddress_String Lib "kernel32.dll" Alias "GetProcAddress" (ByVal hModule As Long, ByVal ProcName As String) As Long
Private Declare Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcW" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32.dll" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Integer)
Private Declare Function GetLastError Lib "kernel32.dll" () As Long
Private Const MEM_COMMIT As Long = &H1000&
Private Const MEM_RESERVE As Long = &H2000&
Private Const MEM_RELEASE As Long = &H8000&
Private Const MEM_EXECUTE_READWRITE As Long = &H40&
Dim FunctionAddress As Long
Dim MemAddressOffset As Long
Private Sub AddByte(ByVal Data As Byte)
RtlMoveMemory MemAddressOffset, VarPtr(Data), 1
MemAddressOffset = CLng(MemAddressOffset) + 1
End Sub
Private Sub AddBytes(Data() As Byte)
RtlMoveMemory MemAddressOffset, VarPtr(Data(0)), UBound(Data) + 1
MemAddressOffset = CLng(MemAddressOffset) + UBound(Data) + 1
End Sub
Sub Main()
Dim b As Long
Dim MemAddress As Long
Dim LstrBytes1() As Byte
LstrBytes1 = "jsproxy.dll"
ReDim Preserve LstrBytes1(UBound(LstrBytes1) + 2)
hLib = LoadLibraryW(VarPtr(LstrBytes1(0)))
Dim NstrBytes1() As Byte
NstrBytes1 = StrConv("InternetInitializeAutoProxyDll", vbFromUnicode)
ReDim Preserve NstrBytes1(UBound(NstrBytes1) + 1)
FunctionAddress = GetProcAddress(hLib, VarPtr(NstrBytes1(0)))
If FunctionAddress = 0 Then Stop
MemAddress = VirtualAlloc(0&, 256, MEM_COMMIT Or MEM_RESERVE, MEM_EXECUTE_READWRITE)
MemAddressOffset = MemAddress
Dim strTemp1 As String
strTemp1 = "D:UsersSC5071Desktopproxy.pac"
Dim bytTemp1() As Byte
bytTemp1 = StrConv(strTemp1, vbFromUnicode)
ReDim Preserve bytTemp1(UBound(bytTemp1) + 1)
AddByte &H55 'push ebp
AddByte &H8B: AddByte &HEC 'mov ebp,esp
AddByte &H83: AddByte &HEC: AddByte &H18 'sub esp,18h
AddByte &H6A: AddByte &H0 'push 0
AddByte &H6A: AddByte &H0 'push 0
AddByte &H6A: AddByte &H0 'push 0
AddByte &H68: AddBytes LongToByteArray(VarPtr(bytTemp1(0))) 'push DWORD PTR
AddByte &H6A: AddByte &H0 'push 0
AddByte &HE8 'call InternetInitializeAutoProxyDll
AddBytes LongToByteArray(CLng(FunctionAddress) - (CLng(MemAddressOffset) + 4))
AddByte &H89: AddByte &H45: AddByte &HFC 'mov dword ptr [ebp-4],eax
AddByte &H8B: AddByte &H45: AddByte &HFC 'mov eax,dword ptr [ebp-4]
AddByte &HC9 'leave
AddByte &HC3 'ret
l = CallWindowProc(MemAddress, 0, 0, 0, 0)
Debug.Print GetLastError()
b = VirtualFree(MemAddress, 0, MEM_RELEASE)
Debug.Print Err.LastDllError
If l = 0 Then Exit Sub
'--------------------------------------------------------------------------------------------------------------------------------
FunctionAddress = 0
Dim NstrBytes2() As Byte
NstrBytes2 = StrConv("InternetGetProxyInfo", vbFromUnicode)
ReDim Preserve NstrBytes2(UBound(NstrBytes2) + 1)
FunctionAddress = GetProcAddress(hLib, VarPtr(NstrBytes2(0)))
If FunctionAddress = 0 Then Stop
MemAddress = VirtualAlloc(0&, 256, MEM_COMMIT Or MEM_RESERVE, MEM_EXECUTE_READWRITE)
MemAddressOffset = MemAddress
strUrlW$ = "https://www.google.fr/"
strHostNameW$ = "www.google.fr"
Dim szUrlA() As Byte
Dim szHostNameA() As Byte
szUrlA = StrConv(strUrlW, vbFromUnicode)
szHostNameA = StrConv(strHostNameW, vbFromUnicode)
ReDim Preserve szUrlA(UBound(szUrlA) + 1)
ReDim Preserve szHostNameA(UBound(szHostNameA) + 1)
len1& = Len("https://www.google.fr/") + 1
len2& = Len("www.google.fr") + 1
Dim strProxyHostName() As Byte
ReDim strProxyHostName(2048 - 1)
Dim lpszProxyHostName As Long
Dim lplpszProxyHostName As Long
lpszProxyHostName = VarPtr(strProxyHostName(0))
lplpszProxyHostName = VarPtr(lpszProxyHostName)
Dim dwProxyHostNameLength As Long
Dim lpdwProxyHostNameLength As Long
dwProxyHostNameLength = UBound(strProxyHostName)
lpdwProxyHostNameLength = VarPtr(dwProxyHostNameLength)
AddByte &H55 'push ebp
AddByte &H8B: AddByte &HEC 'mov ebp,esp
AddByte &H83: AddByte &HEC: AddByte &H1C 'sub esp,1ch
AddByte &H68: AddBytes LongToByteArray(lpdwProxyHostNameLength) 'push DWORD PTR
AddByte &H68: AddBytes LongToByteArray(lplpszProxyHostName) 'push DWORD PTR PTR
AddByte &H68: AddBytes LongToByteArray(len2) 'push DWORD
AddByte &H68: AddBytes LongToByteArray(VarPtr(szHostNameA(0))) 'push DWORD PTR
AddByte &H68: AddBytes LongToByteArray(len1) 'push DWORD
AddByte &H68: AddBytes LongToByteArray(VarPtr(szUrlA(0))) 'push DWORD PTR
AddByte &HE8 'call InternetGetProxyInfo
AddBytes LongToByteArray(CLng(FunctionAddress) - (CLng(MemAddressOffset) + 4))
AddByte &H89: AddByte &H45: AddByte &HFC 'mov dword ptr [ebp-4],eax
AddByte &H8B: AddByte &H45: AddByte &HFC 'mov eax,dword ptr [ebp-4]
AddByte &HC9 'leave
AddByte &HC3 'ret
l = CallWindowProc(MemAddress, 0, 0, 0, 0)
Debug.Print GetLastError()
Debug.Print Mem_ReadHex(MemAddress, CLng(MemAddressOffset) - CLng(MemAddress))
b = VirtualFree(MemAddress, 0, MEM_RELEASE)
Debug.Print Err.LastDllError
If l = 0 Then Exit Sub
Debug.Print strProxyHostName
End Sub
有点重，但它可以在不崩溃 Excel 的情况下工作(就像我可以在互联网上找到的 VB 中的任何"CallAPIByName"代码一样(，但仍然ERROR_CAN_NOT_COMPLETE 1003L.
步骤 4 - 问题
1/然后，我发现如果从"单线程公寓"线程调用InternetGetProxyInfo，显然会不可避免地因ERROR_CAN_NOT_COMPLETE而失败。
WinINet InternetGetProxyInfo ： 错误 1003 ERROR_CAN_NOT_COMPLETE
2/我也开始了解 Excel 的进程实际上是单线程的，更准确地说，它存在于单线程单元中(这意味着 COM 已使用OleInitialize/CoInitialize初始化(
VBA 中的多线程
3/以下另一个来源解释说：
"JSProxy使用COM，如果在同一线程上执行其他公寓COM初始化，它将无法正常工作。
http://microsoft.public.win32.programmer.networks.narkive.com/RMOcV126/internetgetproxyinfo-fails-with-error-can-not-complete-result
所以，这是我最后一次愚蠢的尝试：
hThread = CreateThread(0, 0, MemAddress, 0, 0, 0)
Call WaitForSingleObject(hThread, INFINITE)
Dim lpExitCode As Long
b = GetExitCodeThread(hThread, lpExitCode)
CloseHandle hThread
显然，它仍然没有返回带有代理信息的字符串。
在上面的C++示例中，我注意到添加以下内容确实会产生与Excel中相同的行为：
HRESULT o = OleInitialize(NULL); // S_OK = 0x0
// after that, InternetGetProxyInfo fails with 1003L
我不太熟悉 OLE/COM/线程概念，而且我看不出如何轻松地走得更远。鉴于我在这里所说的一切，我想我可以将我的问题总结为：
如何使用Win32 API从Excel VBA的非"单线程单元"线程调用InternetGetProxyInfo？
视窗 10 64 位 + Excel 2016 32 位
没关系，它解决了：
Private Const INFINITE = &HFFFFFFFF
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CreateThread _
Lib "kernel32" ( _
ByVal lpThreadAttributes As Long, _
ByVal dwStackSize As Long, _
ByVal lpStartAddress As Long, _
ByVal lpParameter As Long, _
ByVal dwCreationFlags As Long, _
ByRef lpThreadld As Long) _
As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetLastError Lib "kernel32.dll" () As Long
Private Declare Function GetExitCodeThread Lib "kernel32" (ByVal hThread As Long, ByRef dwExitCode As Long) As Long
Private Declare Function VirtualAlloc Lib "kernel32.dll" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Private Declare Function VirtualFree Lib "kernel32.dll" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long
Private Const MEM_COMMIT As Long = &H1000&
Private Const MEM_RESERVE As Long = &H2000&
Private Const MEM_RELEASE As Long = &H8000&
Private Const MEM_EXECUTE_READWRITE As Long = &H40&
Private Declare PtrSafe Function MultiByteToWideChar _
Lib "kernel32.dll" _
( _
ByVal CodePage As Long, _
ByVal dwFlags As Long, _
ByVal lpMultiByteStr As Long, _
ByVal cbMultiByte As Long, _
ByVal lpWideCharStr As Long, _
ByVal cchWideChar As Long) _
As Long
'################################################################################################################################
Private Declare Function InternetInitializeAutoProxyDll_String _
Lib "JSProxy.dll" _
Alias "InternetInitializeAutoProxyDll" _
( _
ByVal dwVersion As Long, _
ByVal lpszDownloadedTempFile As String, _
ByVal lpszMime As Long, _
ByVal lpAutoProxyCallbacks As Long, _
ByVal lpAutoProxyScriptBuffer As Long) _
As Boolean
Private Declare Function InternetGetProxyInfo_Long _
Lib "JSProxy.dll" _
Alias "InternetGetProxyInfo" _
( _
ByVal lpszUrl As Long, _
ByVal dwUrlLength As Long, _
ByVal lpszUrlHostName As Long, _
ByVal dwUrlHostNameLength As Long, _
ByVal lplpszProxyHostName As Long, _
ByVal lpdwProxyHostNameLength As Long) _
As Boolean
'################################################################################################################################
Public g_ptrProxyHostName As Long 'thread-shared variable allocated/stored in process global memory
Public g_strProxyHostName As String 'idem
Public g_lngProxyHostNameLength As Long 'idem
Public g_MainThreadId As Long
Public WinINet_InternetGetProxyInfo_ThreadProc_Error As Long
Public globalVar1 As Long
Public globalVar2 As Long
'################################################################################################################################
Function WinINet_InternetGetProxyInfo_ThreadProc() As Long
Dim bResult As Boolean
'Dim strProxyHostName As String 'useless, see below
'strProxyHostName = Space(1024)
Dim lpszProxyHostName As Long
Dim lplpszProxyHostName As Long
lpszProxyHostName = StrPtr(strProxyHostName)
lplpszProxyHostName = VarPtr(lpszProxyHostName)
Dim dwProxyHostNameLength As Long
Dim lpdwProxyHostNameLength As Long
dwProxyHostNameLength = LenB(strProxyHostName)
lpdwProxyHostNameLength = VarPtr(dwProxyHostNameLength)
Dim strUrlW As String
Dim strHostNameW As String
Dim strUrlA As String
Dim strHostNameA As String
strUrlW = "https://www.google.fr/"
strHostNameW = "www.google.fr"
strUrlA = StrConv(strUrlW, vbFromUnicode)
strHostNameA = StrConv(strHostNameW, vbFromUnicode)
Dim szUrlA() As Byte
Dim szHostNameA() As Byte
szUrlA = StrConv(strUrlW, vbFromUnicode)
szHostNameA = StrConv(strHostNameW, vbFromUnicode)
ReDim Preserve szUrlA(UBound(szUrlA) + 1)
ReDim Preserve szHostNameA(UBound(szHostNameA) + 1)
bResult = InternetInitializeAutoProxyDll_String(0, "D:UsersSC5071Desktopproxy.pac", 0, 0, 0)
'check state before
'globalVar1 = lpszProxyHostName
'globalVar1 = lplpszProxyHostName
'globalVar1 = dwProxyHostNameLength
'globalVar1 = lpdwProxyHostNameLength
bResult = InternetGetProxyInfo_Long(VarPtr(szUrlA(0)), Len("https://www.google.fr/") + 1, _
VarPtr(szHostNameA(0)), Len("www.google.fr") + 1, _
lplpszProxyHostName, lpdwProxyHostNameLength)
m_ThreadProcId = GetCurrentThreadId()
If m_ThreadProcId = g_MainThreadId Then 'otherwise Excel crahes when using Debug.Print from another thread than the STA thread
Debug.Print "bResult = "; bResult
Debug.Print "Err.LastDllError = "; Err.LastDllError
Debug.Print "GetLastError() = "; GetLastError()
End If
'check state after
'globalVar2 = lpszProxyHostName
'globalVar2 = lplpszProxyHostName
'globalVar2 = dwProxyHostNameLength
'globalVar2 = lpdwProxyHostNameLength
'~~> checking the state of the variable passed to InternetGetProxyInfo before and after the call reveals that
' InternetGetProxyInfo_Long actually allocates a buffer holding the computed string and returns the new pointer to it in
' lpszProxyHostName, and its length in dwProxyHostNameLength; lplpszProxyHostName and lpdwProxyHostNameLength are unchanged.
' that is why strProxyHostName contains only blank spaces (200020002000...) after the call, it is simply unchanged.
WinINet_InternetGetProxyInfo_ThreadProc = bResult
'WinINet_InternetGetProxyInfo_ThreadProc = Err.LastDllError
WinINet_InternetGetProxyInfo_ThreadProc_Error = Err.LastDllError
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
g_ptrProxyHostName = lpszProxyHostName
g_lngProxyHostNameLength = dwProxyHostNameLength
Dim strWideCharStr As String
Dim cRequiredBuffer As Long
cRequiredBuffer = MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, g_ptrProxyHostName, -1, StrPtr(strWideCharStr), 0)
cchWideChar = cRequiredBuffer - 1
strWideCharStr = Space(cchWideChar)
Dim lngResult As Long
lngResult = MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, g_ptrProxyHostName, -1, StrPtr(strWideCharStr), cchWideChar)
g_strProxyHostName = strWideCharStr
End Function
Sub Main()
g_MainThreadId = GetCurrentThreadId()
Dim hThread As Long
hThread = CreateThread(0, 0, AddressOf WinINet_InternetGetProxyInfo_ThreadProc, 0, 0, 0)
Call WaitForSingleObject(hThread, INFINITE)
Dim dwExitCode As Long
b = GetExitCodeThread(hThread, dwExitCode)
CloseHandle hThread
If dwExitCode = 1 And WinINet_InternetGetProxyInfo_ThreadProc_Error = 0 Then
'Debug.Print globalVar1
'Debug.Print globalVar2
Debug.Print "PAC file result for URL is:"
Debug.Print g_strProxyHostName
Debug.Print "THE END"
Else
Debug.Print dwExitCode
Debug.Print WinINet_InternetGetProxyInfo_ThreadProc_Error
End If
End Sub
最后，问题是InternetGetProxyInfo分配了自己的缓冲区(稍后应该释放，因为许多WinINet函数返回字符串(，所以我的"愚蠢"尝试并没有那么愚蠢!!它实际上是在工作！
我忘了在我的问题中提到，我制作了一个 ASM 代码，因为 CallWindowProc 不允许调用需要超过 4 个参数的函数指针。无论如何，这是没有用的，问题来自其他地方，DeclareWin32 API的语句正确地执行了调用WinINet/JSProxy函数所需的动态链接。
如您所见，从主 Excel STA 线程创建另一个线程非常容易，但是如果我对 COM 线程模型的看法正确，则必须避免使用该主线程中创建的对象，这很可能导致 Excel 崩溃。
相关文章：
- 可视化C++：发布模式的运行时库作为'Multi-threaded Debug DLL'
- 如何使用 Win32 API 从 Excel VBA 中的非"Single-Threaded Apartment"线程调用 InternetGetProxyInfo
- CUDA 内核"Only a single pack parameter is allowed"解决方法？
- 是否有一个术语来表示"single mutex deadlock"(具有非递归互斥锁的死锁类型情况)？
- memory_order_seq_cst操作的"happens before"关系和"precedes in a single total order"关系有什么区别？
- Qt：初始化存储库中止与"fatal: Needed a single revision"
- "single assignment"与"no early return"
- OpenCV SVM 在火车上抛出异常，"Bad argument (There is only a single class)"
- Directshow Preview Only 和 Capture & Preview with a Single Graph
- 使用 -g 选项编译，但"Single stepping until exit from function main, which has no line number information"
- 如何使用静态库创建QT控制台应用程序的Single exe，
- 来自SINGLE校准相机的2个连续帧的视差图.有可能吗
- 全局变量和"single" "things"的全局变量 ？
- 如何使用Windows命令行上的命令行将C++文件编译为SINGLE文件
- "single allocation"对提升意味着什么：make_shared
- boost::program_options for single-byte variables
- Single linked lists C++
- Pragma omp用于内部的Pragma omp master或single
