Cool Effects For your Form:

[|2eM!x]

Have your form change colors nicely without flickering:

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:

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:

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:

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:

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!

[|2eM!x]

How to change the menu color:

Option Explicit
 
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 Command1_Click()
Dim mi As MENUINFO
   
    With mi
        .cbSize = Len(mi)
        
        .fMask = MIM_BACKGROUND
        .hbrBack = CreateSolidBrush(RGB(244, 147, 8))
        SetMenuInfo GetMenu(Me.hWnd), mi  'main menu bar
                .fMask = MIM_BACKGROUND Or MIM_APPLYTOSUBMENUS
        .hbrBack = CreateSolidBrush(RGB(244, 147, 8))
        SetMenuInfo GetSubMenu(GetMenu(Me.hWnd), 0), mi 'File menu (item 0)
                .hbrBack = CreateSolidBrush(RGB(244, 147, 8))
        SetMenuInfo GetSubMenu(GetMenu(Me.hWnd), 1), mi 'Edit menu (item 1)
                .hbrBack = CreateSolidBrush(RGB(244, 147, 8))
        SetMenuInfo GetSubMenu(GetMenu(Me.hWnd), 2), mi 'Select menu (item 2)
            End With
        DrawMenuBar Me.hWnd
 
End Sub

[|2eM!x]

How to make your form bounce off all the walls(Not easy to explain):
set timer interval to 1 or whatever

Option Explicit
 
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
    Private Const SPI_GETWORKAREA = 48
 
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
    End Type
    Dim x As Integer, WindowRect As RECT, SetPos As Integer, y As Integer, z As Integer
 
Private Sub Form_Load()
x = 0
SetPos = 1
End Sub
 
Private Sub Timer1_Timer()
SystemParametersInfo SPI_GETWORKAREA, 0, WindowRect, 0
Select Case SetPos
    Case 1
    x = x + 20
    y = y + 20
            Form1.Top = WindowRect.Top * Screen.TwipsPerPixelY + y '+ Form1.Height
            Form1.Left = WindowRect.Left * Screen.TwipsPerPixelX + x  ' + Form1.Width
                If Form1.Top >= WindowRect.Bottom * Screen.TwipsPerPixelY - Form1.Height Then SetPos = 2
                If Form1.Left >= WindowRect.Right * Screen.TwipsPerPixelX - Form1.Width Then SetPos = 4
    Case 2
    x = x + 20
    y = y - 20
            Form1.Top = WindowRect.Top * Screen.TwipsPerPixelY + y
            Form1.Left = WindowRect.Left * Screen.TwipsPerPixelX + x
                If Form1.Top <= WindowRect.Top * Screen.TwipsPerPixelY Then SetPos = 1
                If Form1.Left >= WindowRect.Right * Screen.TwipsPerPixelX - Form1.Width Then SetPos = 3
    Case 3
    x = x - 20
    y = y - 20
            Form1.Top = WindowRect.Top * Screen.TwipsPerPixelY + y
            Form1.Left = WindowRect.Left * Screen.TwipsPerPixelX + x
                If Form1.Top <= WindowRect.Top * Screen.TwipsPerPixelY Then SetPos = 4
                If Form1.Left <= WindowRect.Left * Screen.TwipsPerPixelX Then SetPos = 2
    Case 4
    x = x - 20
    y = y + 20
           Form1.Top = WindowRect.Top * Screen.TwipsPerPixelY + y
           Form1.Left = WindowRect.Left * Screen.TwipsPerPixelX + x
                If Form1.Left <= WindowRect.Left * Screen.TwipsPerPixelX Then SetPos = 1
                If Form1.Top >= WindowRect.Bottom * Screen.TwipsPerPixelY - Form1.Height Then SetPos = 3
    End Select
    Text1.Text = SetPos
End Sub

[techgnome]

Hey, cool stuff there. Ever think about rolling that into a DLL and redisting it that way?

Tg

[|2eM!x]

i dunno how to make dlls, plus isnt it better to have it open source..then you can add it inside your form yourself without an extra dll hangin around..

--hope you got my point lol, that was kinda confusing

[asgsoft]

how can i add a picture next to a menu text

[manavo11]

Not easily... You need to create owner drawn menus...

http://www.elitevb.com/content/01,0009,01/

[|2eM!x]

thanks manavo, thats pretty sweet

[Madboy]

I wish people gave Delphi a try, i mean you can alpha blend forms and do all the above with only around 8 lines of code. Especially since Delphi augments windows API meaning you dont need to declare everything.

[|2eM!x]

I couldnt do delphi because it just doesnt make sense...like

Try;

Begin;

that kinda stuff just dont make sense to me

[Madboy]

its simple, i was baffled at first but after 2 weeks i felt like a pro its just like if..else etc. for example:

try
Text1.Text:= 'Hello World'
except on exception do
ShowMessage('Error displaying text')
end;

the code is basically telling the compiler that if displaying Hello World fails somehow, then the messagebox error is shown. You only use Try..except..and finally for two reasons.

1) Except > is used for error handling
2) Finally > makes sure your app does the required code

Delphi includes all its uses ready for you to add, so instead of calling all the Windows API to access say, the registry. Just by adding:

Uses..Registry;

you have full access to the registry. In one line of code, pretty simple ey, production seems much more faster in Delphi too. I started out in VB like many others, and at the time i thought it was the god in RAD development. But until you actually give Delphi a weeks tryout, you dont know what your missing. You can create simple applications without the need for shipping external dll's and runtime libraries, you can choose whether to include it in the exe, thus creating a workable standalone exe on ANY computer. Simple things make a huge difference in Delphi, i mean in VB you need code or external libraries to add icons or office XP style menus right, in Delphi its done for you. Just browse and select!

Why Microsoft didnt add basic features like this i dont know, all i do know though is Delphi takes away the chores of RAD, so you can spend more time having fun with your projects.

Put it this way, i produce more and better projects in Delphi then i could of ever imagined in VB!

[wrack]

I wish people gave Delphi a try, i mean you can alpha blend forms and do all the above with only around 8 lines of code. Especially since Delphi augments windows API meaning you dont need to declare everything.

Thank you :2 thumbs up:

Delphi kicks ass of VB6 any time of the day, any day of the week, any week of the year...

[wrack]

I couldnt do delphi because it just doesnt make sense...like

Try;

Begin;

that kinda stuff just dont make sense to me

it's pascal syntex and besides Delphi is pure OO while everyone knows VB is not.

[paralinx]

I love these, is there anyway to make a timer's interval shorter than just 1? because the form bouncing off walls would be killer if it were faster

[|2eM!x]

just shove it in a do loop or something instead