| Вопрос: Помогите с иконкой | Добавлено: 28.08.04 18:25 |
Автор вопроса:  D_i_M
|
| Ответы | Всего ответов: 64 |
|
Номер ответа: 61 Автор ответа:  cresta Вопросов: 117 Ответов: 1538 |
Профиль | | #61 | Добавлено: 07.09.04 16:33 |
|
Код помести в модуль, не забудь установить в свойствах проекта старт - Sub Main. Ну и соорудить манифест и положить рядом с ехе-шником.
Declare Function RegisterClass Lib "user32" Alias "RegisterClassA" (Class As WNDCLASS) As Long Declare Function UnregisterClass Lib "user32" Alias "UnregisterClassA" (ByVal lpClassName As String, ByVal hInstance As Long) As Long Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long Declare Function DefWindowProc Lib "user32" Alias "  efWindowProcA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Declare Sub PostQuitMessage Lib "user32" (ByVal nExitCode As Long) Declare Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As Msg, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long Declare Function TranslateMessage Lib "user32" (lpMsg As Msg) As Long Declare Function DispatchMessage Lib "user32" Alias " ispatchMessageA" (lpMsg As Msg) As Long
Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Any) As Long Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Declare Function INITCOMMONCONTROLSEX Lib "comctl32.dll" Alias "InitCommonControlsEx" (ByRef TLPINITCOMMONCONTROLSEX As INITCOMMONCONTROLSEX) As Long Declare Function ExtractAssociatedIcon Lib "shell32.dll" Alias "ExtractAssociatedIconA" (ByVal hInst As Long, ByVal lpIconPath As String, lpiIcon As Long) As Long 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 Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long Declare Function GetWindowDC Lib "user32.dll" (ByVal hwnd As Long) As Long Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hDC As Long) As Long Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Type INITCOMMONCONTROLSEX dwSize As Long dwICC As Long End Type Type WNDCLASS style As Long lpfnwndproc As Long cbClsextra As Long cbWndExtra2 As Long hInstance As Long hIcon As Long hCursor As Long hbrBackground As Long lpszMenuName As String lpszClassName As String End Type Type POINTAPI x As Long y As Long End Type Type Msg hwnd As Long message As Long wParam As Long lParam As Long time As Long pt As POINTAPI End Type Public Const CS_VREDRAW = &H1 Public Const CS_HREDRAW = &H2 Public Const WS_OVERLAPPED = &H0& Public Const WS_CHILD = &H40000000 Public Const WS_VISIBLE = &H10000000 Public Const WS_CAPTION = &HC00000 Public Const WS_BORDER = &H800000 Public Const WS_DLGFRAME = &H400000 Public Const WS_VSCROLL = &H200000 Public Const WS_HSCROLL = &H100000 Public Const WS_SYSMENU = &H80000 Public Const WS_THICKFRAME = &H40000 Public Const WS_MINIMIZEBOX = &H20000 Public Const WS_MAXIMIZEBOX = &H10000 Public Const WS_OVERLAPPEDWINDOW = (WS_OVERLAPPED Or WS_CAPTION Or WS_SYSMENU Or WS_THICKFRAME Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX) Public Const COLOR_WINDOW = 5 Public Const WM_DESTROY = &H2 Public Const SW_SHOWNORMAL = 1 Public Const IDC_ARROW = 32512& Public Const GWL_WNDPROC = -4 Public Const WM_PAINT As Long = &HF Const DI_MASK = &H1 Const DI_IMAGE = &H2 Const DI_NORMAL = DI_MASK Or DI_IMAGE Const BS_RIGHT As Long = &H200& Dim hwnd2 As Long, hwnd3 As Long, old_proc As Long, new_proc As Long Dim hIcon As Long, ic As INITCOMMONCONTROLSEX Public Sub Main() im lngTemp As Long
INITCOMMONCONTROLSEX ic hIcon = ExtractAssociatedIcon(App.hInstance, "C:\Autoexec.bat", 2) If RegClass Then If CreateTestWindow Then new_proc = GetWndProc(AddressOf ButtonProc) old_proc = SetWindowLong(hwnd2, GWL_WNDPROC, new_proc) MessageLoopProc End If UnRegClass End If estroyIcon hIcon
End Sub Private Function RegClass() As Boolean im wndcls As WNDCLASS
wndcls.style = CS_HREDRAW + CS_VREDRAW wndcls.lpfnwndproc = GetWndProc(AddressOf WndProc) wndcls.cbClsextra = 0 wndcls.cbWndExtra2 = 0 wndcls.hInstance = App.hInstance wndcls.hIcon = 0 wndcls.hCursor = LoadCursor(0, IDC_ARROW) wndcls.hbrBackground = COLOR_WINDOW wndcls.lpszMenuName = 0 wndcls.lpszClassName = "wClass" RegClass = (RegisterClass(wndcls) <> 0) End Function Private Sub UnRegClass() UnregisterClass "wClass", App.hInstance End Sub Private Function CreateTestWindow() As Boolean im hwnd As Long
hwnd = CreateWindowEx(0, "wClass", "Pic Button", WS_OVERLAPPEDWINDOW, 100, 100, 200, 200, 0, 0, App.hInstance, ByVal 0& 
hwnd2 = CreateWindowEx(0, "Button", "КНОПКА ", WS_CHILD Or WS_VISIBLE Or BS_RIGHT, 35, 25, 130, 48, hwnd, 0, App.hInstance, ByVal 0&
If hwnd <> 0 Then ShowWindow hwnd, SW_SHOWNORMAL CreateTestWindow = (hwnd <> 0) End Function Private Function WndProc(ByVal hwnd As Long, ByVal message As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Select Case message Case WM_DESTROY PostQuitMessage (0) End Select WndProc = DefWindowProc(hwnd, message, wParam, lParam) End Function Function GetWndProc(ByVal lWndProc As Long) As Long GetWndProc = lWndProc End Function Private Sub MessageLoopProc() im uMsg As Msg
o While GetMessage(uMsg, 0, 0, 0)
ispatchMessage uMsg
Loop End Sub Private Function ButtonProc(ByVal hwnd As Long, ByVal message As Long, ByVal wParam As Long, ByVal lParam As Long) As Long im x As Integer, hDC As Long ', Ps As PAINTSTRUCT
im R As RECT, ret As Long
Select Case message Case WM_PAINT ret = CallWindowProc(old_proc, hwnd, message, wParam, lParam) hDC = GetWindowDC(hwnd) rawIconEx hDC, 8, 8, hIcon, 0, 0, 0, 0, DI_NORMAL
ReleaseDC hwnd, hDC Exit Function End Select ButtonProc = CallWindowProc(old_proc, hwnd, message, wParam, lParam) End Function |
||
|
Номер ответа: 62 Автор ответа: Lister ICQ: 298621256 Вопросов: 57 Ответов: 304 |
Профиль | | #62 | Добавлено: 07.09.04 19:21 |
|
СУПЕР!!! Спасибо большое! |
||
|
Номер ответа: 63 Автор ответа: crestaВопросов: 117 Ответов: 1538 |
Профиль | | #63 | Добавлено: 07.09.04 20:12 |
|
Тут собственно одна только строка что-то делает:
rawIconEx hDC, 8, 8, hIcon, 0, 0, 0, 0, DI_NORMAL
перед ней строка ret = CallWindowProc(old_proc, hwnd, message, wParam, lParam) - заставляет саму винду заботиться о нарисовании собственно кнопки без картинки. Можно это всё сильно сократить, оставить только последнюю функцию, и из любого кода перенаправить обработку сообщений в неё, обработать wm_paint, и потом обратно отправить в old_proc. Чтобы перенаправить в эту процедуру, надо SetwindowLong c индексом GWL_WNDPROC. От неё получишь old_proc, а передашь ей адрес ButtonProc. Только не забудь, что без манифеста или с отключеным стилем ХР пример работать не будет. Чтобы работал, кроме wm_paint надо обрабатывать и другие сообщения. Т.е. сделать Case WM_PAINT, WM_..., WM_... |
||
|
Номер ответа: 64 Автор ответа: ListerICQ: 298621256 Вопросов: 57 Ответов: 304 |
Профиль | | #64 | Добавлено: 07.09.04 20:52 |
|
Ок! Понял, буду разбираться! |
||