Приклади коду на Visual Basic. Робота з формою

Перетаскивание формы за любое место
Для данного примера вам понадобится дополнительный модуль.

КОД ФОРМЫ

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Object_MouseMove Me, X, Y, Button, 10
End Sub

КОД МОДУЛЯ



Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long 'Узнаем координаты курсора мыши
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" _
(ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinini As _
Long) As Long 'В данном случае узнаем размеры рабочего стола для прилипаний
Private Const SPI_GETWORKAREA = 48 'Константа для вышенаписанной функции
Private Type POINTAPI 'Координаты курсора
X As Long: Y As Long
End Type
Private Type RECT 'Размеры рабочей области экрана
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private IsMouseDwn As Boolean 'Служит для определения была ли нажата кнопка мыши
Dim NewCur As POINTAPI, FrmCur As POINTAPI, RC As RECT 'Работа с курсором и размером рабочей обл. экрана

Public Sub Object_MouseMove(frm As Form, ByVal X As Single, ByVal Y As Single, ByVal Button As Integer, Optional ByVal Docking As Long)
'**********************************
'Если надо => укажите свою кнопку *
'**********************************
If Not Button = vbLeftButton Then IsMouseDwn = False: Exit Sub

If Not IsMouseDwn Then 'Если кнопа не нажата => запоминаем координаты, узнаем область экрана
FrmCur.X = X / Screen.TwipsPerPixelX
FrmCur.Y = Y / Screen.TwipsPerPixelY
Call SystemParametersInfo(SPI_GETWORKAREA, vbNull, RC, 0)
IsMouseDwn = True 'Запоминаем, что кнопка нажата
End If
If IsMouseDwn Then 'Если кнопка нажата, работаем...
Dim TempCur As POINTAPI
GetCursorPos NewCur 'Новые координаты

TempCur.X = (NewCur.X - FrmCur.X) 'Координаты верхнего, левого угла окна
TempCur.Y = (NewCur.Y - FrmCur.Y)

If Abs(TempCur.X) - RC.Left < Docking Then 'Abs() - на и за экраном работаем... frm.Left = RC.Left * Screen.TwipsPerPixelX 'Если у края - прилипаем к левому краю ElseIf Abs(TempCur.X + frm.Width / Screen.TwipsPerPixelX - RC.Right) <= Docking Then frm.Left = RC.Right * Screen.TwipsPerPixelX - frm.Width 'Иначе смотрим на другой край и то же прилипаем Else frm.Left = TempCur.X * Screen.TwipsPerPixelX 'А еще иначе - двигаемся вслед за курсором End If If Abs(TempCur.Y) - RC.Top < Docking Then 'Аналогично... frm.Top = RC.Top ElseIf Abs(TempCur.Y + frm.Height / Screen.TwipsPerPixelY - RC.Bottom) <= Docking Then frm.Top = RC.Bottom * Screen.TwipsPerPixelY - frm.Height Else frm.Top = TempCur.Y * Screen.TwipsPerPixelY
End If
End If
End Sub

Размножить на форме картинку
Данный пример размножает картинку на форме с целью создания фона формы.

Для данного примера нам потребуется поставить на форму объект Image, привязать к нему рисунок, который хотим размножить на всю форму.

Private Sub Form_Paint()
Dim X As Integer, Y As Integer
Dim ImgWidth As Integer
Dim ImgHeight As Integer
Dim FrmWidth As Integer
Dim FrmHeight As Integer

'использование Image1 в PaintPicture methods:
ImgWidth = Image1.Width
ImgHeight = Image1.Height
FrmWidth = Form1.Width
FrmHeight = Form1.Height

'залить целую форму (Метод 1)
For X = 0 To FrmWidth Step ImgWidth
For Y = 0 To FrmHeight Step ImgHeight
PaintPicture Image1, X, Y
Next Y
Next X

'залить левый край (Метод 2)
'For Y = 0 To FrmHeight Step ImgHeight
'PaintPicture Image1, 0, Y
'Next Y

End Sub

'Для того чтобы залить только левый край снимите комментарий с метода2 и поставьте на метод1.

Форма, реагирующая на события (min,max,close)
Данный пример покажет, как можно запрограммировать действия на попытку свернуть или развернуть форму, нажатия на панель заголовка, или выбора системного меню. Добавьте дополнительный модуль в ваш проект.

'КОД ФОРМЫ

Private Sub Form_Load()
SetProc hWnd
End Sub

'КОД МОДУЛЯ

