FreeBasic
Главная
Вход
Регистрация
Воскресенье, 22.10.2017, 05:30Приветствую Вас Гость | RSS
[ Новые сообщения · Участники · Правила форума · Поиск · RSS ]
Страница 1 из 11
Форум » Freebasic » Исходники » Подсветка и цветная рамка окна под курсором, получение инфы
Подсветка и цветная рамка окна под курсором, получение инфы
SomerickДата: Понедельник, 25.07.2016, 06:58 | Сообщение # 1
Рядовой
Группа: Пользователи
Сообщений: 10
Репутация: 2
Статус: Offline
Простейший пример как можно показать осветлением и переливающейся рамкой место заданного окна. Задаётся наведением курсора на него или, когда поиск остановлен, задаётся вручную введением в верхнее поле хендла и нажатием кнопки "i" или на клавиатуре Enter.
Вместо рисования прямо на экранном DC и обновления региона ставится полупрозрачное окошко по размеру целевого окна. Да, не совсем правильный метод, но и так работает.
Брать контекст окон не имеет смысла, так как в тех случаях когда они закрыты другими то рамка не отображается.



HWNDInfo.bas
Код
#Include Once"windows.bi"
#Include Once"win\tlhelp32.bi"
Dim Shared As HWND hw,tHwnd,tInfo,btnSearch,btnInfo,btnGetParent,LayerWnd,x,res
Dim Shared As Long col,iFlag
Dim Shared As MODULEENTRY32 MODULENTRY
Declare Sub StartStopSearch

Sub WndInfo
Dim As ZString*3000 s=Any
Dim As ZString*510 sTxt=Any
Dim As ZString*130 sClass=Any,sParClass=Any,sLocale=Any
Dim As ZString Ptr pM=Any,psVE=Any,psF=Any
Dim As Long lnTxt=Any,idt=Any,idp=Any
Dim As HWND par=Any
Dim As RECT rr=Any
Dim As WINDOWPLACEMENT wp=Any
Dim As Point cp=Any
Dim As HPEN pen=Any,OldPen=Any
Dim As LOGFONT LF=Any

If iFlag Then'выдача info
    iFlag-=1
    If iFlag<1 Then StartStopSearch:Exit Sub
Else'ищем окно под курсором
    GetCursorPos @cp
    res=WindowFromPoint(cp)
    SetDlgItemInt hw,1003,res,1
EndIf

If x<>res Then'сменилось окно, обновляем параметры
    x=res
    GetWindowRect res,@rr'получаем координаты
    wp.Length=SizeOf(WINDOWPLACEMENT)
    GetWindowPlacement res,@wp
    MoveWindow LayerWnd,rr.left,rr.top,rr.right-rr.left,rr.bottom-rr.top,1'ставим по координатам
    par=GetParent(res)'получаем hwnd родительск. окна
    GetClassName res,sClass,128:sParClass[0]=0:GetClassName par,sParClass,128'получаем классы
    lnTxt=SendMessage(res,WM_GETTEXT,501,Cast(lparam,@sTxt))'получаем текст
    pM=@""
    If lnTxt>499 Then
      lnTxt=SendMessage(res,WM_GETTEXTLENGTH,0,0)
      pM=@"(View 500)"
    EndIf

    idt=GetWindowThreadProcessId(res,@idp)'получаем инфо о процессе
    Var pSnap=CreateToolhelp32Snapshot(TH32CS_SNAPMODULE,idp)
    MODULENTRY.dwSize=SizeOf(MODULENTRY)
    MODULENTRY.szExePath[0]=0
    Module32First pSnap,@MODULENTRY
    CloseHandle pSnap

    Select Case IIf(IsWindowVisible(res),0,1)+IIf(IsWindowEnabled(res),0,10)+IIf(IsIconic(res),100,0)
    Case 0:psVE=@""
    Case 1:psVE=@!"wnd not visible\r\n"
    Case 10:psVE=@!"wnd not enabled\r\n"
    Case 11:psVE=@!"wnd not enabled, not visible\r\n"
    Case 100:psVE=@!"wnd is iconic\r\n"
    Case 101:psVE=@!"wnd is iconic, not visible\r\n"
    Case 110:psVE=@!"wnd is iconic, not enabled\r\n"
    Case 111:psVE=@!"wnd is iconic, not enabled, not visible\r\n"
    End Select

    Var hFont=SendMessage(res,WM_GETFONT,0,0)'получаем шрифт
    If hFont Then psF=@"" Else psF=@"(Default system font)":hFont=GetStockObject(SYSTEM_FONT)
    LF.lfFaceName[0]=0:LF.lfHeight=0
    GetObject hFont,sizeof(LOGFONT),@LF

    Var hkl=LoWord(GetKeyboardLayout(idt))'получаем локаль
    GetLocaleInfo hkl,LOCALE_SENGLANGUAGE,@sLocale,128

