请问在VB中怎样实现窗体特效

Question

比如窗体关闭或打开的时候出有百页窗效果之类的.

Answer 1

Private Declare Function AnimateWindow Lib "user32" (ByVal hwnd As Long, ByVal dwTime As Long, ByVal dwFlags As Long) As LongPrivate Sub Form_Load()
AnimateWindow hwnd, 3000, &H80000
Me.Refresh
End Sub

Answer 2

为什么我用ANIMATEWINDOW函数的时候，我用的渐入渐出参数，可是调用过后动画到是有了，但是窗体却变成黑色的了，只有在调用一个form1.refresh才能恢复正常。而且都不是完全正常，FORM1上的一个文本框的四周还是黑框呢？请问各位大侠。

Answer 3

1、窗体的渐现渐隐（1.zip）
●特效描述：窗体从一个点逐渐变大，单击窗体后逐渐变小消失。
●实现原理：在窗体加载时，先在屏幕上画一系列有效到大的矩形，直到矩形的大小与窗体的大小相同。这样，看上去窗体就好像是从小变大一样。卸载时，原理也相似，只是过程相反罢了。
●实现方法：新建一个窗体，输入以下代码：
●源代码：
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Sub Form_Load()
'窗体装载时
Dim myRect As RECT
Dim formWidth%, formHeight%, i%, X%, Y%, Cx%, Cy%
Dim Screen As Long
Dim Brush As Long
GetWindowRect Form1.hwnd, myRect '获得窗体四角的坐标
'计算窗体的高与宽
formWidth = myRect.Right - myRect.Left
formHeight = myRect.Bottom - myRect.Top
Screen = GetDC(0)
'创建实色画刷
Brush = CreateSolidBrush(Form1.BackColor)
'将创建的画刷选入设备描述表中
SelectObject Screen, Brush
'从小到大依次绘制矩形，直到与窗体大小相同为止
For i = 1 To 3000
Cx = formWidth * (i / 3000)
Cy = formHeight * (i / 3000)
X = myRect.Left + (formWidth - Cx) / 2
Y = myRect.Top + (formHeight - Cy) / 2
Rectangle Screen, X, Y, X + Cx, Y + Cy
Next i
'释放
X = ReleaseDC(0, Screen)
'从内存中删除创建的画刷
DeleteObject (Brush)
End Sub
Private Sub form_unload(Cancel As Integer)
Dim myRect As RECT
Dim formWidth%, formHeight%, i%, X%, Y%, Cx%, Cy%
Dim Screen As Long
Dim Brush As LongGetWindowRect Form1.hwnd, myRect
formWidth = (myRect.Right - myRect.Left)
formHeight = myRect.Bottom - myRect.Top
Screen = GetDC(0)
Brush = CreateSolidBrush(Form1.BackColor)For i = 3000 To 1 Step -1
Cx = formWidth * (i / 3000)
Cy = formHeight * (i / 3000)
X = myRect.Left + (formWidth - Cx) / 2
Y = myRect.Top + (formHeight - Cy) / 2
Rectangle Screen, X, Y, X + Cx, Y + Cy
Next i
X = ReleaseDC(0, Screen)
DeleteObject (Brush)
Unload Form1
End Sub
2、窗体逐渐展开，再逐渐消失(2.zip)
●特效描述：调用窗体时，窗体先是纵向展开，接着再横向展开；卸载窗体时，先纵向收起，只剩标题栏时，再横向关闭。
●实现原理：实现方法用两种。一种是用Timer控件，隔一定时间改变窗体的宽度（Width）属性值和高度属性值（Height）。另外一种是用循环，也是改变窗体的宽度、高度值。本程序中，在窗体加载时使用第一种方法，在窗体卸载时使用第二种方法。
●实现方法：新建一个窗体，在上面放一个Timer控件，命名为Timer1，并输入以下代码：
●源代码：
Public h As Integer
Public w As Integer
Private Sub Form_Unload(Cancel As Integer)
For i = 1 To Me.Height / 2 '...先是纵向收窄
DoEvents
Me.Height = Me.Height - 10
If Me.Height <= 11 Then GoTo lines '...纵向收窄至标题栏后,再横向收窄
Next i
lines:
Me.Height = 30
For i = 1 To Me.Width / 2
DoEvents
Me.Width = Me.Width - 10
If Me.Width <= 11 Then End
Next i
End
End Sub
Private Sub Form_Load()
'...记录窗体初始值
w = Me.Width
h = Me.Height
Me.Left = 3390
Me.Top = 1800
Me.Height = 0
Me.Width = 0
Timer1.Interval = 1 '...调整这个值,窗体的展开速度会发生变化
Timer1.Enabled = True
End Sub
Private Sub Timer1_Timer()
'150是变化速度;调整这个值,窗体展开速度会发生变化
If Me.Height < h Then Me.Height = Me.Height + 150 '...先是纵向展开
If Me.Height >= h Then '...纵向展开完毕后,再横向展开
Me.Width = Me.Width + 150
If Me.Width >= w Then
Timer1.Enabled = False
End If
End If
End Sub