Option Explicit
Private Declare Function CallWindowProcA Lib "user32" (ByVal lpPrevWndFunc As Long, ByVal lngHandle As Long, ByVal lngMsg As Long, ByVal lngFirstParam As Long, ByVal lngLastParam As Long) As Long
Private Declare Function SetWindowLongA Lib "user32" (ByVal lngHandle As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private lngOldProc As Long
Public Sub SetProc(ByVal lngHandle As Long)
lngOldProc = SetWindowLongA(lngHandle, -4, AddressOf WinProc)
End Sub
Private Function WinProc(ByVal lngHandle As Long, ByVal lngMsg As Long, ByVal lngFirstParam As Long, ByVal lngLastParam As Long) As Long
If lngMsg = &HA1 Then
Select Case lngFirstParam
Case 2
Form1.Caption = "Кто-то нажал на заголовке"
Case 3
Form1.Caption = "Кому-то нужно системное меню формы"
Case 8
Form1.Caption = "Зачем сворачивать форму?!"
Case 9
Form1.Caption = "Кто-то хочет развернуть форму!"
Case 20
Form1.Caption = "Зачем закрывать форму?!"
End Select
End If
WinProc = CallWindowProcA(lngOldProc, lngHandle, lngMsg, lngFirstParam, lngLastParam)
'Автор примера Беляев Данила
End Function
Создание формы произвольных размеров
Создайте новый проект, разместите на форме элемент Label (чтобы выйти из программы).
Обязательно установите в свойствах формы Caption = "" и ControlBox = False.

Private Declare Function ReleaseCapture Lib "user32" () As Long
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 Function CreatePolygonRgn Lib "gdi32" (lpPoint As POINTAPI, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long

Const WM_NCLBUTTONDOWN = &HA1
Const HTCAPTION = 2

Private Type POINTAPI
X As Long
Y As Long
End Type

Sub CutForm()
Dim P(428) As POINTAPI
Dim px
Dim py
Dim i As Integer
Dim Rgn As Long
px = Array(340, 339, 334, 333, 329, 328, 325, 324, 321, 320, 318, 317, 316, 315, 313, _
312, 311, 310, 309, 308, 307, 306, 305, 304, 303, 301, 300, 298, 297, 294, 293, 281, 281, 278, 278, 277, 277, 275, 275, 274, 274, 273, 273, 272, 272, _
271, 271, 270, 270, 269, 268, 267, 265, 264, 263, 262, 260, 259, 258, 257, 256, 255, 254, 252, 251, 249, 248, 245, 195, 194, 188, 187, 187, 186, 186, _
185, 184, 182, 181, 180, 179, 178, 176, 175, 173, 172, 169, 168, 165, 164, 159, 158, 153, 152, 146, 145, 136, 135, 121, 120, 80, 79, 65, 64, 55, _
54, 48, 47, 42, 41, 36, 35, 32, 31, 28, 27, 25, 24, 22, 21, 20, 19, 18, 16, 15, 14, 14, 13, 13, 14, 14, 15, 16, 17, 18, _
19, 20, 21, 22, 24, 25, 27, 28, 31, 32, 35, 36, 41, 42, 47, 48, 54, 55, 64, 65, 67, 67, 64, 63, 61, 60, 57, 56, 54, 53, _
51, 50, 48, 47, 46, 45, 43, 42, 40, 39, 38, 37, 36, 35, 34, 33, 32, 31, 30, 29, 28, 27, 26, 24, 23, 21, 20, 13, 13, 11, _
11, 10, 10, 11, 11, 12, 13, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, _
36, 37, 38, 39, 40, 42, 43, 45, 46, 47, 48, 50, 51, 53, 54, 56, 57, 60, 61, 63, 64, 67, 68, 71, 72, 75, 76, 80, 81, 84, _
85, 89, 90, 95, 96, 100, 101, 106, 107, 113, 114, 120, 121, 128, 129, 136, 137, 146, 147, 158, 159, 172, 173, 194, 195, 254, 255, 276, 277, 290, _
291, 302, 303, 312, 313, 320, 321, 328, 329, 335, 336, 342, 343, 348, 349, 353, 354, 359, 360, 364, 365, 368, 369, 373, 374, 377, 378, 381, 382, 385, _
386, 388, 389, 392, 393, 395, 396, 398, 399, 401, 402, 403, 404, 406, 407, 409, 410, 411, 412, 413, 414, 415, 416, 417, 418, 419, 420, 421, 422, 423, _
425, 426, 428, 429, 436, 436, 438, 438, 439, 439, 438, 438, 436, 436, 435, 435, 434, 434, 433, 433, 431, 431, 431, 431, 432, 432, 433, 433, 432, 432, _
431, 431, 430, 430, 429, 429, 428, 428, 427, 427, 426, 426, 425, 425, 423, 423, 422, 422, 419, 419, 407, 406, 403, 402, 400, 399, 397, 396, 395, 394, _
393, 392, 391, 390, 389, 388, 387, 385, 384, 383, 382, 380, 379, 376, 375, 372, 371, 367, 366, 360, 359, 341, 340, 339)

py = Array(182, 181, 181, 180, 180, 179, 179, 178, 178, 177, 177, 176, 176, 175, 175, _
174, 174, 173, 173, 172, 172, 171, 171, 170, 170, 168, 168, 166, 166, 163, 163, 151, 150, 147, 146, 145, 144, 142, 141, 140, 139, 138, 137, 136, 135, _
134, 132, 131, 129, 128, 128, 127, 127, 126, 126, 125, 125, 124, 124, 123, 123, 122, 122, 120, 120, 118, 118, 115, 115, 114, 114, 115, 118, 119, 120, _
121, 121, 123, 123, 124, 124, 125, 125, 126, 126, 127, 127, 128, 128, 129, 129, 130, 130, 131, 131, 132, 132, 133, 133, 134, 134, 133, 133, 132, 132, _
131, 131, 130, 130, 129, 129, 128, 128, 127, 127, 126, 126, 125, 125, 124, 124, 123, 123, 121, 121, 120, 119, 118, 115, 114, 113, 112, 112, 111, 110, _
110, 109, 109, 108, 108, 107, 107, 106, 106, 105, 105, 104, 104, 103, 103, 102, 102, 101, 101, 100, 100, 98, 98, 97, 97, 96, 96, 95, 95, 94, _
94, 93, 93, 92, 92, 91, 91, 90, 90, 89, 89, 88, 88, 87, 87, 86, 86, 85, 85, 84, 84, 83, 83, 81, 81, 79, 79, 72, 71, 69, _
67, 66, 60, 59, 57, 56, 55, 54, 53, 52, 51, 50, 49, 48, 47, 47, 46, 45, 45, 44, 43, 43, 42, 42, 41, 41, 40, 40, 39, 39, _
38, 38, 37, 37, 36, 36, 35, 35, 34, 34, 33, 33, 32, 32, 31, 31, 30, 30, 29, 29, 28, 28, 27, 27, 26, 26, 25, 25, 24, 24, _
23, 23, 22, 22, 21, 21, 20, 20, 19, 19, 18, 18, 17, 17, 16, 16, 15, 15, 14, 14, 13, 13, 12, 12, 11, 11, 12, 12, 13, 13, _
14, 14, 15, 15, 16, 16, 17, 17, 18, 18, 19, 19, 20, 20, 21, 21, 22, 22, 23, 23, 24, 24, 25, 25, 26, 26, 27, 27, 28, 28, _
29, 29, 30, 30, 31, 31, 32, 32, 33, 33, 34, 34, 35, 35, 36, 36, 37, 37, 38, 38, 39, 39, 40, 40, 41, 41, 42, 42, 43, 43, _
45, 45, 47, 47, 54, 55, 57, 59, 60, 66, 67, 69, 71, 72, 73, 82, 83, 85, 86, 88, 90, 91, 93, 96, 97, 102, 103, 118, 119, 124, _
125, 128, 129, 131, 132, 134, 135, 136, 137, 138, 139, 140, 141, 142, 144, 145, 146, 147, 150, 151, 163, 163, 166, 166, 168, 168, 170, 170, 171, 171, _
172, 172, 173, 173, 174, 174, 175, 175, 176, 176, 177, 177, 178, 178, 179, 179, 180, 180, 181, 181, 182, 182, 181, 181)

For i = 0 To UBound(px)
P(i).X = px(i)
P(i).Y = py(i)
Next
Rgn = CreatePolygonRgn(P(0), 428, 0)
SetWindowRgn Form1.hwnd, Rgn, True
DeleteObject Rgn
End Sub

Private Sub Form_Load()
CutForm
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ReleaseCapture
Call SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
End Sub

Private Sub Label1_Click()
End
'Автор: Никифоров Максим
End Sub


Размещение окна у основания Панели задач
По умолчанию, Windows отображает панель задач в нижней части экрана. Вы можете переместить её к любому краю экрана, изменяя тем самым размеры доступной области экрана. С панелью задач, всегда видимой на экране, информация иногда заслоняется - особенно, если пользователь развертывает окно приложения. Вы можете использовать функцию SystemParametersInfo в приложении, чтобы определить доступную область экрана. Чтобы увидеть, как это работает, создайте новый проект. На форму добавьте контрол Command Button
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinini As Long) As Long
Const SPI_GETWORKAREA = 48

Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Private Sub Command1_Click()
Dim RC As RECT
Dim X As Long
X = SystemParametersInfo(SPI_GETWORKAREA, vbNull, RC, 0)
Me.Move RC.Left * Screen.TwipsPerPixelX, RC.Top * Screen.TwipsPerPixelY, RC.Right * Screen.TwipsPerPixelX, RC.Bottom * Screen.TwipsPerPixelY
End Sub


Различный вид формы
Данный пример добавляет почти по границе формы небольшую кайму, определяющую внешний вид формы.

Такой вид, как если бы на форме присутствовал элемент Frame, CommandButton или нажатый CommandButton.

Private Const BDR_SUNKENOUTER = &H2
Private Const BDR_RAISEDINNER = &H4
Private Const BF_BOTTOM = &H8
Private Const BF_LEFT = &H1
Private Const BF_RIGHT = &H4
Private Const BF_TOP = &H2
Private Const EDGE_ETCHED = (BDR_SUNKENOUTER Or BDR_RAISEDINNER)
Private Const BF_RECT = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)

Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Private Declare Function DrawEdge Lib "user32" (ByVal hdc As Long, qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Long
Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long

Private Sub Form_Paint()
Dim TRect As RECT
Me.ScaleMode = vbPixels
SetRect TRect, 10, 10, Me.ScaleWidth - 10, Me.ScaleHeight - 10
'вы можете использовать одну из трех строчек ниже
'DrawEdge Me.hdc, TRect, EDGE_ETCHED, BF_RECT
DrawEdge Me.hdc, TRect, BDR_SUNKENOUTER, BF_RECT
'DrawEdge Me.hdc, TRect, BDR_RAISEDINNER, BF_RECT
End Sub


Прилипание формы к границам экрана
Данный пример покажет, как ваша форма автоматически "прилипает" к границам экрана

Создайте стандартный проект. В свойствах формы укажите:

BorderStyle = 0 - None
ScaleMode = 3 - Pixel

Private Declare Function GetCursorPos Lib "user32" (lpPoint As PointAPI) As Long
Private Type PointAPI
X As Long
Y As Long
End Type
Dim Pos As PointAPI
Dim A As Boolean
Dim B As Boolean
Dim C As Boolean
Dim D As Boolean
Dim SX As Integer
Dim SY As Integer
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
SX = X
SY = Y
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
GetCursorPos Pos
If Not Button = vbLeftButton Then Exit Sub
If Pos.X - SX >= 10 Then A = False
If Pos.X - SX <= 10 Then Left = 0: A = True If Pos.Y - SY >= 10 Then B = False
If Pos.Y - SY <= 10 Then Top = 0: B = True If Pos.X - SX <= Screen.Width / Screen.TwipsPerPixelX - Width / Screen.TwipsPerPixelX - 10 Then C = False If Pos.X - SX >= Screen.Width / Screen.TwipsPerPixelX - Width / Screen.TwipsPerPixelX - 10 Then Left = Screen.Width - Width: C = True
If Pos.Y - SY + Height / Screen.TwipsPerPixelY > Screen.Height / Screen.TwipsPerPixelX - 10 Then Top = Screen.Height - Height: D = True
If Pos.Y - SY + Height / Screen.TwipsPerPixelY <= Screen.Height / Screen.TwipsPerPixelX - 10 Then D = False If B = True Then GoTo Cya If D = True Then GoTo Cya Top = Pos.Y * Screen.TwipsPerPixelY - SY * Screen.TwipsPerPixelY Cya: If A = True Then Exit Sub If C = True Then Exit Sub Left = Pos.X * Screen.TwipsPerPixelX - SX * Screen.TwipsPerPixelX
End Sub '
Автор этого примера Беляев Данила outen@mail.ru


Использование InputBox для ввода секретной информации 
Хотите использовать стандартный InputBox для ввода информации, скрытой звездочками? Нет проблем, сказал один из программистов, и создал для вас этот пример. В этом примере вам понадобится дополнительный модуль
Хотите использовать стандартный InputBox для ввода информации, скрытой звездочками? Нет проблем, сказал один из программистов, и создал для вас этот пример. В этом примере вам понадобится дополнительный модуль

'КОД ФОРМЫ

Private Sub Command1_Click()
Dim ret As String
ret = InputBoxEx("Наберите пароль:", "Программа...")
Label1 = ret
End Sub

'КОД МОДУЛЯ

Option Explicit
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
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 Const WH_CBT = 5
Private Const HCBT_ACTIVATE = 5
Private m_lMsgHandle As Long
Private m_lhHook As Long
Private Const ES_CENTER = &H1&

Private Function GetMessageBoxHandle(ByVal lMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If lMsg = HCBT_ACTIVATE Then
m_lMsgHandle = wParam
UnhookWindowsHookEx m_lhHook
m_lhHook = 0
End If
GetMessageBoxHandle = False
End Function

Private Sub InputBoxTimerUpdateEvent(hWnd As Long, uiMsg As Long, idEvent As Long, dwTime As Long)
Dim res As Long
If m_lMsgHandle = 0 Then Exit Sub
res = FindWindowEx(m_lMsgHandle, 0, "Edit", "")
SendMessage res, 1052, 42, ByVal 0&
SendMessage res, &H441, ES_CENTER, ByVal 0&
End Sub

Public Function InputBoxEx(sMsgText As String, Optional sTitle As String = "Secured InputBox") As String
Dim lTimerUpdate As Long
m_lhHook = SetWindowsHookEx(WH_CBT, AddressOf GetMessageBoxHandle, App.hInstance, GetCurrentThreadId())
lTimerUpdate = SetTimer(0, 0, 0, AddressOf InputBoxTimerUpdateEvent)
InputBoxEx = InputBox(sMsgText, sTitle)
KillTimer 0, lTimerUpdate
End Function

Эффекты при закрытии формы

Функция AnimateWindow дает возможность Вам произвести специальные эффекты при появление или скрытии окон. Имеются три типа анимации: развёртывание, соскальзывание и постепенное появление.

Private Declare Function AnimateWindow Lib "user32" (ByVal hwnd As Long, ByVal dwTime As Long, ByVal dwFlags As Long) As Boolean
Const AW_HOR_POSITIVE = &H1 'Анимация окна слева направо.
'Этот флаг используется совместно с эффектами развёртывания и соскальзывания.
Const AW_HOR_NEGATIVE = &H2 'Анимация окна справа налево.
'Этот флаг используется совместно с эффектами развёртывания и соскальзывания.
Const AW_VER_POSITIVE = &H4 'Анимация окна сверху вниз.
'Этот флаг используется совместно с эффектами развёртывания и соскальзывания.
Const AW_VER_NEGATIVE = &H8 'Анимация окна снизу вверх.
'Этот флаг используется совместно с эффектами развёртывания и соскальзывания.
Const AW_CENTER = &H10 'Окно сворачивается внутрь себя если
'установлен флаг AW_HIDE, иначе разворачивается
Const AW_HIDE = &H10000 'Скрывает окно, по умолчанию окно появляется.
Const AW_ACTIVATE = &H20000 'Активизирует окно.
Const AW_SLIDE = &H40000 'Устанавливает эффект соскальзывания.
'По умолчанию эффект развёртывания.
Const AW_BLEND = &H80000 'Эффект постепенного появления.
'Применяется только к окнам верхнего уровня.

Private Sub Form_Load()
Me.AutoRedraw = True
Me.Print "Закрой меня"
End Sub
Private Sub Form_Unload(Cancel As Integer)
'Анимация окна
AnimateWindow Me.hwnd, 200, AW_VER_POSITIVE Or AW_HOR_NEGATIVE Or AW_HIDE
'Выгружаем форму полностью
Set Form1 = Nothing
End Sub

Затемнение кнопки 'закрыть' и одновременное удаление системного меню

Пользуйтесь данным примером очень аккуратно! При двойном нажатии кнопки программа "выполняет недопустимую операцию"

Расположите на форме элемент CommandButton.

Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
'процедура определения системного меню (кнопки закрытия)
Private Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
'процедура удаления меню

Sub Disable_SysMenu(handle As Long)
On Error GoTo errhan
Dim menu_handle As Long 'переменная с хэндлом меню
menu_handle = GetSystemMenu(handle, 0)
DestroyMenu (menu_handle)
Exit Sub
errhan:
End Sub

Private Sub Command1_Click()
Disable_SysMenu (Form1.hwnd)
End Sub

Прорисовка системных иконок на форме

Все вы знаете про функцию MsgBox. При использовании этой функции вы также можете вывести одну из четырех иконок, которые заставляют пользователя обратить внимание. Данный пример как раз и позволяет вытащить системные иконки и расположить их на вашей форме.

Public Enum enStockIcons
IDI_APPLICATION = 32512&
IDI_CRITICAL = 32513&
IDI_QUESTION = 32514&
IDI_EXCLAMATION = 32515&
IDI_INFORMATION = 32516&
IDI_WINLOGO = 32517&
IDI_UNKNOWN = 32518&
End Enum
Private Declare Function LoadIconApi Lib "user32" Alias "LoadIconA" (ByVal hInstance As Long, ByVal lpIconName As Long) As Long
Private Declare Function DrawIconApi Lib "user32" Alias "DrawIcon" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal hIcon As Long) As Long
Private Sub Form_Paint()
Dim hIcon As Long
'здесь вы можете определить, какую иконку загрузить
hIcon = LoadSystemIcon(IDI_QUESTION)
If hIcon > 0 Then
'заменяя цифры 10,10 вы определяете месторасположение иконки на форме
Call DrawIcon(Me.hdc, 10, 10, hIcon)
End If
End Sub
Public Function LoadSystemIcon(ByVal StockIcon As enStockIcons) As Long
Dim lRet As Long
lRet = LoadIconApi(0, StockIcon)
If Err.LastDllError = 0 Then
LoadSystemIcon = lRet
End If
End Function
Public Sub DrawIcon(ByVal mHdc As Long, ByVal xPos As Long, ByVal yPos As Long, ByVal hIcon As Long)
Dim lRet As Long
lRet = DrawIconApi(mHdc, xPos, yPos, hIcon)
If (Err.LastDllError > 0) Or (lRet = 0) Then
Debug.Print "DrawIcon failed"
End If
End Sub

Как заблокировать действия кнопок управления формой
Данный пример покажет, как можно заблокировать события кнопок MinButton, MaxButton и CloseButton. Добавьте на форму 2 элемента CommandButton. Изменяя цифру в событии Command1_Click() можно запретить получать форме отклик от кнопок минимизации (цифра 3), максимизации (цифра 4) и закрытия формы (цифра 6). Вторая командная кнопка добавлена для корректного закрытия вашей программы в случае запуска данного примера с параметром 6.

Private Declare Function GetSystemMenu Lib "user32" (ByVal hWnd As Long, ByVal bRevert As Long) As Long
Private Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private Const MF_BYPOS = &H400&
Public Sub KillingMenu(hWnd As Long, what As Integer)
Dim hSysMenu As Long
hSysMenu = GetSystemMenu(hWnd, 0)
Call RemoveMenu(hSysMenu, what, MF_BYPOS)
End Sub
Private Sub Command1_Click()
'замените цифру 6(блокировка CloseButton) на 3(блокировка MinButton) или 4(блокировка MaxButton)
KillingMenu Me.hWnd, 6
End Sub
Private Sub Command2_Click()
End
End Sub
Как перетаскивать форму за любое место
Как перетаскивать форму за любое место
Данный пример покажет вам, как можно перетаскивать форму за любое ее место. Достаточно вставить указанный ниже код, и...

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 Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)
Dim ReturnValue As Long
If Button = 1 Then
Call ReleaseCapture
ReturnValue = SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
End If
End Sub

