Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Перемещение UserForm в любую область - Мир MS Excel

  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_, DrMini  
Перемещение UserForm в любую область
Starbirst Дата: Среда, 31.01.2018, 08:51 | Сообщение № 1
Группа: Пользователи
Ранг: Участник
Сообщений: 83
Репутация: 0 ±
Замечаний: 0% ±

Excel 2003
Доброго времени суток! Ребята, как сделать, чтобы UserForm можно было переместить в любую область при нажатой левой кнопки мыши?
К сообщению приложен файл: 8280981.xlsm (19.2 Kb)
 
Ответить
СообщениеДоброго времени суток! Ребята, как сделать, чтобы UserForm можно было переместить в любую область при нажатой левой кнопки мыши?

Автор - Starbirst
Дата добавления - 31.01.2018 в 08:51
nilem Дата: Среда, 31.01.2018, 08:55 | Сообщение № 2
Группа: Авторы
Ранг: Старожил
Сообщений: 1613
Репутация: 563 ±
Замечаний: 0% ±

Excel 2013, 2016
Ну Вы же специально убрали заголовок формы )
Теперь ее не за что "взять", чтобы перетащить куда-то


Яндекс.Деньги 4100159601573
 
Ответить
СообщениеНу Вы же специально убрали заголовок формы )
Теперь ее не за что "взять", чтобы перетащить куда-то

Автор - nilem
Дата добавления - 31.01.2018 в 08:55
Апострофф Дата: Среда, 31.01.2018, 09:47 | Сообщение № 3
Группа: Проверенные
Ранг: Обитатель
Сообщений: 468
Репутация: 129 ±
Замечаний: 0% ±

Excel 1997
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
[/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
[/vba]

Автор - Апострофф
Дата добавления - 31.01.2018 в 09:47
krosav4ig Дата: Четверг, 01.02.2018, 00:33 | Сообщение № 4
Группа: Друзья
Ранг: Старожил
Сообщений: 2348
Репутация: 997 ±
Замечаний: 0% ±

Excel 2007,2010,2013
[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 'определяет рамку формы
    
    Private Const WM_NCLBUTTONDOWN = &HA1
    Private Const HTCAPTION = 2
    
    'Функции 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]


email:krosav4ig26@gmail.com WMR R207627035142 WMZ Z821145374535 ЯД 410012026478460

Сообщение отредактировал krosav4ig - Четверг, 01.02.2018, 00:33
 
Ответить
Сообщение[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 'определяет рамку формы
    
    Private Const WM_NCLBUTTONDOWN = &HA1
    Private Const HTCAPTION = 2
    
    'Функции 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]

Автор - krosav4ig
Дата добавления - 01.02.2018 в 00:33
Starbirst Дата: Четверг, 01.02.2018, 06:17 | Сообщение № 5
Группа: Пользователи
Ранг: Участник
Сообщений: 83
Репутация: 0 ±
Замечаний: 0% ±

Excel 2003
krosav4ig, Это круто! respect yahoo Огромная благодарность!
 
Ответить
Сообщениеkrosav4ig, Это круто! respect yahoo Огромная благодарность!

Автор - Starbirst
Дата добавления - 01.02.2018 в 06:17
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2026 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!