Private Sub Form_Load()
Dim x As Long, flag As Long
Randomize Timer
x = Int(6 * Rnd + 1) '取随机整数
Select Case x '根据随机数选择相应的动画过程
Case 1
flag = AW_HOR_NEGATIVE
Case 2
flag = AW_HOR_POSITIVE
Case 3
flag = AW_VER_NEGATIVE
Case 4
flag = AW_VER_POSITIVE
Case 5
flag = AW_CENTER
Case 6
flag = AW_BLEND '只在Windows 2000中起作用
End Select
AnimateWindow Form1.hwnd, 200, flag
Me.Refresh
End Sub
Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next
Gotoval = Me.Height / 2
For gointo = 1 To Gotoval
DoEvents
Me.Height = Me.Height - 10
If Me.Height <= 11 Then GoTo horiz
Next gointo
horiz:
Me.Height = 30
Gotoval = Me.Width / 2
For gointo = 1 To Gotoval
DoEvents
Me.Width = Me.Width - 10
If Me.Width <= 11 Then End
Next gointo
End
End Sub
窗体关闭的效果
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Sub SetWindowPos Lib "user32" (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)
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Private Const MOUSEEVENTF_LEFTDOWN = &H2
Private Const MOUSEEVENTF_LEFTUP = &H4
Private Declare Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long
Public Sub CloseForm(FormToClose As Form)
Dim Hwndnew As Long
Dim R As RECT
Dim Rwidth As Integer
Dim Rheight As Integer
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
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
Sub FormEffect(f As Form, Movement As Integer)
Dim myRect As RECT
Dim formWidth%, formHeight%, i%, X%, Y%, Cx%, Cy%
Dim TheScreen As Long
Dim Brush As Long
GetWindowRect f.hwnd, myRect '获得窗体四角的坐标
'计算窗体的高与宽
formWidth = myRect.Right - myRect.Left
formHeight = myRect.Bottom - myRect.Top
'得到屏幕的设备描述表句柄
TheScreen = GetDC(0)
'创建实色画刷
Brush = CreateSolidBrush(f.BackColor)
'将创建的画刷选入设备描述表中
SelectObject TheScreen, Brush
'从小到大依次绘制矩形,直到与窗体大小相同为止
For i = 1 To Movement
Cx = formWidth * (i / Movement)
Cy = formHeight * (i / Movement)
X = myRect.Left + (formWidth - Cx) / 2
Y = myRect.Top + (formHeight - Cy) / 2
Rectangle TheScreen, X, Y, X + Cx, Y + Cy
Next i
'释放
X = ReleaseDC(0, TheScreen)
'从内存中删除创建的画刷
DeleteObject (Brush)
End Sub
Private Sub Form_Load()
FormEffect Me, 10000
End Sub
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 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 WS_EX_LAYERED = &H80000
Private Const GWL_EXSTYLE = (-20)
Private Const LWA_ALPHA = &H2
Private Const LWA_COLORKEY = &H1
图片你自己找啊!
Private Declare Function ReleaseCapture Lib "user32" () 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 Const WM_NCLBUTTONDOWN = &HA1
Private Declare Function SetWindowPos Lib "user32" (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 Form_Load()
Me.BackColor = &HFF0000
Dim rtn As Long
BorderStyler = 0
rtn = GetWindowLong(hwnd, GWL_EXSTYLE)
rtn = rtn Or WS_EX_LAYERED
SetWindowLong hwnd, GWL_EXSTYLE, rtn
SetLayeredWindowAttributes hwnd, &HFF0000, 0, LWA_COLORKEY
End Sub
===========================================================================
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
ReleaseCapture
SendMessage Me.hwnd, WM_NCLBUTTONDOWN, 2, 0
Sub Command3Dl_Click()
Dim i, j, k, m, n '定义变量
For i=2080 To 5520
'显示出三条线,直到图像中的散射中心处,颜色为黑色
Line (2080,2760)-(i,2760),RGB(0, 0, 0)
Line (2080,2860)-(i,2860),RGB(0, 0, 0)
Line (2080,2660)-(i,2660),RGB(0, 0, 0)
Next i
For j=5520 To 4800 Step-1 '反射光线第一次射到管壁上
Line (5520,2760)-(j,2760-(5520-j)*.33333333),RGB
(255, 0, 0) '反射光线,颜色为红色
Line (5520,2660)-(5520+(5520-j),2660),RGB(0, 0, 0)
Line (5520,2860)-(5520+(5520-j),2860),RGB(0, 0, 0)
'没有遇到散射中心的两条光线,为黑色,继续前进
Next j
For k=4800 To 3360 Step-1 '反射光线第二次射到管壁上
Line (4800,2520)-(k,2520+(4800-k)*.33333333),
RGB(255, 0, 0) '反射光线,颜色为红色
Line (6240,2660)-(6240+(4800-k),2660),RGB(0, 0, 0)
Line (6240,2860)-(6240+(4800-k),2860),RGB(0, 0, 0)
'没有遇到散射中心的两条光线,颜色为黑色
Next k
For m=3360 To 2080 Step-1 '反射光线第三次射到管壁上
Line (3360,3000)-(m,3000-(3360-m)*.33333333),
RGB(255, 0, 0) '反射光线,颜色为红色
Next m
End Sub
Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Sub Form_Load()
Dim ScreenW_Lng As Long
Dim ScreenH_Lng As Long
Dim HRgn_Lng As Long