谁能解释解释吗?好多看不懂!
这个可以去掉使用ANIMATEWINDOW函数时产生的黑色背景。不过就是看不懂。
3、用API实现动感效果（10.zip）
●特效描述：本程序用API函数实现了三种成提启动特效：从左上角出现，从正中展开以及淡入淡出。
●实现方法：建立两个窗体，分别命名为Form1和frmanim。在Form1中方三个按钮控件，三个按钮的属性如下所示：
按钮名字 Caption属性
------------------------------------
cmdSlide 从左上角出现
cmdExpand 从中间出现
cmdFade 淡入淡出
接着，在新建的frmanim窗体上，随便放几个控件。然后，新建一个模块。最后输入代码即可。
●源代码：
（1）form1窗体的代码：
Option Explicit
Private Sub Form_Load()
Load frmAnim
End Sub
Private Sub Form_Unload(Cancel As Integer)
Unload frmAnim
End Sub
Private Sub cmdSlide_Click()
frmAnim.Move 300, 300
AnimateWindow frmAnim.hWnd, 300, _
AW_HOR_POSITIVE + AW_VER_POSITIVE + AW_SLIDE + AW_ACTIVATE
End Sub
Private Sub cmdExpand_Click()
frmAnim.Move 300, 300
AnimateWindow frmAnim.hWnd, 300, _
AW_CENTER + AW_SLIDE + AW_ACTIVATE
End Sub
Private Sub cmdFade_Click()
frmAnim.Move 300, 300
AnimateWindow frmAnim.hWnd, 300, _
AW_BLEND + AW_ACTIVATE
End Sub
（2）frmanim窗体的代码：
Option Explicit
Private Declare Function CreateSolidBrush Lib "gdi32" _
(ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, _
lpRect As RECT, ByVal hBrush As Long) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Friend Sub PrintClient(ByVal hDC As Long, ByVal lParam As Long)
Dim rct As RECT
Dim hBr As Long
rct.Left = 0
rct.Top = 0
rct.Right = ScaleX(ScaleWidth, ScaleMode, vbPixels)
rct.Bottom = ScaleY(ScaleHeight, ScaleMode, vbPixels)
hBr = CreateSolidBrush(TranslateColor(Me.BackColor))
FillRect hDC, rct, hBr
DeleteObject hBr
End Sub
Private Sub Form_Load()
SubclassAnim Me
End Sub
Private Sub Form_Unload(Cancel As Integer)
UnSubclassAnim Me
End Sub
（3）模块代码：
Option Explicit
Public Const AW_HOR_POSITIVE = &H1
Public Const AW_HOR_NEGATIVE = &H2
Public Const AW_VER_POSITIVE = &H4
Public Const AW_VER_NEGATIVE = &H8
Public Const AW_CENTER = &H10
Public Const AW_HIDE = &H10000
Public Const AW_ACTIVATE = &H20000
Public Const AW_SLIDE = &H40000
Public Const AW_BLEND = &H80000
Public Declare Function AnimateWindow Lib "user32" _
(ByVal hWnd As Long, _
ByVal dwTime As Long, ByVal dwFlags As Long) As Long
Public Const WM_PRINTCLIENT = &H318
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Any, Source As Any, ByVal Length As Long)
Public Declare Function GetWindowLong Lib "user32" Alias _
"GetWindowLongA" (ByVal hWnd As Long, _
ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias _
"SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Public Const GWL_WNDPROC = (-4)
Public Declare Function GetProp Lib "user32" Alias "GetPropA" _
(ByVal hWnd As Long, ByVal lpString As String) As Long
Public Declare Function SetProp Lib "user32" Alias "SetPropA" _
(ByVal hWnd As Long, ByVal lpString As String, _
ByVal hData As Long) As Long
Public Declare Function RemoveProp Lib "user32" Alias "RemovePropA" _
(ByVal hWnd As Long, ByVal lpString As String) As Long
Public Declare Function CallWindowProc Lib "user32" Alias _
"CallWindowProcA" (ByVal lpPrevWndFunc As Long, _
ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, _
ByVal lParam As Long) As Long
Public Declare Function OleTranslateColor _
Lib "oleaut32.dll" _
(ByVal lOleColor As Long, _
ByVal lHPalette As Long, _
lColorRef As Long) As Long
Public Function TranslateColor(inCol As Long) As Long
Dim retCol As Long
OleTranslateColor inCol, 0&, retCol
TranslateColor = retCol
End Function
Public Function AnimWndProc(ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Dim lProc As Long
Dim lPtr As Long
Dim frm As frmAnim
lProc = GetProp(hWnd, "ExAnimWndProc")
lPtr = GetProp(hWnd, "ExAnimWndPtr")
If wMsg = WM_PRINTCLIENT Then
CopyMemory frm, lPtr, 4
frm.PrintClient wParam, lParam
CopyMemory frm, 0&, 4
End If
AnimWndProc = CallWindowProc(lProc, hWnd, wMsg, wParam, lParam)
End Function
Public Sub SubclassAnim(frm As frmAnim)
Dim l As Long
If GetProp(frm.hWnd, "ExAnimWndProc") <> 0 Then
'Already subclassed
Exit Sub
End If
l = GetWindowLong(frm.hWnd, GWL_WNDPROC)
SetProp frm.hWnd, "ExAnimWndProc", l
SetProp frm.hWnd, "ExAnimWndPtr", ObjPtr(frm)
SetWindowLong frm.hWnd, GWL_WNDPROC, AddressOf AnimWndProc
End Sub
Public Sub UnSubclassAnim(frm As frmAnim)
Dim l As Long
l = GetProp(frm.hWnd, "ExAnimWndProc")
If l = 0 Then
'Isn't subclassed anyway
Exit Sub
End If
SetWindowLong frm.hWnd, GWL_WNDPROC, l
RemoveProp frm.hWnd, "ExAnimWndProc"
RemoveProp frm.hWnd, "ExAnimWndPtr"
End Sub
问题点数：0、回复次数：3Top
1 楼hdhai9451（☆新人类☆）回复于 2004-09-01 21:25:35 得分 0
代碼太多，格式也不好，哪裡有那麼多時間看啊？你只選你最想懂的部分出來就可以嗎！我大概看了一下，裡面用了不少的API函數Top
2 楼flyingscv（zlj）回复于 2004-09-01 21:27:50 得分 0
mark一下Top
3 楼oldsnow（老雪）回复于 2004-09-01 22:25:20 得分 0
其实我主要是想知道怎样去掉ANIMATEWINDOW函数调用时窗体显示的黑色，当然加一个刷新语句就能解决，但是还是不如人意。上面那段代码就可以去掉，但还有更简单一点的吗？Top
