1
2
3
4
5
6
7
8
9
10
11
12
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
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
| Option Explicit
'
'нестандартная форма
'© Антихакер32™
'
Private Const GWL_EXSTYLE = (-20)
Private Const GWL_STYLE = (-16)
Private Const HTCAPTION = 2
Private Const LWA_COLORKEY = &H1
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const WS_CAPTION = &HC00000 'WS_BORDER Or WS_DLGFRAME
Private Const WS_EX_LAYERED As Long = &H80000
#If win64 Then
'-----------------------------------------[Api функции win64]
Private Declare PtrSafe Function AnimateWindow Lib "user32.dll" (ByVal hWnd As Long, ByVal dwTime As Long, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) 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 Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As LongPtr, ByVal crKey As Integer, ByVal bAlpha As Integer, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare PtrSafe Sub ReleaseCapture Lib "user32" ()
#Else
'-----------------------------------------[Api функции win32]
Private Declare Function AnimateWindow Lib "user32.dll" (ByVal hWnd As Long, ByVal dwTime As Long, ByVal dwFlags 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 GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex 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 Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Sub ReleaseCapture Lib "user32" ()
#End If
Dim hWnd&, picobj As Object
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
'Анимация исчезновения
AnimateWindow hWnd&, 1000&, &H10000 Or &H10
End Sub
Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, _
ByVal Y As Single)
'
'Реализация возможности таскать форму за любое место
'
If Button Then
Call ReleaseCapture
Call SendMessage(hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
End If
End Sub
Private Sub UserForm_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Unload Me 'По двойному клику выход из программы
End Sub
Private Function RandomName$(Optional LenName& = 32)
Dim f&
RandomName = Space$(LenName): Randomize Timer
For f = 1 To LenName
Mid$(RandomName, f, 1) = Fix(Rnd * 10)
Next
End Function
Private Sub UserForm_Initialize()
Const KeyColor = &HFF00DC 'Фиолетовый цвет ключ прозрачности
Dim Style As Long, PicFile$, s
'Получаем описатель окна
Me.Caption = RandomName
hWnd = FindWindow(vbNullString, Me.Caption)
PicFile = ThisWorkbook.Path
ChDir PicFile 'Устанавливаем папку этой книги
PicFile = PicFile & "\amsn_8001.gif"
Me.BackColor = KeyColor
Style = GetWindowLong(hWnd, GWL_EXSTYLE) Or WS_EX_LAYERED
SetWindowLong hWnd, GWL_EXSTYLE, Style
SetLayeredWindowAttributes hWnd, KeyColor, 0, LWA_COLORKEY
SetWindowLong hWnd, GWL_STYLE, GetWindowLong(hWnd, GWL_STYLE) And Not WS_CAPTION
Set picobj = LoadPicture(PicFile)
With Controls.Add("forms.image.1", Me.Caption)
.AutoSize = 1: .PictureSizeMode = 1
.Picture = picobj: Me.Picture = .Picture
Me.Move 0, 0, .Width, .Height
End With
Controls.Remove (Me.Caption)
Me.StartUpPosition = 1
End Sub |
