Вот частичное решение задачи. Форма прозрачная, без заголовка, отображается поверх всех окон, но не могу привинтить сюда перемещение за тело.
Код
Private Declare PtrSafe Function FindWindow _
Lib "user32.dll" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function GetWindowLong _
Lib "user32.dll" Alias "GetWindowLongA" ( _
ByVal hWnd As Long, _
ByVal nIndex As Long) As Long
Private Declare PtrSafe Function SetWindowLong _
Lib "user32.dll" Alias "SetWindowLongA" ( _
ByVal hWnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Private Declare PtrSafe Function DrawMenuBar Lib "user32.dll" ( _
ByVal hWnd As Long) As Long
Private Declare PtrSafe Function SetLayeredWindowAttributes _
Lib "user32.dll" ( _
ByVal hWnd As Long, _
ByVal crKey As Long, _
ByVal bAlpha As Long, _
ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hWnd As LongPtr, _
ByVal hWndInsertAfter As LongPtr, _
ByVal X As Long, ByVal Y As Long, _
ByVal cx As Long, ByVal cy As Long, _
ByVal wFlags As Long) As Long
Private Const HWND_NOTOPMOST = -2
Private Const HWND_TOPMOST = -1
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
Private Sub UserForm_Initialize()
Dim ihWnd As Long, iStyle As Long
ihWnd = FindWindow(vbNullString, Me.Caption)
iStyle = GetWindowLong(ihWnd, -16&)
SetWindowLong ihWnd, -16&, iStyle And Not &HC00000
DrawMenuBar ihWnd
Dim hWnd As LongPtr
hWnd = FindWindow(vbNullString, Me.Caption)
Call SetWindowPos(hWnd, HWND_TOPMOST, 0, 0, 0, 0, WP_NOMOVE Or SWP_NOSIZE)
'*******Форма в нормальное положение**************
' Call SetWindowPos(hWnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
'**********************************************
UserForm1.Left = 875
UserForm1.Top = 600
SetWindowLong ihWnd, -20&, iStyle Or 524288
SetLayeredWindowAttributes ihWnd, 0&, 100&, 2&
End Sub
Нужно эти 2 кода скрестить (нижний позволяет таскать за тело форму без шапки). Прошу помочь.
Код
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, применяемые для поиска окна и изменения его стиля
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
Private Declare PtrSafe 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 PtrSafe Sub ReleaseCapture Lib "user32" ()
Dim ihWnd As Long
Private Declare PtrSafe Function SetWindowPos Lib "user32.dll" ( _
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 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
В файлике в первой Юзерформ первый код, во второй - второй.
Мастерство программиста не в том, чтобы писать программы, работающие без ошибок. А в том, чтобы писать программы, работающие при любом количестве ошибок.
Alemox, спасибо, всё работает!) Только непонятно как и почему..) Вот так работает (взял только часть кода):
Код
Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
OldX = X
OldY = Y
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
Me.Left = Me.Left + (X - OldX)
Me.Top = Me.Top + (Y - OldY)
End If
End Sub
А вот так не работает, хотя шапки "UserForm_MouseDown(ByVal B.........", вроде как одинаковы и закинуть действия под одну крышу вроде бы можно (НО нельзя, ибо не работает):
Код
Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
OldX = X
OldY = Y
If Button = 1 Then
Me.Left = Me.Left + (X - OldX)
Me.Top = Me.Top + (Y - OldY)
End If
End Sub