Создание всплывающей панели
У каждого юзера, работающего в операционной системе Windows'98 есть панель задач (это панелька, на которой находится кнопка ПУСК). Некоторые любят в настройках этой панели установить значение "Автоматически убирать с экрана", и тогда панель будет автоматически убираться, когда она не активна. Так вот этот пример покажет, как можно средствами VB создать такую всплывающую справа панельку, подобную панели задач.

Создайте новый проект. Положите на форму компонент Timer. В свойствах формы укажите:
.AutoRedraw = True
.BorderStyle = 0
.MinButton = False
.MaxButton = False
.ShowInTaskbar = False
Вставьте следующий код:

Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type Formsize
Left As Long
Top As Long
Width As Long
Height As Long
End Type

Private Const MaxSize = 50
Private Const MinSize = 1
Private Const Fade = False ' Установите данное значение либо True либо False

Private Sub Command1_Click()
Unload Me
End Sub
Private Sub Form_Load()
Timer1.Interval = 50
Form_Resize
End Sub
Private Sub Form_Resize()
Me.Move Screen.Width - (MinSize * Screen.TwipsPerPixelX), 0, (MaxSize * Screen.TwipsPerPixelX), Screen.Height
Me.Cls
Me.Line (0, 0)-(0, Me.Height), &HFFFFFF
End Sub
Private Sub Timer1_Timer()
Dim a As POINTAPI
Dim Form As Formsize
Dim CurCut As Long

