Как добавить дополнительную кнопку в заголовок

[grindars]

Сабж. Во вложении пример того как это выглядит (кусок скрина апигайда).

[Twister]

Отлов сообщений в заголовке окна и прорисовка элемента - ведь в заголовке нет кнопок, все рисунки. Вообщем, гугл тебе в помощь, да и здесь я раньше видел решение твоей задачи.

[grindars]

Взял сабклассер из кирпичного завода, и написал это:

Код: Выделить всё


Option Explicit
Implements ISubclass
Private Const WM_PAINT = &HF
Private Sub Form_Load()
AddSubclassHook Me.hWnd, Me, DoNotTransfer
End Sub

Private Sub Form_Unload(Cancel As Integer)
SubClasser.RemoveAll
End Sub

Private Function ISubclass_Callback(ByVal hWnd As Long, uMsg As Long, wParam As Long, lParam As Long, ByVal PrevProc As Long) As Long
If PrevProc Then ISubclass_Callback = SubClasser.CallWindowProc(PrevProc, hWnd, uMsg, wParam, lParam)
If uMsg = WM_PAINT Then
    Debug.Print CStr(wParam) + " " + CStr(lParam)
End If
End Function


В результате в окне неотложного переодически нули вылазют, и я не знаю как рисовать на заголовке

Добавлено позже
А заголовок - это часть моего окна или другое окно? даже bitblt не может вылезти на заголовок...

[tyomitch]

В результате в окне неотложного переодически нули вылазют, и я не знаю как рисовать на заголовке

Минздрав предупреждает: использовать пиратский переведённый VB опасно для вашего здоровья.

А заголовок - это часть моего окна или другое окно? даже bitblt не может вылезти на заголовок...

Часть твоего окна. Отрисовывать его положено в WM_NCPAINT.

[grindars]

так... вот что получилось (первая колонка - wParam, вторая lParam)
1 0
3256 0
второе вылезло после того как я оошко двинул.

вопрос: как все-таки рисовать и что означет wParam

[Viper]

Рисовать на заголовке можно используя контекст устройства полученного при помощи GetWindowDC. Такой контекст, в отличии от контекста полученного при помощи GetDC, включает в себя и заголовок, и меню и все остальное...

[grindars]

Код: Выделить всё


Option Explicit
Implements ISubclass
Private Const WM_NCPAINT = &H85
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function WindowFromDC Lib "user32" (ByVal hdc As Long) As Long
Dim MyDC As Long
Dim ButtonDC As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Sub RedrawButton()
    BitBlt MyDC, Me.ScaleWidth - 65, 6, 16, 14, ButtonDC, 0, 0, vbSrcCopy
End Sub
Private Sub Form_Load()
AddSubclassHook Me.hwnd, Me, DoNotTransfer
MyDC = GetWindowDC(Me.hwnd)
ButtonDC = GetWindowDC(Picture1.hwnd)
Me.Show
RedrawButton
End Sub

Private Sub Form_Unload(Cancel As Integer)
SubClasser.RemoveAll
End Sub

Private Function ISubclass_Callback(ByVal hwnd As Long, uMsg As Long, wParam As Long, lParam As Long, ByVal PrevProc As Long) As Long
If PrevProc Then ISubclass_Callback = SubClasser.CallWindowProc(PrevProc, hwnd, uMsg, wParam, lParam)
If uMsg = WM_NCPAINT Then
'    Debug.Print CStr(wParam) + " " + CStr(lParam)
    RedrawButton
End If
End Function


Но это очень криво... не смотря на то что при запуске стоит обновление кнопки, сначала та некоторое время - мусор... и я не знаю как сделать клик по кнопке... вот бы туда обычную кнопку засунуть...

в picturebox1 картинка с кнопкой, нагло выдранной из гайда.

Добавлено позже
Во вложении два скрина, с глюком и нормальный... причем часто после сворачивания- разворачивания или еще чего кнопка начинает показывать то что под ней..

[ВуД]

ВОТ ИСХОДНИК ДЕРЖИ

[grindars]

ВуД
клево, спасибо тебе огромное!

Только зачем так много раз?

[ВуД]

grindars, да всегда пожалуйста.

[Конь]

Шо за? Происходит по истечении двух-трех секунд после восстановления из трея.

[Kovu]

Конь
Не, это не после восстановления, это когда ты начинаешь таскать форму =). Слетает отрисовка стиля ХРшного.

