1. Администрация SafeZone приветствует вас на нашем форуме!
    Если вы больше не желаете видеть рекламу при просмотре тем и сообщений - то достаточно просто зарегистрироваться. Для зарегистрированных пользователей реклама не отображается.
    Если у вас возникли проблемы с регистрацией на форуме - то вы можете сообщить об этом с помощью этой формы без авторизации,администрация форума обязательно отреагирует на вашу проблему.
    Скрыть объявление

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

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

  1. Сергей

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

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

    (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. Сергей

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

    Сообщения:
    277
    Симпатии:
    127
    Чуть не забыл. Там еще в модуле нужно (для работоспособности кода) если нужно уточнять:
    Код (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 Команда форума Супер-Модератор Разработчик Клуб переводчиков

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

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

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

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

    Сообщения:
    277
    Симпатии:
    127
    Все же сделал. Через 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 Команда форума Супер-Модератор Разработчик Клуб переводчиков

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

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

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

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

    Сообщения:
    5.171
    Симпатии:
    5.041
    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. Сергей

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

    Сообщения:
    277
    Симпатии:
    127
Загрузка...
Похожие темы - Получить иконку окна
  1. alex_diablo
    Ответов:
    2
    Просмотров:
    1.456
  2. Паразит
    Ответов:
    5
    Просмотров:
    1.287