Form.Width = Me.Width / Screen.TwipsPerPixelX
Form.Left = Me.Left / Screen.TwipsPerPixelX
Form.Height = Me.Height / Screen.TwipsPerPixelY
Form.Top = Me.Top / Screen.TwipsPerPixelY
Call GetCursorPos(a)
If a.x >= Form.Left And a.x < Form.Left + Form.Width And a.y >= Form.Top And a.y < Form.Height + Form.Top Then If Me.Tag <> "0" Then
If Fade = True Then
CurCut = 1
Do Until Me.Left - (CurCut * Screen.TwipsPerPixelX) <= Screen.Width - (MaxSize * Screen.TwipsPerPixelX) Me.Left = Me.Left - (CurCut * Screen.TwipsPerPixelX) DoEvents Loop Me.Move Screen.Width - (MaxSize * Screen.TwipsPerPixelX), 0, (MaxSize * Screen.TwipsPerPixelX), Screen.Height Else Me.Move Screen.Width - (MaxSize * Screen.TwipsPerPixelX), 0, (MaxSize * Screen.TwipsPerPixelX), Screen.Height End If Me.Tag = "0" End If Else If Me.Tag <> "1" Then
If Fade = True Then
CurCut = 1
Do Until Me.Left + (CurCut * Screen.TwipsPerPixelX) >= Screen.Width - (MinSize * Screen.TwipsPerPixelX)
Me.Left = Me.Left + (CurCut * Screen.TwipsPerPixelX)
DoEvents
Loop
Me.Left = Screen.Width - (MinSize * Screen.TwipsPerPixelX)
Else
Me.Left = Screen.Width - (MinSize * Screen.TwipsPerPixelX)
End If
Me.Tag = "1"
End If
End If
End Sub