[tyomitch]

У меня вопрос на смежную тему

Как в заголовке MDI-ребёнка нарисовать вместо кнопки "Развернуть" кнопку "Свернуть в окно"?
Если я просто устанавливаю этому окну стиль WS_MAXIMIZE, то у него вообще не рисуется ни заголовок, ни рамка -- т.к. у настоящих максимизированных MDI-детей ничего этого нет.

[Naked]

отрисовка стиля XP не слетает, работает только при XP-шном оформлении, если кто хочет дорабатывайте.

tyomitch рисуй поверх "развернуть"


приложение добавить не дают значит выложу тут

создаем новый проект
в модуль формы кидаем

Код: Выделить всё

Private Sub Form_Load()
    Call Hook(hwnd)
End Sub


в модуль

Код: Выделить всё

Option Explicit

Public Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Public Type POINTAPI
    x As Long
    y As Long
End Type

Public Const GWL_WNDPROC = (-4)

Public Const WM_DESTROY = &H2
Public Const WM_NCPAINT = &H85
Public Const WM_NCHITTEST = &H84
Public Const WM_NCLBUTTONDOWN = &HA1
Public Const WM_NCLBUTTONUP = &HA2
Public Const WM_NCMOUSEMOVE = &HA0
Public Const WM_ERASEBKGND = &H14
Public Const WM_KILLFOCUS = &H8
Public Const WM_SETFOCUS = &H7

Public Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Public Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long

Public 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
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Public Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Public Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long

Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Public Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long


Private Type SIZE
   cX As Long
   cY As Long
End Type

Private Declare Function OpenThemeData Lib "uxtheme.dll" (ByVal hwnd As Long, ByVal pszClassList As Long) As Long
Private Declare Function CloseThemeData Lib "uxtheme.dll" (ByVal hTheme As Long) As Long
Private Declare Function DrawThemeBackground Lib "uxtheme.dll" (ByVal hTheme As Long, ByVal lHDC As Long, ByVal iPartId As Long, ByVal iStateId As Long, pRect As RECT, pClipRect As RECT) As Long
Private Declare Function DrawThemeParentBackground Lib "uxtheme.dll" (ByVal hwnd As Long, ByVal hdc As Long, prc As RECT) As Long
Private Declare Function GetThemeBackgroundContentRect Lib "uxtheme.dll" (ByVal hTheme As Long, ByVal hdc As Long, ByVal iPartId As Long, ByVal iStateId As Long, pBoundingRect As RECT, pContentRect As RECT) As Long
'Private Declare Function DrawThemeText Lib "uxtheme.dll" (ByVal hTheme As Long, ByVal hdc As Long, ByVal iPartId As Long, ByVal iStateId As Long, ByVal pszText As Long, ByVal iCharCount As Long, ByVal dwTextFlag As Long, ByVal dwTextFlags2 As Long, pRect As RECT) As Long
'Private Declare Function DrawThemeIcon Lib "uxtheme.dll" (ByVal hTheme As Long, ByVal hdc As Long, ByVal iPartId As Long, ByVal iStateId As Long, pRect As RECT, ByVal hIml As Long, ByVal iImageIndex As Long) As Long
Public Enum THEMESIZE
    TS_MIN             '// minimum size
    TS_TRUE            '// size without stretching
    TS_DRAW            '// size that theme mgr will use to draw part
End Enum
Private Declare Function GetThemePartSize Lib "uxtheme.dll" (ByVal hTheme As Long, ByVal hdc As Long, ByVal iPartId As Long, ByVal iStateId As Long, prc As RECT, ByVal eSize As THEMESIZE, psz As SIZE) As Long
'Private Declare Function GetThemeTextExtent Lib "uxtheme.dll" (ByVal hTheme As Long, ByVal hdc As Long, ByVal iPartId As Long, ByVal iStateId As Long, ByVal pszText As Long, ByVal iCharCount As Long, ByVal dwTextFlags As DrawTextFlags, pBoundingRect As RECT, pExtentRect As RECT) As Long
'Private Declare Function DrawThemeEdge Lib "uxtheme.dll" (ByVal hTheme As Long, ByVal hdc As Long, ByVal iPartId As Long, ByVal iStateId As Long, pDestRect As RECT, ByVal uEdge As DrawEdgeEdgeTypes, ByVal uFlags As DrawEdgeBorderFlags, pContentRect As RECT) As Long

