modfaves.bas

使用vb程序开发的一个浏览器范例程序

End Function
Private Sub ListSubDirs(Path As String, parent As Long, parentDir As String, Optional IsRoot As Boolean = False)
    On Error Resume Next
    If Right(parentDir, 1) <> "\" Then parentDir = parentDir + "\"
    Dim Count, D() As String, i As Long, DirName As String, nSub() As Long, nPos As Long
    DirName = Dir(Path, 16)
    Do While DirName <> ""
        If DirName <> "." And DirName <> ".." Then
            If GetAttr(Path + DirName) = 16 Then 'a folder
                If (Count Mod 10) = 0 Then
                    ReDim Preserve D(Count + 10)
                End If
                Count = Count + 1
                D(Count) = DirName
            End If
        End If
        DirName = Dir
    Loop
    If IsRoot Then 'doing first folder so allow for the first thee items
        RootCount = Count + 3
        nPos = 3
    End If
    'these will be the menu handles of subfolders
    'we need to remember these so we can add the correct links to the correct menus
    'see ListFiles below
    ReDim nSub(1 To Count)
    
    For i = 1 To Count
        nPos = nPos + 1
        nSub(i) = AddSubMenu(parent, nPos, D(i)) 'create a menu(folder)
        If Not TV Is Nothing Then TV.Nodes.add parentDir, tvwChild, Path & D(i) & "\", D(i), 1, 2 'add a node to the treeview
        ListSubDirs Path & D(i) & "\", nSub(i), Path & D(i) & "\" 'recurse any subfolders
        ListFiles Path & D(i) & "\", nSub(i), Path & D(i) & "\", nPos 'add any files held within current folder
    Next
    DoEvents
End Sub
Private Sub ListFiles(Path As String, parent As Long, parentDir As String, Optional StartCnt As Long = 1)
    On Error Resume Next
    Dim Count As Long, D(), i, DirName As String
    DirName = Dir(Path, 6)
    Count = StartCnt
    Do While DirName <> ""
        If DirName <> "." And DirName <> ".." Then
            LinkURLColl.add Path + DirName 'remember location
            AddMenu parent, Count, LinkURLColl.Count + 1100, Left(DirName, Len(DirName) - 4) 'add file to correct menu (handle=parent)
            If Not TV Is Nothing Then TV.Nodes.add parentDir, tvwChild, Path & DirName, Left(DirName, Len(DirName) - 4), 3, 3
            Count = Count + 1
        End If
        DirName = Dir
    Loop
End Sub
Private Function AddSubMenu(mParent As Long, mCount As Long, mname As String) As Long
    lngNewSubMenu = CreatePopupMenu
    If Len(mname) > 49 Then mname = Left(mname, 47) + "..." 'shorten long captions
    Call InsertMenu(mParent, mCount, MF_STRING Or MF_BYPOSITION Or MF_POPUP, lngNewSubMenu, mname)
    AddSubMenu = lngNewSubMenu
End Function
Private Sub AddMenu(mParent As Long, mCount As Long, mID As Long, mname As String)
    If Len(mname) > 49 Then mname = Left(mname, 47) + "..." 'shorten long captions
    Call InsertMenu(mParent, mCount, MF_STRING Or MF_BYPOSITION, mID, mname)
End Sub
Public Sub RefreshFaves()
    Dim z As Long, ret As Long, mSmenu As Long
    Call SetWindowLong(ParentForm.hwnd, GWL_WNDPROC, gOldProc&)
    lngMenu& = GetMenu(ParentForm.hwnd)
    lngNewMenu = GetSubMenu(lngMenu&, 2)
    RemoveMenu lngMenu&, 4, MF_BYPOSITION Or MF_REMOVE 'kill the menu
    If Not TV Is Nothing Then
        TV.Nodes.Clear 'kill the treeview
        GetFaves ParentForm, TV 'reload
    Else
        GetFaves ParentForm
    End If
    DrawMenuBar ParentForm.hwnd 'refresh the form's menu bar