Создать градиент-форму
Этот пример создает Form/Picture Box с фоном, например как в инсталяционной программе
Установите свойство формы AutoRedraw в True.

Sub Gradient(TheObject As Object, ByVal Redval As Long, ByVal Greenval As _
Long, ByVal Blueval As Long, ByVal Direction As Integer)
Dim Step As Integer, Reps As Integer, FillTop As Integer
Dim FillLeft As Integer, FillRight As Integer, FillBottom As Integer
If Direction < 1 Or Direction > 4 Then Direction = 1
FillTop = 0
FillLeft = 0
If Direction < 3 Then
Step = (TheObject.Height / 100)
If Direction = 2 Then FillTop = TheObject.Height - Step
FillBottom = FillTop + Step
FillRight = TheObject.Width
Else
Step = (TheObject.Width / 100)
If Direction = 4 Then FillLeft = TheObject.Width - Step
FillRight = FillLeft + Step
FillBottom = TheObject.Height
End If
For Reps = 1 To 100
If Direction = 2 And Reps = 100 Then FillTop = 0
If Direction = 4 And Reps = 100 Then FillLeft = 0
Redval = Redval - 3
Greenval = Greenval - 3
Blueval = Blueval - 3
If Redval <= 0 Then Redval = 0
If Greenval <= 0 Then Greenval = 0
If Blueval <= 0 Then Blueval = 0
TheObject.Line (FillLeft, FillTop)-(FillRight, FillBottom), RGB(Redval, _
Greenval, Blueval), BF
If Direction < 3 Then
If Direction = 1 Then
FillTop = FillBottom
Else
FillTop = FillTop - Step
End If
FillBottom = FillTop + Step
Else
If Direction = 3 Then
FillLeft = FillRight
Else
FillLeft = FillLeft - Step
End If
FillRight = FillLeft + Step
End If
Next Reps
End Sub
Private Sub Form_Load()
'Поэкспериментируйте над цифрами 200, 100, 300
'Замените "1" на 2, 3 или 4
Gradient Me, 200, 100, 300, 1
'Gradient Picture1, 200, 100, 300, 1
End Sub

