Заметили, что этот самый AnimateWindow хреново работает?
Форма ЧЁРНАЯ при этом, хоть на 98, хоть на XP <_<
Не подскажете, как сделать плавное появление и исчезание окна без ентого самого AnimateWindow?
Плавное исчезновение, так что ли?
Кинь на форму таймер и кнопку, далее код.
Option Explicit
Dim wrem As Long
Private Sub Command1_Click()
Timer1.Enabled = True
End Sub
Private Sub Form_Load()
wrem = 250
Timer1.Interval = 50
Timer1.Enabled = False
End Sub
Private Sub Timer1_Timer()
Call alpha(Me.hwnd, wrem)
wrem = wrem - 10
If wrem = 30 Then
Timer1.Enabled = False
Unload Me
End If
End Sub
а это в модуле.
Option Explicit
'îáúÿâëÿåì API ôóíêöèè è êîíñòàíòû
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex 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 Const GWL_STYLE = (-16)
Private Const GWL_EXSTYLE = (-20)
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 Const LWA_COLORKEY = &H1
Private Const LWA_ALPHA = &H2
Private Const WS_EX_LAYERED = &H80000
Sub alpha(Hwnds As Long, vals As Long) 'ñîçäàíèå ïðîçðà÷íîñòè ó ôîðìû (îïèñàòåëü îêíà, ñòåïåíü ïðîçðà÷íîñòè 0 - 255)
If vals < 254 Then 'åñëè çíà÷åíèå vals ìåíüøå 254, òî
Dim lStyle As Long 'îáúÿâëÿåì ÷èñëîâóþ ïåðåìåííóþ
lStyle = GetWindowLong(Hwnds, GWL_EXSTYLE) 'óçíàåì àòòðèáóòû îêíà
lStyle = lStyle Or WS_EX_LAYERED
SetWindowLong Hwnds, GWL_EXSTYLE, lStyle 'óñòàíàâëèâàåì àòòðèáóòû îêíà
SetLayeredWindowAttributes Hwnds, 0, vals, LWA_ALPHA 'óñòàíàâëèâàåì ïðîçðà÷íîñòü
Else 'â ëþáîì äðóãîì ñëó÷àå
SetWindowLong Hwnds, GWL_EXSTYLE, 0 'óñòàíàâëèâàåì îáû÷íûå àòòðèáóòû îêíà
End If 'çàêðûâàåì óñëîâèå
End Sub
для AnimateWindow нужен обработчик WM_PRINTCLIENT.
Cабклассировать окно и в оконной процедуре использовать следущее:
Public Function win_proc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
On Error Resume Next
Dim rct As RECT
Dim hbr As Long
Select Case Msg
Case &H318 'WM_PRINTCLIENT
GetClientRect hwnd, rct
hbr = CreateSolidBrush(TransCol(Form1.BackColor))
FillRect wParam, rct, hbr
 eleteObject hbr
End Select
win_proc = CallWindowProc(dfPrc, hwnd, Msg, wParam, lParam)
End Function
Private Function TransCol(ByVal Clr As Long) As Long
OleTranslateColor Clr, 0, TransCol
End Function