Получить иконку окна

Сергій

Разработчик
Сообщения
1,045
Реакции
300
Имея некий перечень исполняемых файлов, можно получить их иконки ,непример, так:

(Form1.AutoRedraw = True и PictureEskiz(i).AutoRedraw = True)
VB.NET / VBA:
For i=1 to Fajlov
PictureEskiz(i).Cls
PictureEskiz(i).Visible = CBool(DrawIcon(PictureEskiz(i).hDC, 0, 0, ExtractIcon(App.hInstance, AdresFajla(i), 0)) <> 0)
Next i
Если иконка у файла есть, то она будет отображена на форме в соответствующем месте.

А как получить иконки, имея перечень открытых окон таких файлов? Это надо как то по окну определить адрес исполняемого файла, и потом воспользоваться описанным методом, или как то по другому? Подскажите ,пожалуйста,.
 
Последнее редактирование модератором:
Чуть не забыл. Там еще в модуле нужно (для работоспособности кода) если нужно уточнять:
VB.NET / VBA:
Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long
Declare Function DrawIcon Lib "user32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal hIcon As Long) As Long
 
Последнее редактирование модератором:
Нет. Это плохой вариант. Иконка может быть подгружена динамически (хороший пример - браузер, где для каждого окна иконка соответствует favicon-у сайта),
тогда максимум, что ты получишь из исполняемого файла, - это иконку по-умолчанию.

Действуй, как описано в этом примере: Find an application’s icon with WinAPI | CodeUtopia

C#:
public const int GCL_HICONSM = -34;
public const int GCL_HICON = -14;

public const int ICON_SMALL = 0;
public const int ICON_BIG = 1;
public const int ICON_SMALL2 = 2;

public const int WM_GETICON = 0x7F;

public static IntPtr GetClassLongPtr(IntPtr hWnd, int nIndex)
{
  if (IntPtr.Size > 4)
    return GetClassLongPtr64(hWnd, nIndex);
  else
    return new IntPtr(GetClassLongPtr32(hWnd, nIndex));
}

[DllImport("user32.dll", EntryPoint = "GetClassLong")]
public static extern uint GetClassLongPtr32(IntPtr hWnd, int nIndex);

[DllImport("user32.dll", EntryPoint = "GetClassLongPtr")]
public static extern IntPtr GetClassLongPtr64(IntPtr hWnd, int nIndex);

[DllImport("user32.dll", CharSet = CharSet.Auto, SetLastError = false)]
static extern IntPtr SendMessage(IntPtr hWnd, int Msg, int wParam, int lParam);

public Icon GetAppIcon(IntPtr hwnd)
{
  IntPtr iconHandle = SendMessage(hwnd,WM_GETICON,ICON_SMALL2,0);
  if(iconHandle == IntPtr.Zero)
    iconHandle = SendMessage(hwnd,WM_GETICON,ICON_SMALL,0);
  if(iconHandle == IntPtr.Zero)
    iconHandle = SendMessage(hwnd,WM_GETICON,ICON_BIG,0);
  if (iconHandle == IntPtr.Zero)
    iconHandle = GetClassLongPtr(hwnd, GCL_HICON);
  if (iconHandle == IntPtr.Zero)
    iconHandle = GetClassLongPtr(hwnd, GCL_HICONSM);
  if(iconHandle == IntPtr.Zero)
    return null;
  Icon icn = Icon.FromHandle(iconHandle);
  return icn;
}

Если не ошибаюсь, таким способом, тебе не получится извлечь иконку из окна 64-разрядной программы из под VB6, коим является 32-битное приложение (сообщение просто к нему не дойдет).

И не забывай использовать теги кода.
 
Последнее редактирование:
С Си как то туговато. А на VB6 как то переводится?
Про универсальность, это хорошо, но она здесь излишня. (Для меня) достаточно иметь иконку браузера, а иконку его окна не обязательно, да и 64-битных у меня (пока) нет.
 
Все же сделал. Через PID-ы

CurrWnd получить через GetWindow -
VB.NET / VBA:
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long

For i=1 to Fajlov
TID = GetWindowThreadProcessId(CurrWnd, PID)
hProc2 = OpenProcess(&H400 Or &H10, 0, PID)
AdresFajla(i) = Space(255)
GetModuleFileNameEx hProc2, 0, AdresFajla(i), 255
CloseHandle hProc2
PictureEskiz(i).Cls
PictureEskiz(i).Visible = CBool(DrawIcon(PictureEskiz(i).hDC, 0, 0, ExtractIcon(App.hInstance, AdresFajla(i), 0)) <> 0)
Next i
Предупреждение
Используйте теги кода.
 