Private Sub Form_Resize()
'Положите здесь те же номера, что и выше
Gradient Me, 200, 100, 300, 1
'Gradient Picture1, 200, 100, 300, 1
End Sub


Создать Gradient-форму (с использованием API)
Добавьте 2 CommandButton

Private Type TRIVERTEX
x As Long
y As Long
Red As Integer
Green As Integer
Blue As Integer
Alpha As Integer
End Type
Private Type GRADIENT_RECT
UpperLeft As Long
LowerRight As Long
End Type
Const GRADIENT_FILL_RECT_H As Long = &H0
Const GRADIENT_FILL_RECT_V As Long = &H1
Private Declare Function GradientFillRect Lib "msimg32" Alias "GradientFill" (ByVal hdc As Long, pVertex As TRIVERTEX, ByVal dwNumVertex As Long, pMesh As GRADIENT_RECT, ByVal dwNumMesh As Long, ByVal dwMode As Long) As Long
Private Sub Form_Load()
Me.ScaleMode = vbPixels
End Sub
Private Function LongToUShort(ULong As Long) As Integer
LongToUShort = CInt(ULong - &H10000)
End Function
Private Function UShortToLong(Ushort As Integer) As Long
UShortToLong = (CLng(Ushort) And &HFFFF&)
End Function
Private Sub Command2_Click()
Cls
End Sub
Private Sub Command1_Click()
Dim vert(1) As TRIVERTEX
Dim gRect As GRADIENT_RECT
With vert(0)
.x = 0
.y = 0
.Red = 0&
.Green = &HFF&
.Blue = 0&
.Alpha = 0&
End With
With vert(1)
.x = Me.ScaleWidth
.y = Me.ScaleHeight
.Red = 0&
.Green = LongToUShort(&HFF00&)
.Blue = LongToUShort(&HFF00&)
.Alpha = 0&
End With
gRect.UpperLeft = 1
gRect.LowerRight = 0
'Замените GRADIENT_FILL_RECT_H на GRADIENT_FILL_RECT_V чтобы рисовать вертикальную прорисовку
GradientFillRect Me.hdc, vert(0), 2, gRect, 1, GRADIENT_FILL_RECT_H
End Sub

