В этой статье я описал или, можно сказать, перевел создание собственных диалоговых окон сообщений.
Все бы там хорошо, но не нравится мне эта синяя панель диалогового окна - ну прямо вопиюще контрастирует с тематической гаммой программой. Выглядит это все непрофессионально....распадается единое стилевое оформление, раздражает, какая-то незавершенность остается. В, общем, много про это можно говорить ;), но сейчас мы будем вырезать эту синюю полоску, оставляя окно модальным.
В модуль формы frmMsgBox необходимо добавить еще немного кода.
Добавляем в раздел объявления переменных модуля несколько деклараций API и констант:
' для перетаскивания формы мышкой за псевдозаголовок
Private 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 Declare Sub ReleaseCapture Lib "user32" ()
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2
' для управления состоянием окна
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal Hwnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
(ByVal Hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowPos Lib "user32" _
(ByVal Hwnd As Long, _
ByVal hWndInsertAfter As Long, _
ByVal X As Long, ByVal Y As Long, _
ByVal cx As Long, _
ByVal cy As Long, _
ByVal wFlags As Long) As Long
Private Declare Function SPIGetWorkArea Lib "user32" Alias "SystemParametersInfoA" _
(ByVal uAction As Long, _
ByVal uParam As Long, _
lpvParam As Rect, _
ByVal fuWinIni As Long) As Long
Private Const GWL_STYLE = (-16)
Private Const WS_OVERLAPPED = &H0&
Private Const WS_CAPTION = &HC00000
Private Const WS_SYSMENU = &H80000
Private Const WS_THICKFRAME = &H40000
Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_OVERLAPPEDWINDOW = (WS_OVERLAPPED Or _
WS_CAPTION Or _
WS_SYSMENU Or _
WS_THICKFRAME Or _
WS_MINIMIZEBOX Or _
WS_MAXIMIZEBOX)
Private Const WS_POPUP = &H80000000
Private Const SWP_FRAMECHANGED = &H20
Private Const SWP_NOZORDER = &H4
Private Const SWP_DRAWFRAME = SWP_FRAMECHANGED
Private Const SPI_GETWORKAREA = 48
Private Type Rect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Добавим саму процедуру удаления заголовка у формы подробности см. Скрытие строки заголовка приложения.
' удаление заголовка у формы, но все равно открытия формы как модальной
Private Function NoCaption()
Dim Hwnd As Long
Dim Style As Long
Dim rc As Rect
Hwnd = Me.Hwnd
Style = GetWindowLong(Hwnd, GWL_STYLE)
Style = Style And (Not WS_OVERLAPPEDWINDOW)
Style = Style Or WS_POPUP
SetWindowLong Hwnd, GWL_STYLE, Style
SPIGetWorkArea SPI_GETWORKAREA, 0, rc, 0
SetWindowPos Hwnd, 0, _
(rc.Right - 462) / 2, (rc.Bottom - 174) / 2, _
462, 174, _
SWP_NOZORDER Or SWP_DRAWFRAME
End Function
Диалоговое окошко MBox у меня имеет размеры 462 пикселя по ширине и 174 по высоте и появляется в середине экрана. Понятно, что Вы можете изменить эти размеры по своему усмотрению.
Также нарисуем надпись lblInfoTips по верхней границе формы также как описано в Создание "фальшивой" строки заголовка у формы . Установим ее шрифт жирным и белым. По умолчанию зададим надписи название приложения, в случае, если не будет передан параметр Title, будет отображаться эта строка. Для события "Перемещение указателя" надписи добавим следующий код:
Private Sub lblInfoTips_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim lngReturnValue As Long
If Button = 1 Then
Call ReleaseCapture
lngReturnValue = SendMessage(Me.Hwnd, WM_NCLBUTTONDOWN, _
HTCAPTION, 0&)
End If
End Sub
Если Вы уже используете код для перетаскивания других форм за псевдозаголовок, то, вероятнее всего Вы задекларировали необходимые API и константы к этой процедуре в отдельном модуле, как Public. Если так, то добавление их в раздел объявлений переменных модуля не является необходимым. Хотя.... ничего противозаконного нет, можно просто оставить их в модуле как Private, как описано выше.
Добавим еще несколько небольших дополнений в код:
If Not (StrComp(Me.OpenArgs & vbNullString, "MBox", vbBinaryCompare) = 0) Then
Cancel = True
Exit Sub
End If
' вызов процедуры обрезания заголовка
Call NoCaption
Добавим код изменения цвета заголовка:
Select Case MBoxIconStyle
Case vbCritical
Me.picCritical.Visible = True
Me.recBorder.BorderColor = RGB(230, 70, 30)
Me.lblFakeButton1.BackColor = RGB(230, 70, 30)
Me.lblFakeButton2.BackColor = RGB(230, 70, 30)
Me.lblInfoTips.BackColor = RGB(230, 70, 30)
Case vbExclamation
Me.picExclamation.Visible = True
Me.recBorder.BorderColor = RGB(230, 190, 20)
Me.lblFakeButton1.BackColor = RGB(230, 190, 20)
Me.lblFakeButton2.BackColor = RGB(230, 190, 20)
Me.lblInfoTips.BackColor = RGB(230, 190, 20)
Case vbInformation
Me.picInformation.Visible = True
Me.recBorder.BorderColor = RGB(150, 200, 50)
Me.lblFakeButton1.BackColor = RGB(150, 200, 50)
Me.lblFakeButton2.BackColor = RGB(150, 200, 50)
Me.lblInfoTips.BackColor = RGB(150, 200, 50)
End Select
и изменим строку присвоения заголовка:
If Len(MBoxTitle) > 0 Then Me.lblInfoTips.Caption = " " & MBoxTitle
Теперь можно любоваться бескомпромиссно доработанным MBox'ом.