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

Тема в разделе "Visual Basic 6 / Сценарии VBScript, JScript", создана пользователем Сергей, 17 ноя 2015.

  1. Сергей
    Оффлайн

    Сергей Активный пользователь

    Сообщения:
    253
    Симпатии:
    120
    Имея некий перечень исполняемых файлов, можно получить их иконки ,непример, так:

    (Form1.AutoRedraw = True и PictureEskiz(i).AutoRedraw = True)
    Код (vb.net):

    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
    Если иконка у файла есть, то она будет отображена на форме в соответствующем месте.

    А как получить иконки, имея перечень открытых окон таких файлов? Это надо как то по окну определить адрес исполняемого файла, и потом воспользоваться описанным методом, или как то по другому? Подскажите ,пожалуйста,.
     
    Последнее редактирование модератором: 18 ноя 2015
  2. Сергей
    Оффлайн

    Сергей Активный пользователь

    Сообщения:
    253
    Симпатии:
    120
    Чуть не забыл. Там еще в модуле нужно (для работоспособности кода) если нужно уточнять:
    Код (vb.net):
    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
     
    Последнее редактирование модератором: 18 ноя 2015
  3. Dragokas
    Онлайн

    Dragokas Very kind Developer Команда форума Супер-Модератор Разработчик Клуб переводчиков

    Сообщения:
    4.480
    Симпатии:
    4.307
    Нет. Это плохой вариант. Иконка может быть подгружена динамически (хороший пример - браузер, где для каждого окна иконка соответствует 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-битное приложение (сообщение просто к нему не дойдет).

    И не забывай использовать теги кода.
     
    Последнее редактирование: 18 ноя 2015
    Kиpилл нравится это.
  4. Сергей
    Оффлайн

    Сергей Активный пользователь

    Сообщения:
    253
    Симпатии:
    120
    С Си как то туговато. А на VB6 как то переводится?
    Про универсальность, это хорошо, но она здесь излишня. (Для меня) достаточно иметь иконку браузера, а иконку его окна не обязательно, да и 64-битных у меня (пока) нет.
     
  5. Сергей
    Оффлайн

    Сергей Активный пользователь

    Сообщения:
    253
    Симпатии:
    120
    Все же сделал. Через PID-ы

    CurrWnd получить через GetWindow -
    Код (vb.net):
    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
    Используйте теги кода.
     
    Последнее редактирование модератором: 22 ноя 2015
  6. Dragokas
    Онлайн

    Dragokas Very kind Developer Команда форума Супер-Модератор Разработчик Клуб переводчиков

    Сообщения:
    4.480
    Симпатии:
    4.307
    Точнее, GetWindowThreadProcessId.
    Только проверок на успех операции не хватает.
     
  7. Сергей
    Оффлайн

    Сергей Активный пользователь

    Сообщения:
    253
    Симпатии:
    120
    Если стоит On Error Resume Next, то результатом неудачи будет отсутствие пикчурки с иконкой, ну или накрайняк пустая пикчурка.
    (А теги кода обязательно?, без них можно повредить сайт?)
     
  8. Dragokas
    Онлайн

    Dragokas Very kind Developer Команда форума Супер-Модератор Разработчик Клуб переводчиков

    Сообщения:
    4.480
    Симпатии:
    4.307
    On Error Resume Next - это очень плохая практика и может привести к вылету приложения.
    Не у каждой API-функции есть защита от некорректных параметров,
    и не факт, что на одной системе все будет нормально, если Вы передадите 0 в качестве неудачно полученного хендла,
    а на другой вся программа не "рухнет".
    Неудача может произойти по многим причинам, например, защищенный процесс, недостаток полномочий при открытии процесса.
    Чтобы увеличить шанс успешного открытия процесса необходимо указывать минимальное количество прав, которое Вы хотите получить при доступе к процессу.
    Например, для систем Vista и выше положено использовать флаг PROCESS_QUERY_LIMITED_INFORMATION, а не PROCESS_QUERY_INFORMATION.
    Также потерпеть неудачу может функция GetModuleFileNameEx. Вдобавок к ней можно воспользоваться функцией QueryFullProcessImageName.
    Вот таким образом я получаю путь к процессу, имея в распоряжении его Process ID:
    Код (vb.net):

    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 также может вернуть неудачу, поэтому результат ее выполнения тоже нужно проверять.

    Сергей, на любом уважаемом себя сайте код оформляется в теги для удобочаемости его чтения. Теги обязательны. Не так сложно пройти по гиперссылке, которую я давал выше, и посмотреть, как быстро это оформить.
     
    Последнее редактирование: 22 ноя 2015
    Сергей нравится это.
  9. Сергей
    Оффлайн

    Сергей Активный пользователь

    Сообщения:
    253
    Симпатии:
    120

Поделиться этой страницей