Ограничить перемещение одной формы в пределах другой
'Начните новый проект, добавьте в события формы1 (Form1) следующий код

Private Sub Form_Load()
Load Form2
Form2.Show
End Sub

'добавьте еще одну форму (под именем Form2).
 Вставьте на форму2 следующий код:

Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Private Sub Form_Load()
r = SetParent(Me.hWnd, Form1.hWnd)
End Sub

'Запустите проект на выполнение. Данный код ограничит передвижение второй формы относительно первой формы.


Выравнивание формы относительно экрана
Добавьте 3 CommandButton на форму. Вставьте следующий код

Private Sub Form_Load()
Form1.Top = Screen.Height / 2 - Form1.Height / 2
End Sub
Private Sub Command1_Click()
Form1.Left = 0
End Sub
Private Sub Command2_Click()
Form1.Left = Screen.Width / 2 - Form1.Width / 2
End Sub
Private Sub Command3_Click()
Form1.Left = Screen.Width - Form1.Width
End Sub


Определить, загружена ли форма
Добавьте 2 CommandButton и другую форму (Form 2)

Function FormLoadedByName(FormName As String) As Boolean
Dim i As Integer, fnamelc As String
fnamelc = LCase$(FormName)
FormLoadedByName = False
For i = 0 To Forms.Count - 1
If LCase$(Forms(i).Name) = fnamelc Then
FormLoadedByName = True
Exit Function
End If
Next
End Function
Private Sub Command1_Click()
'Замените 'Form2' именем формы, про которую хотите знать...
If FormLoadedByName("Form2") = True Then
MsgBox "Форма загружена"
Else
MsgBox "Форма не загружена"
End If
End Sub
Private Sub Command2_Click()
Load Form2
End Sub