'вывод всех параметров в текст
    wsprintf s,!"Thread: %d Process: %d\r\n"_
    !"BaseAddr: %d BaseSize: %d\r\n"_
    !"Path: %s\r\n"_
    !"HWND: %d Parent: %d\r\n%s"_
    !"Class: %s Parent: %s\r\n"_
    !"Control ID: %d\r\n"_
    !"Position x,y,w,h: %d,%d,%d,%d"_
    !" Rect l,t,r,b: %d,%d,%d,%d\r\n"_
    !"Style: %d ExStyle: %d\r\n"_
    !"LayoutLocale: %d(%s) Font: %s,%d%s\r\n"_
    !"Text %dB%s: %s",_
    idt,idp,_
    MODULENTRY.modBaseAddr,MODULENTRY.modBaseSize,_
    @MODULENTRY.szExePath,_
    res,par,psVE,_
    sClass,sParClass,_
    GetDlgCtrlID(res),_
    wp.rcNormalPosition.left,wp.rcNormalPosition.top,wp.rcNormalPosition.right-wp.rcNormalPosition.left,wp.rcNormalPosition.bottom-wp.rcNormalPosition.top,_
    rr.left,rr.top,rr.right,rr.bottom,_
    GetWindowLong(res,GWL_STYLE),GetWindowLong(res,GWL_EXSTYLE),_
    hkl,sLocale,LF.lfFaceName,Abs(LF.lfHeight),psF,_
    lnTxt,pM,sTxt
    SetWindowText tInfo,s
EndIf

'цветная рамка окна
Dim As HDC dc=GetDC(LayerWnd)
If dc Then
    col+=758630'смена цвета
    If col>17783049 Then col=cp.x
    pen=CreatePen(0,5,col)
    SelectObject dc,pen
    GetClientRect LayerWnd,@rr
    Rectangle dc,rr.left,rr.top,rr.right,rr.bottom
    DeleteObject pen
    ReleaseDC LayerWnd,dc
EndIf

If GetAsyncKeyState(VK_ESCAPE)Then StartStopSearch
End Sub

Sub StartStopSearch
If LayerWnd Then
    KillTimer hw,123
    DestroyWindow LayerWnd
    LayerWnd=0
    iFlag=0
    SetWindowText btnSearch,"Start"
Else
    SetTimer hW,123,160,@WndInfo
    LayerWnd=CreateWindowEx(&h000802AC,"#32770","",&hD0800000,0,0,1,1,0,0,0,0)
    SetLayeredWindowAttributes LayerWnd,0,115,LWA_ALPHA
    SetWindowText btnSearch,"Stop (Press Esc)"
EndIf
End Sub

Sub GetInfo(p As Long)
Dim As ZString*100 s=Any
res=GetDlgItemInt(hw,1003,0,1)
If IsWindow(res)Then
    If p Then res=GetParent(res):If IsWindow(res)=0 Then GoTo SetTxt
    x=res+1:iFlag=10
    If LayerWnd=0 Then StartStopSearch
Else
SetTxt:
    wsprintf s,"No exist wnd %d",res
    SetWindowText tInfo,s
EndIf
End Sub

Sub main Cdecl Alias"main"'Точка входа. При запуске программы вызывается эта процедура. В CompileExeGUISubmain.bat уже задана.
Dim As MSG msg=Any
hw=CreateWindowEx(256,"#32770","HWND Info",348782592,500,234,470,326,0,0,0,0)'диалоговый класс не требует регистрации
btnSearch=CreateWindowEx(0,"Button","",1342189312,6,0,135,32,hw,1001,0,0)
tInfo=CreateWindowEx(512,"Edit","",1345392836,6,32,450,245,hw,1002,0,0)
tHwnd=CreateWindowEx(512,"Edit","3016828",1342251008,144,0,88,24,hw,1003,0,0)
btnInfo=CreateWindowEx(0,"Button","i",1342189312,232,0,24,24,hw,1004,0,0)
btnGetParent=CreateWindowEx(0,"Button","GetParent",1342189312,256,0,84,24,hw,1004,0,0)
StartStopSearch

