用VB实现QQ一样的菜单(半透明窗口)

Option   Explicit

' ''窗口半透明声明开始
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   Sub  Form_Load()
' '''''窗口半透明代码开始
     Dim  rtn  As   Long
    rtn  =  GetWindowLong(hwnd, GWL_EXSTYLE)
    rtn  =  rtn  Or  WS_EX_LAYERED
    SetWindowLong hwnd, GWL_EXSTYLE, rtn
    SetLayeredWindowAttributes hwnd,  0 ,  180 , LWA_ALPHA  '   透明度为 0--255 之间的数
' '''''窗口半透明代码结束
With  Me
.Width  =   1200   +   155
.Height  =   4860   +   355
.BorderStyle  =   3
.ScaleMode  =   1
.BackColor  =   & H80C0FF
.FillStyle  =   1
End   With

With  Picture1
.Width  =   1200   +   60
.Height  =   4860
End   With
Dim  i  As   Integer
For  i  =  Command1.Count  -   1   To   0  Step  - 1
With  Command1(i)
.Width  =   1200
.Height  =   300
.Top  =  Picture1.ScaleHeight  -   300   *  (Command1.Count  -  i)
.Left  =   0
.Caption  =   " 分组  "   &  i  +   1
End   With
Next  i
Command1( 0 ).Top  =   0
End Sub

Private   Sub  Command1_Click(Index  As   Integer )
Picture1.SetFocus
' 把焦点给Picture1是为了不让按钮出现难看的黑框
Dim  i  As   Integer
For  i  =   1   To  Index
Command1(i).Top  =   300   *  i
Next  i
For  i  =  Command1.Count  -   1   To  Index  +   1  Step  - 1
Command1(i).Top  =  Picture1.ScaleHeight  -   300   *  (Command1.Count  -  i)
Next  i
End Sub