End Sub
Public Function BrowseForFolder(owner As Long) As String
    Dim lpIDList As Long 'show the dialog
    Dim sBuffer As String
    Dim tBrowseInfo As BrowseInfo
    With tBrowseInfo
        .pIDLRoot = 6 'use favorites folder as root
        .hwndOwner = owner
        .lpszTitle = lstrcat("Move to...", "")
        .ulFlags = BIF_RETURNONLYFSDIRS
        .lpfnCallback = GetAddressofFunction(AddressOf BrowseCallbackProc)
    End With
    lpIDList = SHBrowseForFolder(tBrowseInfo)
    If (lpIDList) Then
        sBuffer = Space(260)
        SHGetPathFromIDList lpIDList, sBuffer
        sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
        BrowseForFolder = sBuffer
    Else
        BrowseForFolder = ""
    End If
End Function
Private Function BrowseCallbackProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal lp As Long, ByVal pData As Long) As Long
    Select Case uMsg
      Case BFFM_INITIALIZED
            SetWindowText hwnd, "Favorites" 'put a caption on the dialog
    End Select
    BrowseCallbackProc = 0
End Function
Private Function GetAddressofFunction(add As Long) As Long
  GetAddressofFunction = add
End Function
'API file operations
Public Function MoveFave(sSource As String, sDestination As String) As Long
    On Error Resume Next
    sSource = sSource & Chr$(0) & Chr$(0)
    With SHFileOp
        .wFunc = 1
        .pFrom = sSource
        .pTo = sDestination
        .fFlags = FOF_NOCONFIRMATION Or FOF_SILENT
    End With
    MoveFave = SHFileOperation(SHFileOp)
End Function
Public Function RenameFave(sSource As String, sDestination As String) As Long
    On Error Resume Next
    sSource = sSource & Chr$(0) & Chr$(0)
    With SHFileOp
        .wFunc = 4
        .pFrom = sSource
        .pTo = sDestination
        .fFlags = FOF_NOCONFIRMATION Or FOF_RENAMEONCOLLISION Or FOF_SILENT
    End With
    RenameFave = SHFileOperation(SHFileOp)
End Function
Public Function DeleteFave(sSource As String) As Long
    On Error Resume Next
    sSource = sSource & Chr$(0) & Chr$(0)
    With SHFileOp
        .wFunc = 3
        .pFrom = sSource
        .fFlags = FOF_NOCONFIRMATION Or FOF_SILENT
    End With
    DeleteFave = SHFileOperation(SHFileOp)
End Function
Public Sub GetPropDlg(frm As Form, mfile As String)
    Dim Prop As SHELLEXECUTEINFO
    Dim R As Long
    With Prop
        .cbSize = Len(Prop)
        .fMask = &HC
        .hwnd = frm.hwnd
        .lpVerb = "properties"
        .lpFile = mfile
    End With
    R = ShellExecuteEx(Prop) 'show dialog
End Sub
Public Function RunMenu(mPath As String) As Long
    Dim temp As String, z As VbFileAttribute
    On Error GoTo woops
    If FileExists(mPath) Then
        Select Case LCase(ExtOnly(mPath))
            Case "url" 'navigate
                temp = ReadINI(mPath, "InternetShortcut", "URL")
                If ParentForm.Brow.LocationURL <> temp Then ParentForm.Brow.Navigate temp
            Case "lnk" 'run
                'this will run 99% of links
                'example - fails to execute a link to my dial-up connection
                ShellExecute 0&, vbNullString, mPath, vbNullString, vbNullString, vbNormalFocus
        End Select
    End If
woops:
    RunMenu = 0
End Function

Public Function OrgFaves() As Long
    On Error GoTo woops
    LockWindowUpdate ParentForm.hwnd
    DoOrganizeFavDlg ParentForm.hwnd, SpecialFolder(6) 'show dialog
    RefreshFaves
woops:
    LockWindowUpdate 0
    OrgFaves = 0
End Function

Public Function AddFaves()
    On Error GoTo woops
    LockWindowUpdate ParentForm.hwnd
    BrowDlg.AddFavorite ParentForm.Brow.LocationURL, ChangeExt(ParentForm.Brow.LocationName) 'show dialog
    RefreshFaves
woops:
    LockWindowUpdate 0
    AddFaves = 0
End Function