Спрятать/показать панель заголовка
Добавьте 2 CommandButton на форму

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 Const GWL_STYLE = (-16)
Private Const WS_CAPTION = &HC00000
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_SYSMENU = &H80000
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 Enum ESetWindowPosStyles
SWP_SHOWWINDOW = &H40
SWP_HIDEWINDOW = &H80
SWP_FRAMECHANGED = &H20
SWP_NOACTIVATE = &H10
SWP_NOCOPYBITS = &H100
SWP_NOMOVE = &H2
SWP_NOOWNERZORDER = &H200
SWP_NOREDRAW = &H8
SWP_NOREPOSITION = SWP_NOOWNERZORDER
SWP_NOSIZE = &H1
SWP_NOZORDER = &H4
SWP_DRAWFRAME = SWP_FRAMECHANGED
HWND_NOTOPMOST = -2
End Enum
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Function ShowTitleBar(ByVal bState As Boolean)
Dim lStyle As Long
Dim tR As RECT
GetWindowRect Me.hwnd, tR
lStyle = GetWindowLong(Me.hwnd, GWL_STYLE)
If (bState) Then
Me.Caption = Me.Tag
If Me.ControlBox Then
lStyle = lStyle Or WS_SYSMENU
End If
If Me.MaxButton Then
lStyle = lStyle Or WS_MAXIMIZEBOX
End If
If Me.MinButton Then
lStyle = lStyle Or WS_MINIMIZEBOX
End If
If Me.Caption = "" Then
lStyle = lStyle Or WS_CAPTION
End If
Else
Me.Tag = Me.Caption
Me.Caption = ""
lStyle = lStyle And Not WS_SYSMENU
lStyle = lStyle And Not WS_MAXIMIZEBOX
lStyle = lStyle And Not WS_MINIMIZEBOX
lStyle = lStyle And Not WS_CAPTION
End If
SetWindowLong Me.hwnd, GWL_STYLE, lStyle
SetWindowPos Me.hwnd, 0, tR.Left, tR.Top, tR.Right - tR.Left, tR.Bottom - tR.Top, SWP_NOREPOSITION Or SWP_NOZORDER Or SWP_FRAMECHANGED
Me.Refresh
End Function
Private Sub Command1_Click()
ShowTitleBar False
End Sub
Private Sub Command2_Click()
ShowTitleBar True
End Sub