Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) If Button = 1 Then XX = X YY = Y End If End Sub
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) If Button = 1 Then Left = Left + X - XX Top = Top + Y - YY End If End Sub
[/vba]
Starbirst, попробуйте -[vba]
Код
Dim XX As Single, YY As Single 'на уровне формы
Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) If Button = 1 Then XX = X YY = Y End If End Sub
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) If Button = 1 Then Left = Left + X - XX Top = Top + Y - YY End If End Sub
Option Explicit 'константы для функций API Private Const GWL_STYLE As Long = -16& 'для установки нового вида окна Private Const GWL_EXSTYLE = -20& 'для расширенного стиля окна Private Const WS_CAPTION As Long = &HC00000 'определяет заголовок Private Const WS_BORDER As Long = &H800000 'определяет рамку формы
'Функции API, применяемые для поиска окна и изменения его стиля #If VBA7 Then Private Declare PtrSafe Function SetWindowLong Lib "User32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr Private Declare PtrSafe Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr Private Declare PtrSafe Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr Private Declare PtrSafe Function DrawMenuBar Lib "User32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr Private Declare PtrSafe Sub ReleaseCapture Lib "user32" ()
Dim ihWnd As LongPtr #Else 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 FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function DrawMenuBar Lib "user32.dll" (ByVal hwnd 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 Declare Sub ReleaseCapture Lib "user32" ()
Dim ihWnd As Long #End If
Private Sub UserForm_Initialize() Dim hStyle 'ищем окно формы среди всех открытых окон If VAL(Application.Version) < 9 Then ihWnd = FindWindow("ThunderXFrame", Me.Caption) 'для Excel 97 Else ihWnd = FindWindow("ThunderDFrame", Me.Caption) 'для Excel 2000 и выше End If 'получаем информацию о найденном окне(стили и т.д.) hStyle = GetWindowLong(ihWnd, GWL_STYLE) 'назначаем переменной новый стиль для окна формы hStyle = hStyle And Not WS_CAPTION And Not WS_BORDER 'изменяем вид окна: убираем меню(заголовок) и рамку SetWindowLong ihWnd, GWL_STYLE, hStyle SetWindowLong ihWnd, GWL_EXSTYLE, 0 'перерисовываем форму, точнее строку меню(заголовка) DrawMenuBar ihWnd 'меняем размер формы, т.к. сделали смещение элементов формы вверх на высоту заголовка Me.Height = Me.Height + GWL_EXSTYLE End Sub
Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) If Button = 1 Then ReleaseCapture SendMessage ihWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0& End If End Sub
Private Sub ЗАКРЫТЬ_Click() Unload Me End Sub
[/vba]
[vba]
Код
Option Explicit 'константы для функций API Private Const GWL_STYLE As Long = -16& 'для установки нового вида окна Private Const GWL_EXSTYLE = -20& 'для расширенного стиля окна Private Const WS_CAPTION As Long = &HC00000 'определяет заголовок Private Const WS_BORDER As Long = &H800000 'определяет рамку формы
'Функции API, применяемые для поиска окна и изменения его стиля #If VBA7 Then Private Declare PtrSafe Function SetWindowLong Lib "User32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr Private Declare PtrSafe Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr Private Declare PtrSafe Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr Private Declare PtrSafe Function DrawMenuBar Lib "User32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr Private Declare PtrSafe Sub ReleaseCapture Lib "user32" ()
Dim ihWnd As LongPtr #Else 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 FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function DrawMenuBar Lib "user32.dll" (ByVal hwnd 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 Declare Sub ReleaseCapture Lib "user32" ()
Dim ihWnd As Long #End If
Private Sub UserForm_Initialize() Dim hStyle 'ищем окно формы среди всех открытых окон If VAL(Application.Version) < 9 Then ihWnd = FindWindow("ThunderXFrame", Me.Caption) 'для Excel 97 Else ihWnd = FindWindow("ThunderDFrame", Me.Caption) 'для Excel 2000 и выше End If 'получаем информацию о найденном окне(стили и т.д.) hStyle = GetWindowLong(ihWnd, GWL_STYLE) 'назначаем переменной новый стиль для окна формы hStyle = hStyle And Not WS_CAPTION And Not WS_BORDER 'изменяем вид окна: убираем меню(заголовок) и рамку SetWindowLong ihWnd, GWL_STYLE, hStyle SetWindowLong ihWnd, GWL_EXSTYLE, 0 'перерисовываем форму, точнее строку меню(заголовка) DrawMenuBar ihWnd 'меняем размер формы, т.к. сделали смещение элементов формы вверх на высоту заголовка Me.Height = Me.Height + GWL_EXSTYLE End Sub
Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) If Button = 1 Then ReleaseCapture SendMessage ihWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0& End If End Sub