本文說(shuō)明在vba中如何獲取進(jìn)程加載的dll文件的路徑。
新建VBA工程
打開(kāi)Excel，按下Atl + F11，打開(kāi)VBA工程。
增加一個(gè)Form
增加一個(gè)Form，F(xiàn)orm上有一個(gè)Label、一個(gè)文本框、一個(gè)按鈕和一個(gè)ListBox控件。文本框用來(lái)輸入進(jìn)程的名稱(chēng)，ListBox用來(lái)顯示dll的路徑
增加一個(gè)模塊
新增加一個(gè)VBA模塊，貼入如下代碼。
Option Explicit
Public Const PROCESS_QUERY_INFORMATION = 1024
Public Const PROCESS_VM_READ = 16
Public Const MAX_PATH = 260
Public Const WINNT_System_Found = 2
Type PROCESS_MEMORY_COUNTERS
cb As Long
PageFaultCount As Long
PeakWorkingSetSize As Long
WorkingSetSize As Long
QuotaPeakPagedPoolUsage As Long
QuotaPagedPoolUsage As Long
QuotaPeakNonPagedPoolUsage As Long
QuotaNonPagedPoolUsage As Long
PagefileUsage As Long
PeakPagefileUsage As Long
End Type
Public Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long '1 = Windows 95.
'2 = Windows NT
szCSDVersion As String * 128
End Type
Public Declare Function GetProcessMemoryInfo Lib "PSAPI.DLL" (ByVal hProcess As Long, ppsmemCounters As PROCESS_MEMORY_COUNTERS, ByVal cb As Long) As Long
Public Declare Function CloseHandle Lib "Kernel32.dll" (ByVal Handle As Long) As Long
Public Declare Function OpenProcess Lib "Kernel32.dll" (ByVal dwDesiredAccessas As Long, ByVal bInheritHandle As Long, ByVal dwProcId As Long) As Long
Public Declare Function EnumProcesses Lib "PSAPI.DLL" (ByRef lpidProcess As Long, ByVal cb As Long, ByRef cbNeeded As Long) As Long
Public Declare Function GetModuleFileNameExA Lib "PSAPI.DLL" (ByVal hProcess As Long, ByVal hModule As Long, ByVal ModuleName As String, ByVal nSize As Long) As Long
Public Declare Function EnumProcessModules Lib "PSAPI.DLL" (ByVal hProcess As Long, ByRef lphModule As Long, ByVal cb As Long, ByRef cbNeeded As Long) As Long
Public Declare Function GetVersionExA Lib "kernel32" (lpVersionInformation As OSVERSIONINFO) As Integer
Public Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Public Sub GetDLLs(ByVal EXEName As String, list As Collection)
Dim lngLength As Long
Dim strProcessName As String
Dim lngCBSize As Long 'Specifies the size, In bytes, of the lpidProcess array
Dim lngCBSizeReturned As Long 'Receives the number of bytes returned
Dim lngNumElements As Long
Dim lngProcessIDs() As Long
Dim lngCBSize2 As Long
Dim lngModules(1 To 200) As Long
Dim lngReturn As Long
Dim strModuleName As String
Dim lngSize As Long
Dim lngHwndProcess As Long
Dim lngLoop As Long
Dim pmc As PROCESS_MEMORY_COUNTERS
Dim lRet As Long
Dim strProcName2 As String
Dim llLoop As Long
Dim llEnd As Long
'Turn on Error handler
On Error GoTo Error_handler
EXEName = UCase$(Trim$(EXEName))
lngLength = Len(EXEName)
lngCBSize = 8 ' Really needs To be 16, but Loop will increment prior to calling API
lngCBSizeReturned = 96
If EXEName <> "" Then
Do While lngCBSize <= lngCBSizeReturned
DoEvents
'Increment Size
lngCBSize = lngCBSize * 2
'Allocate Memory for Array
ReDim lngProcessIDs(lngCBSize / 4) As Long
'Get Process ID's
lngReturn = EnumProcesses(lngProcessIDs(1), lngCBSize, lngCBSizeReturned)
Loop
lngNumElements = lngCBSizeReturned / 4
Else
ReDim lngProcessIDs(1) As Long
lngProcessIDs(1) = GetCurrentProcessId
lngNumElements = 1
End If
'Count number of processes returned
'Loop thru each process
For lngLoop = 1 To lngNumElements
'Get a handle to the Process and Open
lngHwndProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0, lngProcessIDs(lngLoop))
If lngHwndProcess <> 0 Then
'Get an array of the module handles for the specified process
lngReturn = EnumProcessModules(lngHwndProcess, lngModules(1), 200, lngCBSize2)
'If the Module Array is retrieved, Get the ModuleFileName
If lngReturn <> 0 Then
llEnd = lngCBSize2 / 4
'Buffer with spaces first to allocate memory for byte array
strModuleName = Space(MAX_PATH)
'Must be set prior to calling API
lngSize = 500
'Get Process Name
lngReturn = GetModuleFileNameExA(lngHwndProcess, lngModules(1), strModuleName, lngSize)
'Remove trailing spaces
strProcessName = Left(strModuleName, lngReturn)
'Check for Matching Upper case result
strProcessName = UCase$(Trim$(strProcessName))
strProcName2 = GetElement(Trim(Replace(strProcessName, Chr$(0), "")), "\", 0, 0, _
GetNumElements(Trim(Replace(strProcessName, Chr$(0), "")), "\") - 1)
'All the items for the process
If EXEName = "" Or strProcName2 = ExtractFileName(EXEName) Then
For llLoop = 1 To llEnd
lngReturn = GetModuleFileNameExA(lngHwndProcess, lngModules(llLoop), strModuleName, lngSize)
'Remove trailing spaces
strProcessName = Left(strModuleName, lngReturn)
'Check for Matching Upper case result
strProcessName = UCase$(Trim$(strProcessName))
' strProcName2 = GetElement(Trim(Replace(strProcessName, Chr$(0), "")), "\", 0, 0, _
GetNumElements(Trim(Replace(strProcessName, Chr$(0), "")), "\") - 1)
'Add path to the Collection
If Right$(strProcessName, 4) = ".DLL" Then list.Add strProcessName
Next
'Get the Site of the Memory Structure
pmc.cb = LenB(pmc)
lRet = GetProcessMemoryInfo(lngHwndProcess, pmc, pmc.cb)
End If
End If
End If
'Close the handle to this process
lngReturn = CloseHandle(lngHwndProcess)
'DoEvents
Next
IsProcessRunning_Exit:
'Exit early to avoid error handler
Exit Sub
Error_handler:
Err.Raise Err, Err.Source, "ProcessInfo", Error
Resume Next
End Sub
Private Function ExtractFileName(ByVal vStrFullPath As String) As String
Dim intPos As Integer
intPos = InStrRev(vStrFullPath, "\")
ExtractFileName = UCase$(Mid$(vStrFullPath, intPos + 1))
End Function
Private Function getOsVersion() As Long
Dim osinfo As OSVERSIONINFO
Dim retvalue As Integer
osinfo.dwOSVersionInfoSize = 148
osinfo.szCSDVersion = Space$(128)
retvalue = GetVersionExA(osinfo)
getOsVersion = osinfo.dwPlatformId
End Function
Public Function GetElement(ByVal strList As String, ByVal strDelimiter As String, ByVal lngNumColumns As Long, ByVal lngRow As Long, ByVal lngColumn As Long) As String
Dim lngCounter As Long
' Append delimiter text to the end of the list as a terminator.
strList = strList & strDelimiter
' Calculate the offset for the item required based on the number of columns the list
' 'strList' has i.e. 'lngNumColumns' and from which row the element is to be
' selected i.e. 'lngRow'.
lngColumn = IIf(lngRow = 0, lngColumn, (lngRow * lngNumColumns) + lngColumn)
' Search for the 'lngColumn' item from the list 'strList'.
For lngCounter = 0 To lngColumn - 1
' Remove each item from the list.
strList = Mid$(strList, InStr(strList, strDelimiter) + Len(strDelimiter), Len(strList))
' If list becomes empty before 'lngColumn' is found then just
' return an empty string.
If Len(strList) = 0 Then
GetElement = ""
Exit Function
End If
Next lngCounter
' Return the sought list element.
GetElement = Left$(strList, InStr(strList, strDelimiter) - 1)
End Function
Public Function GetNumElements(ByVal strList As String, ByVal strDelimiter As String) As Integer
Dim intElementCount As Integer
' If no elements in the list 'strList' then just return 0.
If Len(strList) = 0 Then
GetNumElements = 0
Exit Function
End If
' Append delimiter text to the end of the list as a terminator.
strList = strList & strDelimiter
' Count the number of elements in 'strlist'
While InStr(strList, strDelimiter) > 0
intElementCount = intElementCount + 1
strList = Mid$(strList, InStr(strList, strDelimiter) + 1, Len(strList))
Wend
' Return the number of elements in 'strList'.
GetNumElements = intElementCount
End Function
增加Command按鈕事件
雙擊Command按鈕，增加如下代碼：
Private Sub CommandButton1_Click()
Dim objDlls As New Collection
Dim lngIndex As Long
GetDLLs TextBox1.Text, objDlls
ListBox1.Clear
For lngIndex = 1 To objDlls.Count
ListBox1.AddItem objDlls(lngIndex)
Next
End Sub
獲取當(dāng)前進(jìn)程的dll路徑
選擇UserForm1，按F5運(yùn)行，點(diǎn)擊按鈕，可以獲取當(dāng)前進(jìn)程所有dll的路徑。
獲取指定進(jìn)程的dll路徑
選擇UserForm1，按F5運(yùn)行，在本文框中輸入進(jìn)程名稱(chēng)，點(diǎn)擊按鈕，就可以獲取和進(jìn)程名稱(chēng)匹配的進(jìn)程的所有dll的路徑。
下載測(cè)試工程代碼
測(cè)試用的Excel及VBA代碼共享在如下位置，可以自行下來(lái)測(cè)試。
下載路徑：http://pan.baidu.com/s/1bpAnpcN
聯(lián)系客服