Answer 4

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
　

Answer 5

4、图形化的窗体（6.zip）
●特效描述：以一个图形作为窗体形状的模板。（如图4所示）
　                    图4●实现原理：和上面提到的“文字窗体”差不多。
●实现方法：新建一个窗体，将其命名为Form1，在上面放一个PictureBox控件，命名为picMainSkin。接着新建一个模块。最后输入代码。
●源代码：
（1）Form1的源代码：
Option Explicit
Private Sub form_click()
Unload Form1
End SubPrivate Sub Form_Load()
Dim WindowRegion As Long
picMainSkin.ScaleMode = vbPixels
picMainSkin.AutoRedraw = True
picMainSkin.AutoSize = True
picMainSkin.BorderStyle = vbBSNone
Me.BorderStyle = vbBSNone
Set picMainSkin.Picture = LoadPicture(App.Path & "\form1.gif")
Me.Width = picMainSkin.Width
Me.Height = picMainSkin.Height
WindowRegion = MakeRegion(picMainSkin)
SetWindowRgn Me.hWnd, WindowRegion, True
End SubPrivate Sub picMainSkin_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
ReleaseCapture
SendMessage Me.hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&End Sub
（2）模块代码：
Option Explicit
Public Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long) As Long
Public Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Public Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Public Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function ReleaseCapture Lib "user32" () As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Const RGN_OR = 2
Public Const WM_NCLBUTTONDOWN = &HA1
Public Const HTCAPTION = 2Public Function MakeRegion(picSkin As PictureBox) As Long
Dim X As Long, Y As Long, StartLineX As Long
Dim FullRegion As Long, LineRegion As Long
Dim TransparentColor As Long
Dim InFirstRegion As Boolean
Dim InLine As Boolean ' Flags whether we are in a non-tranparent pixel sequence
Dim hDC As Long
Dim PicWidth As Long
Dim PicHeight As Long
hDC = picSkin.hDC
PicWidth = picSkin.ScaleWidth
PicHeight = picSkin.ScaleHeight
InFirstRegion = True: InLine = False
X = Y = StartLineX = 0
TransparentColor = GetPixel(hDC, 0, 0)
For Y = 0 To PicHeight - 1
For X = 0 To PicWidth - 1
If GetPixel(hDC, X, Y) = TransparentColor Or X = PicWidth Then
If InLine Then
InLine = False
LineRegion = CreateRectRgn(StartLineX, Y, X, Y + 1)
If InFirstRegion Then
FullRegion = LineRegion
InFirstRegion = False
Else
CombineRgn FullRegion, FullRegion, LineRegion, RGN_ORDeleteObject LineRegion
End If
End If
ElseIf Not InLine Then
InLine = True
StartLineX = X
End If
End If
Next
NextMakeRegion = FullRegion
End Function