Проблема со шрифтами в стандартных контролах!

[$Yastrebov$]

Как устранить следующую зависимость:
1. Создаем новый проэкт, добавляем форму и стандартный ToolBar (Comctl32.ocx) В нем нет возможности изменять размер и стиль шрифта.
2. Создаем кнопочки и подписываем их. До конца формы (чтобы правый край последней кнопки ToolBar сравнялся с правым краем вашей формы)
3. Запускаем проэкт - Все красиво???? - Да.
4. Оставляем проэкт, нажимаем правой клавишей на раб. столе, выбираем Свойства, вкладка Оформление, последний пункт меню Размер шрифта, устанавливаем Крупный.

О ужас, границы нашего ToolBar навсегда покинули границы форму, интерфейс испоганен.

Вопрос: Как задать свои шрифты станд. элементам или запретить их изменения при подобных изменениях в Windows? Лучше первый вариант))))

[GSerg]

Шо, опять?
http://bbs.vbstreets.ru/viewtopic.php?t=30223

[$Yastrebov$]

2 GSerg (благодарю за участие в обсуждении)
Данная ссылка и все в ней вложенные никаким образом не решают проблему данной зависимости ДЛЯ СТАНДАРТНЫХ КОНТРОЛОВ, у которых нет свойства FontSize и Font.Size, а лишь демонстрируют слабые попытке ее обойти.

Вот решение данной проблемы:
(Автор michael R с www.sql.ru)

Код ниже установит нужный Font(шрифт) для ToolBar у которого по умолчанию НЕТ ТАКОГО СВОЙСТВА (подозреваю, что и не только для него). Шрифт берется из обьекта Form

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



'****************************Code****************************

Option Explicit
Private Const GW_CHILD As Long = 5
Private Const WM_GETFONT As Long = &H31
Private Const WM_SETFONT As Long = &H30
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Declare Function GetWindow Lib "user32.dll" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private hFont As Long

Private Sub Form_Load()
Dim hwndTB As Long

        'Get the ~real~ hwnd of the toolbar. VB wraps the actual
        'toolbar in a separate container, so you need the child...
    hwndTB = GetWindow(Toolbar1.hwnd, GW_CHILD)

        'Get the handle of the form's font...
    hFont = SendMessage(Me.hwnd, WM_GETFONT, ByVal 0&, ByVal 0&)

        'Set the font...
    SendMessage hwndTB, WM_SETFONT, ByVal hFont, ByVal 1
End Sub

Private Sub Form_Unload(Cancel As Integer)
DeleteObject hFont
End Sub

'************************************************************


Хотя на многих форумах меня убеждали, что это невозможно
Вот так-то!

[GSerg]

ДЛЯ СТАНДАРТНЫХ КОНТРОЛОВ

Не надо орать. Кнопка - стандартный контрол.

а лишь демонстрируют слабые попытке ее обойти.

Из чего следует, что ты не только не понял, в чём суть проблемы, но и вообще плохо ориентируешься в ситуации.

Код ниже

Код ниже написан человеком, который не подозревает, что WM_GETFONT возвращает отнюдь не копию шрифта, и потому уничтожать его не следует, но это мелочи, а главное в том, что если после такого "установления" сменить шрифт на форме, то тулбар окажется с недействительным шрифтом (потому что его уничтожит форма), и будет рисовать всё с помощью fixedsys.

Простейшая демонстрация.

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

Option Explicit

Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Declare Function InvalidateRect Lib "user32.dll" (ByVal hwnd As Long, ByRef lpRect As Any, ByVal bErase As Long) As Long

Private Const WM_GETFONT As Long = &H31
Private Const WM_SETFONT As Long = &H30

Private WithEvents Command1 As CommandButton, WithEvents Command2 As CommandButton

Private Sub Command1_Click()
  Me.Font.Name = "Comic Sans MS"
  Me.Font.Size = 18
 
  SendMessage Command1.hwnd, WM_SETFONT, SendMessage(Me.hwnd, WM_GETFONT, 0, ByVal 0&), ByVal 1&
 
  Command2.Visible = True
End Sub

Private Sub Command2_Click()
  Me.Font.Name = "Arial"
 
  InvalidateRect Command1.hwnd, ByVal 0&, 1
 
  Command1.Caption = "Что, сдох шрифт?"
End Sub

Private Sub Form_Load()
  Me.ScaleMode = vbTwips
  Me.Move Me.Left, Me.Top, 6360, 4710
 
  Set Command1 = Me.Controls.Add("VB.CommandButton", "Command1")
  With Command1
    .Move 360, 360, 2775, 735
    .Caption = "Сначала нажми меня"
    .Visible = True
  End With
 
  Set Command2 = Me.Controls.Add("VB.CommandButton", "Command2")
  With Command2
    .Move 2520, 1800, 2775, 735
    .Caption = "А теперь нажми меня"
  End With
End Sub

[$Yastrebov$]

$Yastrebov$ писал(а):
ДЛЯ СТАНДАРТНЫХ КОНТРОЛОВ

Не надо орать. Кнопка - стандартный контрол.

ДЛЯ СТАНДАРТНЫХ КОНТРОЛОВ, у которых нет свойства FontSize и Font.Size Кнопка имеет возможность настройки Font (в отличии от ToolBar).

и потому уничтожать его не следует

Согласен, но тем не менее, человек подсказал идею реализации. Пусть и не совсем правильную, но с возможностью дальнейшей отладки! Разве не так? Ведь это нам и нужно программистам?!

а главное в том, что если после такого "установления" сменить шрифт на форме, то тулбар окажется с недействительным шрифтом (потому что его уничтожит форма), и будет рисовать всё с помощью fixedsys.

А кто собирается менять шрифт на форме? Уместное замечание, но все же. Если перезагрузить ПК, уже ничего не будет рисовать... (это ведь крайний случай, который к тому же ВОЗМОЖНО учесть при написании программы)