Последнее редактирование модератором:
Точнее, GetWindowThreadProcessId.
Только проверок на успех операции не хватает.
 
Если стоит On Error Resume Next, то результатом неудачи будет отсутствие пикчурки с иконкой, ну или накрайняк пустая пикчурка.
(А теги кода обязательно?, без них можно повредить сайт?)
 
Если стоит On Error Resume Next, то результатом неудачи будет отсутствие пикчурки с иконкой, ну или накрайняк пустая пикчурка.
On Error Resume Next - это очень плохая практика и может привести к вылету приложения.
Не у каждой API-функции есть защита от некорректных параметров,
и не факт, что на одной системе все будет нормально, если Вы передадите 0 в качестве неудачно полученного хендла,
а на другой вся программа не "рухнет".
Неудача может произойти по многим причинам, например, защищенный процесс, недостаток полномочий при открытии процесса.
Чтобы увеличить шанс успешного открытия процесса необходимо указывать минимальное количество прав, которое Вы хотите получить при доступе к процессу.
Например, для систем Vista и выше положено использовать флаг PROCESS_QUERY_LIMITED_INFORMATION, а не PROCESS_QUERY_INFORMATION.
Также потерпеть неудачу может функция GetModuleFileNameEx. Вдобавок к ней можно воспользоваться функцией QueryFullProcessImageName.
Вот таким образом я получаю путь к процессу, имея в распоряжении его Process ID:
VB.NET / VBA:
Private Declare Function OpenProcessToken Lib "advapi32" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As Long
Private Declare Function GetModuleFileNameEx Lib "psapi.dll" Alias "GetModuleFileNameExW" (ByVal hProcess As Long, ByVal hModule As Long, ByVal lpFileName As Long, ByVal nSize As Long) As Long
Private Declare Function GetProcessImageFileName Lib "psapi.dll" Alias "GetProcessImageFileNameW" (ByVal hProcess As Long, ByVal lpImageFileName As Long, ByVal nSize As Long) As Long
Private Declare Function GetFullPathName Lib "kernel32.dll" Alias "GetFullPathNameW" (ByVal lpFileName As Long, ByVal nBufferLength As Long, ByVal lpBuffer As Long, lpFilePart As Long) As Long
Private Declare Function QueryFullProcessImageName Lib "kernel32.dll" Alias "QueryFullProcessImageNameW" (ByVal hProcess As Long, ByVal dwFlags As Long, ByVal lpExeName As Long, ByVal lpdwSize As Long) As Long
Private Declare Function GetLogicalDriveStrings Lib "kernel32.dll" Alias "GetLogicalDriveStringsW" (ByVal nBufferLength As Long, ByVal lpBuffer As Long) As Long
Private Declare Function QueryDosDevice Lib "kernel32.dll" Alias "QueryDosDeviceW" (ByVal lpDeviceName As Long, ByVal lpTargetPath As Long, ByVal ucchMax As Long) As Long

