如何动态的生成象ie5的收藏夹的下拉菜单
编号：QA004028
建立日期: 2001年3月25日 最后修改日期：2001年3月25日
所属类别：
wanghu:
操作系统：win98
编程工具：vb6.0
问题：1.如何动态的生成菜单栏...(有图表的菜单栏)
2.就象ie5的收藏夹的下拉菜单
回答:
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
此问题由Xrh_Xlz回答。
| |
|
|
| |
|
|