Dim PrevWndProc As Long
Dim hdc As Long


Dim m_sClass As String
Dim hTheme As Long
Dim tSize As SIZE, tR As RECT
Dim m_lPartId As Long
Dim StateID As Long
Dim rct As RECT

Dim xState As Long
Dim xLeft As Long, xRight As Long, xTop As Long, xBottom As Long
Dim hX As Long, hY As Long

Sub Hook(hwnd As Long)
    PrevWndProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WndProc)
    m_sClass = "window" 'button
   
    'minimize  = 15
    'maximize = 17
    'close = 18
    'restore = 21
    m_lPartId = 21
   
    StateID = 1
End Sub
Sub UnHook(hwnd As Long)
    Call SetWindowLong(hwnd, GWL_WNDPROC, PrevWndProc)
End Sub

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_NCLBUTTONDOWN
            hX = LoWord(lParam)
            hY = HiWord(lParam)
            Call GetWindowRect(hwnd, rct)
           
            If hX >= rct.Left + xLeft And hX <= rct.Left + xLeft + 21 And hY >= rct.Top + xTop And hY <= rct.Top + xTop + 21 Then
                StateID = 3
                SendMessage hwnd, WM_ERASEBKGND, 0, 0
            Else
                StateID = 1
                SendMessage hwnd, WM_ERASEBKGND, 0, 0
            End If
            WndProc = CallWindowProc(PrevWndProc, hwnd, message, wParam, lParam)
       
        Case WM_NCHITTEST
            hX = LoWord(lParam)
            hY = HiWord(lParam)
            Call GetWindowRect(hwnd, rct)
           
            If hX >= rct.Left + xLeft And hX <= rct.Left + xLeft + 21 And hY >= rct.Top + xTop And hY <= rct.Top + xTop + 21 Then
                StateID = 2
                SendMessage hwnd, WM_ERASEBKGND, 0, 0
            Else
                StateID = 1
                SendMessage hwnd, WM_ERASEBKGND, 0, 0
            End If
           
            WndProc = CallWindowProc(PrevWndProc, hwnd, message, wParam, lParam)
       
        Case WM_SETFOCUS
            StateID = 1
            SendMessage hwnd, WM_ERASEBKGND, 0, 0
            WndProc = CallWindowProc(PrevWndProc, hwnd, message, wParam, lParam)
       
        Case WM_KILLFOCUS
            StateID = 4
            SendMessage hwnd, WM_ERASEBKGND, 0, 0
            WndProc = CallWindowProc(PrevWndProc, hwnd, message, wParam, lParam)
       
        Case WM_NCPAINT, WM_ERASEBKGND
            hdc = GetWindowDC(hwnd)

            Draw hwnd, StateID

            Call ReleaseDC(hwnd, hdc)
            Call DeleteDC(hdc)
            WndProc = CallWindowProc(PrevWndProc, hwnd, message, wParam, lParam)
       
        Case WM_DESTROY
            Call UnHook(hwnd)
            WndProc = CallWindowProc(PrevWndProc, hwnd, message, wParam, lParam)
       
        Case Else
            WndProc = CallWindowProc(PrevWndProc, hwnd, message, wParam, lParam)
    End Select
End Function


Function LoWord(LongIn As Long) As Integer
     If (LongIn And &HFFFF&) > &H7FFF Then
          LoWord = (LongIn And &HFFFF&) - &H10000
     Else
          LoWord = LongIn And &HFFFF&
     End If
End Function
Function HiWord(LongIn As Long) As Integer
     HiWord = (LongIn And &HFFFF0000) \ &H10000
End Function

Private Sub Draw(hwnd As Long, hState As Long)
    Call GetWindowRect(hwnd, rct)
    xLeft = rct.Right - rct.Left - 96 '50 '96
    xTop = 6
   
    hTheme = OpenThemeData(hwnd, StrPtr(m_sClass))
    Call GetThemePartSize(hTheme, hdc, m_lPartId, hState, tR, TS_TRUE, tSize)
    tR.Left = xLeft
    tR.Top = xTop
    tR.Right = tR.Left + tSize.cX
    tR.Bottom = tR.Top + tSize.cY
    Call DrawThemeBackground(hTheme, hdc, m_lPartId, hState, tR, tR)
    Call CloseThemeData(hTheme)
End Sub