Function GetFilePathByPID(PID As Long) As String
    Const MAX_PATH_W                        As Long = 32767&
    Const PROCESS_VM_READ                   As Long = 16&
    Const PROCESS_QUERY_INFORMATION         As Long = 1024&
    Const PROCESS_QUERY_LIMITED_INFORMATION As Long = &H1000&
  
    Dim ProcPath    As String
    Dim hProc       As Long
    Dim cnt         As Long
    Dim pos         As Long
    Dim FullPath    As String
    Dim SizeOfPath  As Long
    Dim lpFilePart  As Long

    hProc = OpenProcess(IIf(bIsWinVistaOrLater, PROCESS_QUERY_LIMITED_INFORMATION, PROCESS_QUERY_INFORMATION) Or PROCESS_VM_READ, 0&, PID)
    If hProc <> 0 Then
  
        If bIsWinVistaOrLater Then
            cnt = MAX_PATH_W + 1
            ProcPath = Space$(cnt)
            Call QueryFullProcessImageName(hProc, 0&, StrPtr(ProcPath), VarPtr(cnt))
        End If
      
        If 0 <> err.LastDllError Or Not bIsWinVistaOrLater Then     'Win 2008 Server (x64) can cause Error 128 if path contains space characters
      
            ProcPath = Space$(MAX_PATH)
            cnt = GetModuleFileNameEx(hProc, 0&, StrPtr(ProcPath), Len(ProcPath))
      
            If cnt = MAX_PATH Then 'Path > MAX_PATH -> realloc
                ProcPath = Space$(MAX_PATH_W)
                cnt = GetModuleFileNameEx(hProc, 0&, StrPtr(ProcPath), Len(ProcPath))
            End If
        End If
      
        If cnt <> 0 Then                          'clear path
            ProcPath = Left$(ProcPath, cnt)
            If StrComp("\SystemRoot\", Left$(ProcPath, 12), 1) = 0 Then ProcPath = sWinDir & Mid$(ProcPath, 12)
            If "\??\" = Left$(ProcPath, 4) Then ProcPath = Mid$(ProcPath, 5)
        End If
      
        If ERROR_PARTIAL_COPY = err.LastDllError Or cnt = 0 Then     'because GetModuleFileNameEx cannot access to that information for 64-bit processes on WOW64
            ProcPath = Space$(MAX_PATH)
            cnt = GetProcessImageFileName(hProc, StrPtr(ProcPath), Len(ProcPath))
          
            If cnt <> 0 Then
                ProcPath = Left$(ProcPath, cnt)
              
                ' Convert DosDevice format to Disk drive format
                If StrComp(Left$(ProcPath, 8), "\Device\", 1) = 0 Then
                    pos = InStr(9, ProcPath, "\")
                    If pos <> 0 Then
                        FullPath = ConvertDosDeviceToDriveName(Left$(ProcPath, pos - 1))
                        If Len(FullPath) <> 0 Then
                            ProcPath = FullPath & Mid$(ProcPath, pos + 1)
                        End If
                    End If
                End If
              
            End If
          
        End If
      
        If cnt <> 0 Then    'if process ran with 8.3 style, GetModuleFileNameEx will return 8.3 style on x64 and full pathname on x86
                            'so wee need to expand it ourself
      
            FullPath = Space$(MAX_PATH)
            SizeOfPath = GetFullPathName(StrPtr(ProcPath), MAX_PATH, StrPtr(FullPath), lpFilePart)
            If SizeOfPath <> 0& Then
                GetFilePathByPID = Left$(FullPath, SizeOfPath)
            Else
                GetFilePathByPID = ProcPath
            End If
          
        End If
      
        CloseHandle hProc
    End If
End Function

Public Function ConvertDosDeviceToDriveName(inDosDeviceName As String) As String
    On Error Resume Next

    Static DosDevices   As New Collection
  
    If DosDevices.Count Then
        ConvertDosDeviceToDriveName = DosDevices(inDosDeviceName)
        Exit Function
    End If
  
    Dim aDrive()        As String
    Dim sDrives         As String
    Dim cnt             As Long
    Dim i               As Long
    Dim DosDeviceName   As String
  
    cnt = GetLogicalDriveStrings(0&, StrPtr(sDrives))
  
    sDrives = Space(cnt)
  
    cnt = GetLogicalDriveStrings(Len(sDrives), StrPtr(sDrives))

    If 0 = err.LastDllError Then
  
        aDrive = Split(Left$(sDrives, cnt - 1), vbNullChar)
  
        For i = 0 To UBound(aDrive)
          
            DosDeviceName = Space(MAX_PATH)
          
            cnt = QueryDosDevice(StrPtr(Left$(aDrive(i), 2)), StrPtr(DosDeviceName), Len(DosDeviceName))
          
            If cnt <> 0 Then
          
                DosDeviceName = Left$(DosDeviceName, InStr(DosDeviceName, vbNullChar) - 1)

                DosDevices.Add aDrive(i), DosDeviceName

            End If
          
        Next
  
    End If
  
    ConvertDosDeviceToDriveName = DosDevices(inDosDeviceName)
  
End Function
ExtractIcon также может вернуть неудачу, поэтому результат ее выполнения тоже нужно проверять.

(А теги кода обязательно?, без них можно повредить сайт?)
Сергей, на любом уважаемом себя сайте код оформляется в теги для удобочаемости его чтения. Теги обязательны. Не так сложно пройти по гиперссылке, которую я давал выше, и посмотреть, как быстро это оформить.
 
Последнее редактирование:
Назад
Сверху Снизу