While GetMessage(@msg,0,0,0)
 Select Case msg.message
    Case WM_SYSCOMMAND
        If msg.wParam=SC_CLOSE Then Exit While
     Case WM_COMMAND
        If msg.hwnd=hw Then Exit While
    Case WM_LBUTTONUP
        Select Case msg.hwnd
            Case btnSearch:StartStopSearch
            Case btnInfo:GetInfo 0
            Case btnGetParent:GetInfo 1
        End Select
    Case WM_KEYDOWN
        If msg.hwnd=tHwnd And msg.wParam=13 Then GetInfo 0
 End Select
 TranslateMessage @msg
 DispatchMessage @msg
Wend

DestroyWindow LayerWnd
DestroyWindow hw
ExitProcess 0
End Sub


CompileExeGUISubmain.bat
Код
@echo off
:: Расположение папки компилятора. Задать и сохранить bat. Перетащить bas на этот bat.
SET FBPATH=C:\FreeBASIC-1.05.0-win32

%~d1
cd %~p1
SET File=%~n1
SET LIBS=-lkernel32 -luser32 -lgdi32 -lmsimg32 -lshell32 -lComdlg32 -lole32 -ladvapi32.dll -luuid -loleaut32 -limm32 -lwinmm -lcomctl32.dll -lfb -lgcc -lmingw32 -lmingwex -lmoldname -lsupc++ -lgcc_eh -lmsvcrt

If Not Exist %File%.rc GoTo norc
echo compiling resource..
SET RES="%File%.res.obj"
%FBPATH%\bin\win32\gorc /ni /nw /o /fo %RES% "%File%.rc"
:norc
echo compiling..
%FBPATH%\fbc.exe -w 3 %1 -r -lib
If ErrorLevel 1 echo # Compile error! # && GoTo exit
echo assembling..
%FBPATH%\bin\win32\as.exe --32 --strip-local-absolute %File%.asm -o %File%.o
If ErrorLevel 1 echo # Asm error! # && GoTo exit
echo linking..
%FBPATH%\bin\win32\ld.exe -e _main -subsystem windows "%FBPATH%\lib\win32\fbextra.x" -s --stack 102400,102400 -L %FBPATH%\lib\win32 -L "./" "%File%.o" %RES% -o "%File%.exe" -( %LIBS% -)
If ErrorLevel 1 echo # Link error! # && GoTo exit
echo # No errors ! #
:exit
pause


Сообщение отредактировал Somerick - Воскресенье, 07.08.2016, 00:35
 
haavДата: Понедельник, 25.07.2016, 07:47 | Сообщение # 2
Генерал-лейтенант
Группа: Администраторы
Сообщений: 777
Репутация: 34
Статус: Offline
Та же проблема, что и здесь: http://freebasic.ucoz.com/forum/5-368-1

В остальном работает хорошо.

И тот же вопрос: не против, если выложу программу на основном сайте?


Вы сохраняете власть над людьми покуда оставляете им что-то…Отберите у человека все, и этот человек уже будет неподвластен вам…
 
SomerickДата: Вторник, 02.08.2016, 02:12 | Сообщение # 3
Рядовой
Группа: Пользователи
Сообщений: 10
Репутация: 2
Статус: Offline
Код изменён, добавлено PostQuitMessage 0, теперь-то должно выходить
Добавлено получение инфы о процессе
Добавлена кнопка показывающая родительское окно получаемое из соответствующей апи функции.

Есть более мощная программа, сырая недоделанная, нет время, но уже можно пользоваться, немалый функционал работает. Посыл сообщений, поиск в списке окон.


https://yadi.sk/d/sjP2c_K-tpygQ
 
haavДата: Пятница, 05.08.2016, 10:29 | Сообщение # 4
Генерал-лейтенант
Группа: Администраторы
Сообщений: 777
Репутация: 34
Статус: Offline
Цитата Somerick ()
Код изменён, добавлено PostQuitMessage 0, теперь-то должно выходить


Неа, висит в процессах после закрытия окна


Вы сохраняете власть над людьми покуда оставляете им что-то…Отберите у человека все, и этот человек уже будет неподвластен вам…
 
SomerickДата: Воскресенье, 07.08.2016, 00:14 | Сообщение # 5
Рядовой
Группа: Пользователи
Сообщений: 10
Репутация: 2
Статус: Offline
Полагаю, финальная правка. Доработан выход из программы, выход по системной команде SC_CLOSE, ExitProcess 0 поставлен в конец главной процедуры.

Добавлено получение инфы о локали раскладки потока окна, id и соответствующий язык.
Добавлено получение инфы о шрифте, имя, высота. Если WM_GETFONT возвращает 0, значит у окна не был установлен шрифт, показывается имя и высота системного по умолчанию. (В окнах может быть отрисовка другими своими шрифтами)
 
Форум » Freebasic » Исходники » Подсветка и цветная рамка окна под курсором, получение инфы
Страница 1 из 11
Поиск: