|
-
Jun 15th, 2005, 01:03 AM
#1
Thread Starter
Admodistrator
Cool Effects For your Form:
Have your form change colors nicely without flickering:
VB Code:
Option Explicit
Dim r As Byte, g As Byte, b As Byte, flag As Byte, d(3) As Byte
Private Sub Form_Load()
r = 255: g = 255: b = 255: flag = 0
End Sub
Function Disco()
If flag Then
r = DoIt(1, r)
g = DoIt(2, g)
b = DoIt(3, b)
flag = flag - 1
Else
r = Ran(1, r)
g = Ran(2, g)
b = Ran(3, b)
flag = 50
End If
Me.BackColor = RGB(r, g, b)
End Function
Function DoIt(ByVal a As Byte, ByVal c As Byte)
If ((d(a) = 2 And c < 255) Or c = 0) Then
c = c + 1
d(a) = 2
Else
If ((d(a) = 1 And c) Or c = 255) Then
c = c - 1
d(a) = 1
End If
If a = 3 Then
If (d(1) + d(2) + d(3) = 0) Then flag = 1
End If
End If
DoIt = c
End Function
Private Sub Timer1_Timer()
Disco
End Sub
Function Ran(ByVal a As Byte, ByVal c As Byte)
If ((Rnd > 0.667 Or c = 0) And c < 255) Then
c = c + 1
d(a) = 2
ElseIf ((Rnd <= 0.5 Or c = 255) And c > 0) Then
c = c - 1
d(a) = 1
Else
d(a) = 0
End If
Ran = c
End Function
To Make a form Opacity fade:
VB Code:
Dim cat as string
Private Sub Timer2_Timer()
Select Case cat
Case "Up"
x = Val(x) + 1
If Val(x) >= 255 Then cat = "Down"
Case "Down"
x = Val(x) - 1
If Val(x) <= 150 Then cat = "Up"
Case ""
cat = "Up"
End Select
Call Mache_Transparent(Me.hWnd, 0)
End Sub
Private Sub Form_Load()
x = 120
cat = "Up"
End Sub
'------------------------------------------------------
'Add below to a module
Option Explicit
Declare Function GetWindowLong Lib "user32.dll" Alias _
"GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Declare Function SetWindowLong Lib "user32.dll" Alias _
"SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal _
dwNewLong As Long) As Long
Declare Function SetLayeredWindowAttributes Lib "user32.dll" (ByVal _
hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal _
dwFlags As Long) As Long
Public Const GWL_EXSTYLE = (-20)
Public Const WS_EX_LAYERED = &H80000
Public Const LWA_ALPHA = &H2
Public x As Integer
Public Sub Mache_Transparent(hWnd As Long, Rate As Byte)
Dim Opacity As Integer
Opacity = x
Rate = Opacity
Dim WinInfo As Long
WinInfo = GetWindowLong(hWnd, GWL_EXSTYLE)
If Rate < 255 Then
WinInfo = WinInfo Or WS_EX_LAYERED
SetWindowLong hWnd, GWL_EXSTYLE, WinInfo
SetLayeredWindowAttributes hWnd, 0, Rate, LWA_ALPHA
Else
WinInfo = WinInfo Xor WS_EX_LAYERED
SetWindowLong hWnd, GWL_EXSTYLE, WinInfo
End If
End Sub
To make a form Opacity fade and Color Fade:
VB Code:
Option Explicit
Dim r As Byte, g As Byte, b As Byte, flag As Byte, d(3) As Byte, cat As String
Private Sub Form_Load()
r = 255: g = 255: b = 255: flag = 0
x = 120: cat = "Up"
End Sub
Function Disco()
If flag Then
r = DoIt(1, r)
g = DoIt(2, g)
b = DoIt(3, b)
flag = flag - 1
Else
r = Ran(1, r)
g = Ran(2, g)
b = Ran(3, b)
flag = 50
End If
Me.BackColor = RGB(r, g, b)
End Function
Function DoIt(ByVal a As Byte, ByVal c As Byte)
If ((d(a) = 2 And c < 255) Or c = 0) Then
c = c + 1
d(a) = 2
Else
If ((d(a) = 1 And c) Or c = 255) Then
c = c - 1
d(a) = 1
End If
If a = 3 Then
If (d(1) + d(2) + d(3) = 0) Then flag = 1
End If
End If
DoIt = c
End Function
Function Ran(ByVal a As Byte, ByVal c As Byte)
If ((Rnd > 0.667 Or c = 0) And c < 255) Then
c = c + 1
d(a) = 2
ElseIf ((Rnd <= 0.5 Or c = 255) And c > 0) Then
c = c - 1
d(a) = 1
Else
d(a) = 0
End If
Ran = c
End Function
Private Sub Timer2_Timer()
Disco
Select Case cat
Case "Up"
x = Val(x) + 1
If Val(x) >= 255 Then cat = "Down"
Case "Down"
x = Val(x) - 1
If Val(x) <= 150 Then cat = "Up"
Case ""
cat = "Up"
End Select
Call Mache_Transparent(Me.hWnd, 0)
End Sub
Public Sub Mache_Transparent(hWnd As Long, Rate As Byte)
Dim Opacity As Integer
Opacity = x
Rate = Opacity
Dim WinInfo As Long
WinInfo = GetWindowLong(hWnd, GWL_EXSTYLE)
If Rate < 255 Then
WinInfo = WinInfo Or WS_EX_LAYERED
SetWindowLong hWnd, GWL_EXSTYLE, WinInfo
SetLayeredWindowAttributes hWnd, 0, Rate, LWA_ALPHA
Else
WinInfo = WinInfo Xor WS_EX_LAYERED
SetWindowLong hWnd, GWL_EXSTYLE, WinInfo
End If
End Sub
'-----------------------------------------------------
'Below in module
Declare Function GetWindowLong Lib "user32.dll" Alias _
"GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Declare Function SetWindowLong Lib "user32.dll" Alias _
"SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal _
dwNewLong As Long) As Long
Declare Function SetLayeredWindowAttributes Lib "user32.dll" (ByVal _
hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal _
dwFlags As Long) As Long
Public Const GWL_EXSTYLE = (-20)
Public Const WS_EX_LAYERED = &H80000
Public Const LWA_ALPHA = &H2
Public x As Integer
To make a form Draggable by clicking:
VB Code:
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
Sub MoveObject(Obj As Object)
Const WM_NCLBUTTONDOWN = &HA1
Const HTCAPTION = 2
ReleaseCapture
SendMessage Obj.hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0
End Sub
Private Sub Label1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = vbLeftButton Then
MoveObject Me
End If
End Sub
How to fade a forms MENU bar:
VB Code:
Option Explicit
Dim r As Byte, g As Byte, b As Byte, flag As Byte, d(3) As Byte, cat As String
Private Const MIM_BACKGROUND As Long = &H2
Private Const MIM_APPLYTOSUBMENUS As Long = &H80000000
Private Type MENUINFO
cbSize As Long
fMask As Long
dwStyle As Long
cyMax As Long
hbrBack As Long
dwContextHelpID As Long
dwMenuData As Long
End Type
Private Declare Function DrawMenuBar Lib "user32" _
(ByVal hWnd As Long) As Long
Private Declare Function GetSubMenu Lib "user32" _
(ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function GetMenu Lib "user32" _
(ByVal hWnd As Long) As Long
Private Declare Function SetMenuInfo Lib "user32" _
(ByVal hMenu As Long, _
mi As MENUINFO) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" _
(ByVal crColor As Long) As Long
Private Sub Form_Load()
r = 255: g = 255: b = 255: flag = 0
End Sub
Function Disco()
If flag Then
r = DoIt(1, r)
g = DoIt(2, g)
b = DoIt(3, b)
flag = flag - 1
Else
r = Ran(1, r)
g = Ran(2, g)
b = Ran(3, b)
flag = 50
End If
End Function
Function DoIt(ByVal a As Byte, ByVal c As Byte)
If ((d(a) = 2 And c < 255) Or c = 0) Then
c = c + 1
d(a) = 2
Else
If ((d(a) = 1 And c) Or c = 255) Then
c = c - 1
d(a) = 1
End If
If a = 3 Then
If (d(1) + d(2) + d(3) = 0) Then flag = 1
End If
End If
DoIt = c
End Function
Function Ran(ByVal a As Byte, ByVal c As Byte)
If ((Rnd > 0.667 Or c = 0) And c < 255) Then
c = c + 1
d(a) = 2
ElseIf ((Rnd <= 0.5 Or c = 255) And c > 0) Then
c = c - 1
d(a) = 1
Else
d(a) = 0
End If
Ran = c
End Function
Private Sub Timer1_Timer()
Disco
Dim mi As MENUINFO
With mi
.cbSize = Len(mi)
.fMask = MIM_BACKGROUND
.hbrBack = CreateSolidBrush(RGB(r, g, b))
SetMenuInfo GetMenu(Me.hWnd), mi 'main menu bar
.fMask = MIM_BACKGROUND Or MIM_APPLYTOSUBMENUS
.hbrBack = CreateSolidBrush(RGB(r, g, b))
SetMenuInfo GetSubMenu(GetMenu(Me.hWnd), 0), mi 'File menu (item 0)
.hbrBack = CreateSolidBrush(RGB(r, g, b))
SetMenuInfo GetSubMenu(GetMenu(Me.hWnd), 1), mi 'Edit menu (item 1)
.hbrBack = CreateSolidBrush(RGB(r, g, b))
SetMenuInfo GetSubMenu(GetMenu(Me.hWnd), 2), mi 'Select menu (item 2)
End With
DrawMenuBar Me.hWnd
End Sub
Hope you all liked it..If so ill try and figure out some cool new ones. Enjoy!
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|
Reply With Quote