'添加 Picture1 Picture2 Command1 Imagelist1 ListView1 Option Explicit '**************************** 进程 API Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwprocessid As Long) As Long Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal aint As Long) As Long Const MAXLEN = 255 Const GW_HWNDNEXT = 2 '******************************** 图标API Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long Private Declare Function ExtractAssociatedIcon Lib "shell32.dll" Alias "ExtractAssociatedIconA" (ByVal hInst As Long, ByVal lpIconPath As String, lpiIcon As Long) As Long Private Declare Function DrawIconEx Lib "user32" (ByVal hdc As Long, ByVal Xleft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long Const DI_MASK = &H1 Const DI_IMAGE = &H2 Const DI_NORMAL = DI_MASK Or DI_IMAGE '************************************** 变量宣告 ************************************* Dim proid&, hProcess&, phwnd&, hwndval&, tt&, i&, j%, transcolor&, mIcon& Dim aa$, clsnm$, captitle$, exename$, exepath$, tmpstr$ Dim imgX As ListImage, xn As ListItem, itm As ListItem, clm As ColumnHeader Dim objWMIService, objProcess, colProcess, itmX Private Sub Form_Load() transcolor = vbBlue With Picture1 .BorderStyle = 0 .AutoSize = True .AutoRedraw = True .ScaleMode = 3 .BackColor = transcolor .Move 0, Me.Height - 1000, 480, 480 .ZOrder 0 End With With Picture2 .ScaleMode = 3 .BorderStyle = 0 .AutoRedraw = True .Move Screen.Width, 0, 480, 480 End With '*********************************************************** ImageList1.MaskColor = transcolor ImageList1.UseMaskColor = transcolor ImageList1.BackColor = transcolor '************************************************************ ListView1.Arrange = lvwAutoLeft ListView1.LabelWrap = False ListView1.FlatScrollBar = False 'ListView1.Sorted = True ListView1.ListItems.Clear ListView1.ColumnHeaders.Clear ListView1.View = lvwReport Set clm = ListView1.ColumnHeaders.Add(, , "进程名称", 1800) Set clm = ListView1.ColumnHeaders.Add(, , "句 柄", 1000) Set clm = ListView1.ColumnHeaders.Add(, , "PID", 800) Set clm = ListView1.ColumnHeaders.Add(, , "类 名", 1800) Set clm = ListView1.ColumnHeaders.Add(, , "窗口标题", 2600) Set clm = ListView1.ColumnHeaders.Add(, , "路 径", 4000) ListView1.Refresh Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2 End Sub Private Sub Command1_Click() On Error Resume Next Picture1.ZOrder 0 tmpstr = "." Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & tmpstr & "\root\cimv2") Set colProcess = objWMIService.ExecQuery("Select * from Win32_Process") If ImageList1.ListImages.Count > 0 Then ListView1.ListItems.Clear Set ListView1.SmallIcons = Nothing Set ListView1.Icons = Nothing ImageList1.ListImages.Clear End If i = 1 For Each objProcess In colProcess Picture1.Cls Picture2.Cls proid = objProcess.processid exename = objProcess.Name exepath = IIf(proid > 8 And exename <> "csrss.exe" And exename <> "dllhost.exe", objProcess.ExecutablePath, "") phwnd = InstanceToWnd(proid) clsnm = Getclassnm(phwnd) captitle = GetCaptionFromHwnd(phwnd) j = InStr(captitle, Chr(0)) If j > 0 Then captitle = Mid(captitle, 1, j - 1) If exepath <> "" Then Call Geticonmain(Picture1, exepath) BitBlt Picture2.hdc, 0, 0, 32, 32, Picture1.hdc, 0, 0, vbSrcCopy ImageList1.ListImages.Add i, "", Picture2.Image ListView1.SmallIcons = ImageList1 ListView1.Icons = ImageList1 Set itm = ListView1.ListItems.Add(, "Row" & CStr(i), exename, 1, i) itm.SubItems(1) = CStr(phwnd) itm.SubItems(2) = CStr(proid) If clsnm <> "" Then itm.SubItems(3) = clsnm If captitle <> "" Then itm.SubItems(4) = captitle If exepath <> "" Then itm.SubItems(5) = exepath i = i + 1 End If Next Picture1.Move Screen.Width MsgBox ListView1.ListItems.Count End Sub Public Function InstanceToWnd(ByVal target_pid As Long) As Long Dim test_hwnd&, test_pid&, test_thread_id& '以ProID查找Hwnd test_hwnd = FindWindow(vbNullString, vbNullString) Do While test_hwnd <> 0 If GetParent(test_hwnd) = 0 Then test_thread_id = GetWindowThreadProcessId(test_hwnd, test_pid) If test_pid = target_pid Then InstanceToWnd = test_hwnd: Exit Do End If test_hwnd = GetWindow(test_hwnd, GW_HWNDNEXT) Loop End Function Public Function Getclassnm(hwnd As Long) As String Dim Ret$, RetVal&, lpClassName$ lpClassName = Space(256) RetVal = GetClassName(hwnd, lpClassName, 256) Getclassnm = Trim(Left(lpClassName, RetVal)) End Function Public Function GetCaptionFromHwnd(hwnd As Long) As String Dim strBuffer$, intCount% strBuffer = String$(MAXLEN - 1, 0) intCount = GetWindowText(hwnd, strBuffer, MAXLEN) If intCount > 0 Then GetCaptionFromHwnd = Trim(Left(strBuffer, intCount)) End Function Public Function Geticonmain(pic1 As Object, pathstr As String) As Long On Error Resume Next If TypeOf pic1 Is Form Or TypeOf pic1 Is PictureBox Then pic1.AutoRedraw = False mIcon = ExtractAssociatedIcon(App.hInstance, pathstr, 2) DrawIconEx pic1.hdc, 0, 0, mIcon, 0, 0, 0, 0, DI_NORMAL Geticonmain = pic1.hdc DestroyIcon mIcon End Function