如果做象QQ表情窗口一样的图片列表呢

Question

如果做象QQ表情窗口一样的图片列表呢

Answer 1

你可以参考这个代码的作法, 使用 ListView【CBM666 的图标进程】'添加 Picture1 Picture2 Command1 Imagelist1 ListView1Option 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 SubPrivate 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
End SubPublic 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 FunctionPublic 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 FunctionPublic 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 FunctionPublic 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
效果图:
http://p.blog.csdn.net/images/p_blog_csdn_net/cbm666/366646/o_20fd42a737671e9bd0435858.jpg 

Answer 2

好象以前有做过，直接就用多个image显示在那就是了嘛
我找一下。