如何动态的生成象ie5的收藏夹的下拉菜单.txt

VB技巧问答10000例 VB技巧问答10000例

1. 
    Option Explicit 
    Public LastState As Integer 
    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_SYSCOMMAND = &H112 
    Private Const SC_MOVE = &HF010& 
    Private Const SC_RESTORE = &HF120& 
    Private Const SC_SIZE = &HF000& 
    ' 
    Public CountX As Integer 
    Public ShowX As Integer 
    Dim MyFile As String 
    Dim MyProx As String 
    Dim Fname As String 
    Dim AllText As String 
    Dim FileN As Integer 
    Dim hInst As Integer 
     
    Private Sub Form_Load() 
     Dim Ix As Integer 
     Dim Mx As Long 
     Dim Lx As Long 
     Dim Fs As New FileSystemObject 
     Dim Fd As Folder 
     Dim Fx As File 
     Dim MenuID As Long 
     Dim sHandle As Long 
     Dim Cx, Cy 
     Dim Nx, Rx 
     If Not Fs.FolderExists(App.Path + "\" + "MyTemp") Then 
     MkDir App.Path + "\" + "MyTemp" 
     End If 
     Fname = App.Path + "\" + "创 立 快 车 .xrh" 
     FileN = FreeFile 
     Mx = GetMenu(Me.hWnd) 
     sHandle = GetSubMenu(Mx, 0) 
     Ix = 1 
     If Fs.FileExists(Fname) Then 
     ListX.Clear 
     Open Fname For Input As #FileN 
     Do Until EOF(FileN) 
     Line Input #FileN, AllText$ 
     ListX.AddItem AllText$ 
     Loop 
     Close #FileN 
     If ListX.ListCount > 0 Then 
     Dim Icons As Integer 
     ListX.Clear 
     Open Fname For Input As #FileN 
     Do Until EOF(FileN) 
     Ix = Ix + 1 
     Input #FileN, MyProx, MyFile 
     ListX.AddItem MyFile 
     Icons = ExtractIcon(hInst, MyFile, -1) 
     IconOut 
     ImageListX.ListImages.Add , , LoadPicture(App.Path + "\" + "MyTemp\" + MyProx + ".bmp") 
     Load MyMenu(Ix) 
     MyMenu(Ix).Visible = True 
     MyMenu(Ix).Caption = MyProx 
     MenuID = GetMenuItemID(sHandle, Ix) 
     Lx = SetMenuItemBitmaps(sHandle, MenuID, MF_BITMAP, ImageListX.ListImages(Ix + 1).Picture, ImageListX.ListImages(Ix + 1).Picture) 
     Loop 
     Close #FileN 
     End If 
     End If 
     If Ix > 2 Then 
     Ix = Ix + 1 
     Load MyMenu(Ix) 
     MyMenu(Ix).Visible = True 
     MyMenu(Ix).Caption = "-" 
     End If 
     Ix = Ix + 1 
     Cx = PictureX.ScaleWidth \ 2 
     Cy = PictureX.ScaleHeight \ 2 
     If Cx < Cy Then 
     Nx = Cx 
     Else 
     Nx = Cy 
     End If 
     Randomize Second(Time) 
     PictureX.DrawWidth = 50 
     For Rx = 0 To Nx Step 50 
     PictureX.Circle (Cx, Cy), Rx, RGB(Rnd * 255, Rnd * 255, Rnd * 255) 
     Next Rx 
     SavePicture PictureX.Image, "MyTemp\MenuExit.bmp" 
     ImageListX.ListImages.Add , , LoadPicture("MyTemp\MenuExit.bmp") 
     Load MyMenu(Ix) 
     MyMenu(Ix).Visible = True 
     MyMenu(Ix).Caption = "返 回 系 统 " 
     If Ix > 2 Then 
     MenuID = GetMenuItemID(sHandle, Ix) 
     Lx = SetMenuItemBitmaps(sHandle, MenuID, MF_BITMAP, ImageListX.ListImages(Ix).Picture, ImageListX.ListImages(Ix).Picture) 
     Else 
     MenuID = GetMenuItemID(sHandle, Ix) 
     Lx = SetMenuItemBitmaps(sHandle, MenuID, MF_BITMAP, ImageListX.ListImages(Ix + 1).Picture, ImageListX.ListImages(Ix + 1).Picture) 
     End If 
     ' 
     If WindowState = vbMinimized Then 
     LastState = vbNormal 
     Else 
     LastState = WindowState 
     End If 
     AddToMyTool Me, MyTool 
     SetMyToolTip " ^!^ 我 的 工 具 ~o~ " 
     NOTI.cbSize = Len(NOTI) 
     NOTI.hWnd = PictureA(0).hWnd 
     NOTI.uID = 1& 
     NOTI.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE 
     NOTI.uCallbackMessage = WM_MOUSEMOVE 
     NOTI.hIcon = PictureA(0).Picture 
     NOTI.szTip = " ^!^ 我 的 工 具 ~o~ " + Chr$(0) 
     Shell_NotifyIcon NIM_ADD, NOTI 
     TimerX.Enabled = True 
     App.TaskVisible = False 
     CountX = CountX + 1 
    End Sub 
     
    Private Sub IconOut() 
     Dim FileLen As Integer 
     Dim Rx As Integer 
     Dim Cx As Integer 
     Dim Cy As Integer 
     Dim Nx As Integer 
     Dim IconX As Integer 
     Dim hIcon As Long 
     PictureY.AutoRedraw = True 
     PictureY.Cls 
     hIcon = ExtractIcon(0, MyFile, 0) 
     IconX = DrawIcon(PictureY.hdc, 0, 0, hIcon) 
     PictureY.AutoRedraw = False 
     Cx = PictureY.ScaleWidth \ 2 
     Cy = PictureY.ScaleHeight \ 2 
     If Cx < Cy Then 
     Nx = Cx 
     Else 
     Nx = Cy 
     End If 
     Randomize Second(Time) 
     PictureY.DrawWidth = 50 
     For Rx = 0 To Nx Step 50 
     PictureY.Circle (Cx, Cy), Rx, RGB(Rnd * 255, Rnd * 255, Rnd * 255) 
     Next Rx 
     SavePicture PictureY.Image, App.Path + "\" + "MyTemp\" + MyProx + ".bmp" 
    End Sub 
     
    Private Sub MyMenu_Click(Index As Integer) 
     Dim Fs As New FileSystemObject 
     If Fs.FolderExists("MyTemp") Then 
     Kill "MyTemp\*.*" 
     RmDir "MyTemp" 
     End If 
     Select Case Index 
     Case 0 Or 1 
     Exit Sub 
     Case 2 
     If ListX.ListCount = 0 Then 
     ShowX = 1 
     Unload Me 
     Else 
     MyProx = ListX.List(Index - 2) 
     WinExec MyProx, SW_RESTORE 
     ShowX = 1 
     Unload Me 
     End If 
     Case 1 + ListX.ListCount + 1 
     If ListX.ListCount > 0 Then 
     Exit Sub 
     Else 
     ShowX = 1 
     Unload Me 
     End If 
     Case Else 
     If ListX.ListCount > 0 Then 
     If Index = 0 Or Index = 1 Or Index = 1 + ListX.ListCount + 1 Then 
     Exit Sub 
     Else 
     If Index = 1 + ListX.ListCount + 2 Then 
     ShowX = 1 
     Unload Me 
     Else 
     MyProx = ListX.List(Index - 2) 
     WinExec MyProx, SW_RESTORE 
     ShowX = 1 
     Unload Me 
     End If 
     End If 
     Else 
     If Index = 0 Or Index = 1 Then 
     Exit Sub 
     Else 
     ShowX = 1 
     Unload Me 
     End If 
     End If 
     End Select 
    End Sub 
     
    Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 
     If Button = 2 Then 
     Me.PopupMenu MyTool 
     End If 
    End Sub 
     
    Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 
     If Button = 1 Then 
     Me.PopupMenu MyTool 
     End If 
    End Sub 
     
    Private Sub Form_Unload(Cancel As Integer) 
     RemoveFromMyTool 
    End Sub 
     
    Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) 
     TimerX.Enabled = False 
     NOTI.cbSize = Len(NOTI) 
     NOTI.hWnd = PictureA(0).hWnd 
     NOTI.uID = 1& 
     Shell_NotifyIcon NIM_DELETE, NOTI 
    End Sub 
     
    Private Sub PictureA_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single) 
     If X = 512 Then 
     Me.PopupMenu MyTool 
     End If 
    End Sub 
     
    Private Sub TimerX_Timer() 
     Static I As Long, Img As Long 
     NOTI.cbSize = Len(NOTI) 
     NOTI.hWnd = PictureA(0).hWnd 
     NOTI.uID = 1& 
     NOTI.uFlags = NIF_ICON 
     NOTI.hIcon = PictureA(I).Picture 
     Shell_NotifyIcon NIM_MODIFY, NOTI 
     TimerX.Enabled = True 
     I = I + 1 
     If I = 2 Then 
     I = 0 
     End If 
    End Sub 
    2. 
     If MyMenu.Count > 2 Then 
     For CountX = 2 To MyMenu.Count - 1 
     Unload MyMenu(CountX) 
     Next 
     End If 
     If ListB.ListCount > 0 Then 
     MyMenu(0).Caption = "我 的 菜 单 " 
     For CountX = 0 To ListB.ListCount - 1 
     Load MyMenu(CountX + 2) 
     MyMenu(CountX + 2).Visible = True 
     MyMenu(CountX + 2).Caption = ListB.List(CountX) 
     Next 
     End If 
<END>