home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / CODE_UPLOAD90468172000.psc / Favorites.bas < prev    next >
Encoding:
BASIC Source File  |  2000-08-11  |  13.5 KB  |  486 lines

  1. Attribute VB_Name = "Favorites"
  2. Option Explicit
  3. '//////////////////////////////////////////////////////
  4. '//
  5. '// THANKS TO Chris Shell for the Favorites code
  6. '// posted at http://Planet-Source-Code.com
  7. '//
  8. '// With minor revisions from me
  9. '// There is something not quite right with
  10. '// how the nodes are added to the tree,
  11. '// but I cant figure it out.
  12. '//
  13. '//////////////////////////////////////////////////////
  14.  
  15. '//////////////////////////////////////////////////////
  16. '// Favorites.bas
  17. '// Code for retieving IE Favorites
  18. '// Requires modCommon.bas
  19. Global FP As FILE_PARAMS
  20. Global Itm As Node
  21. Global favpath As String
  22. Global sLastFolder As String
  23. Global sRoot As String
  24. Global bSubItem As Boolean
  25. Global nCount As Long
  26. Global bCancel As Boolean
  27.  
  28. Public Sub GetFavorites()
  29. '///////////////////////////////////////////////////////////////
  30. 'FAVORITES LOAD
  31. '    sLastFolder = ""
  32.     'Load The Tree
  33.     frmBrowser.treeFavorites.Nodes.Clear
  34.     frmBrowser.treeFavorites.Refresh
  35.     
  36.     'retrieve the special folder path
  37.     'to the internet favorites
  38.     favpath = GetFolderPath(CSIDL_FAVORITES)
  39.     
  40.     'Initializes the Root Item in the TreeView
  41.     Call LoadTreeView("Internet Favorites", True, True)
  42.    
  43.     If Len(favpath) > 0 Then
  44.    
  45.      'set up the search UDT
  46.       With FP
  47.          .sFileRoot = favpath
  48.          .sFileNameExt = "*.url"
  49.          .bRecurse = True
  50.       End With
  51.       
  52.      'get the files
  53.       Call SearchForFilesArray(FP)
  54.       frmBrowser.treeFavorites.Nodes("R").Expanded = True
  55.     Else
  56.          
  57.        MsgBox " Could not locate favorites folder! " & _
  58.            "This program requires Microsoft's Internet " & _
  59.            "Explorer to be installed. Program will shutdown now!", _
  60.            vbCritical + vbOKOnly, "FavMenu Error"
  61.        End
  62.  
  63.     End If
  64. '///////////////////////////////////////////////////////////////
  65. End Sub
  66.  
  67. Public Function TrimNull(startstr As String) As String
  68.  
  69.   'returns the string up to the first
  70.   'null, if present, or the passed string
  71.    Dim pos As Integer
  72.    
  73.    pos = InStr(startstr, Chr$(0))
  74.    
  75.    If pos Then
  76.       TrimNull = Left$(startstr, pos - 1)
  77.       Exit Function
  78.    End If
  79.   
  80.    TrimNull = startstr
  81.   
  82. End Function
  83.  
  84. Private Function GetFileInformation(FP As FILE_PARAMS) As Long
  85.  
  86.   'local working variables
  87.    Dim WFD As WIN32_FIND_DATA
  88.    Dim hFile As Long
  89.    Dim pos As Long
  90.    Dim sPath As String
  91.    Dim sRoot As String
  92.    Dim sTmp As String
  93.    Dim sURL As String
  94.    Dim sShortcut As String
  95.    Dim itmX As ListItem
  96.          
  97.   'FP.sFileRoot (assigned to sRoot) contains
  98.   'the path to search.
  99.   '
  100.   'FP.sFileNameExt (assigned to sPath) contains
  101.   'the full path and filespec.
  102.    sRoot = QualifyPath(FP.sFileRoot)
  103.    sPath = sRoot & FP.sFileNameExt
  104.    
  105.   'obtain handle to the first filespec match
  106.    hFile = FindFirstFile(sPath, WFD)
  107.    
  108.   'if valid ...
  109.    If hFile <> INVALID_HANDLE_VALUE Then
  110.  
  111.       Do
  112.       
  113.         'remove trailing nulls
  114.          sTmp = TrimNull(WFD.cFileName)
  115.          
  116.         'Even though this routine uses filespecs,
  117.         '*.* is still valid and will cause the search
  118.         'to return folders as well as files, so a
  119.         'check against folders is still required.
  120.          If Not (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) _
  121.             = FILE_ATTRIBUTE_DIRECTORY Then
  122.            
  123.            'determine the link name by removing
  124.            'the .url extension
  125.             pos = InStr(sTmp, ".url")
  126.             
  127.             If pos > 0 Then
  128.             
  129.                 sShortcut = Left$(sTmp, pos - 1)
  130.            
  131.                 'extract the URL
  132.                 sURL = ProfileGetItem("InternetShortcut", "URL", "", sRoot & sTmp)
  133.                 If sLastFolder = "" Then
  134.                     'In The Root
  135.                     Call LoadTreeView(sShortcut, False, False, "R", sURL)
  136.                     'jrbCall LoadTreeView(sShortcut, False, False, "", sURL)
  137.                 Else
  138.                     Call LoadTreeView(sShortcut, False, False, sLastFolder, sURL)
  139.                 End If
  140.          
  141.             End If
  142.          
  143.          End If
  144.          
  145.       Loop While FindNextFile(hFile, WFD)
  146.       
  147.      'close the handle
  148.       hFile = FindClose(hFile)
  149.    
  150.    End If
  151.    
  152.   'clean up
  153.    Set itmX = Nothing
  154.    
  155. End Function
  156.  
  157. Private Function QualifyPath(sPath As String) As String
  158.  
  159.   'assures that a passed path ends in a slash
  160.    If Right$(sPath, 1) <> "\" Then
  161.          QualifyPath = sPath & "\"
  162.    Else: QualifyPath = sPath
  163.    End If
  164.       
  165. End Function
  166.  
  167. Public Function GetFolderPath(CSIDL As Long) As String
  168.  
  169.    Dim sPath As String
  170.    Dim sTmp As String
  171.   
  172.   'fill pidl with the specified folder item
  173.    sPath = Space$(MAX_LENGTH)
  174.    
  175.    If SHGetFolderPath(frmBrowser.hwnd, CSIDL, 0&, SHGFP_TYPE_CURRENT, sPath) = S_OK Then
  176.        sTmp = Left$(sPath, InStr(sPath, Chr$(0)) - 1)
  177.    End If
  178.    
  179.    GetFolderPath = sTmp
  180.    
  181. End Function
  182.  
  183. Public Function ProfileGetItem(lpSectionName As String, _
  184.                                lpKeyName As String, _
  185.                                defaultValue As String, _
  186.                                inifile As String) As String
  187.  
  188.     'Retrieves a value from an ini file corresponding
  189.     'to the section and key name passed.
  190.           
  191.      Dim success As Long
  192.      Dim nSize As Long
  193.      Dim ret As String
  194.     
  195.     'call the API with the parameters passed.
  196.     'The return value is the length of the string
  197.     'in ret, including the terminating null. If a
  198.     'default value was passed, and the section or
  199.     'key name are not in the file, that value is
  200.     'returned. If no default value was passed (""),
  201.     'then success will = 0 if not found.
  202.     
  203.     'Pad a string large enough to hold the data.
  204.      ret = Space$(2048)
  205.      nSize = Len(ret)
  206.      success = GetPrivateProfileString(lpSectionName, lpKeyName, _
  207.                                        defaultValue, ret, nSize, inifile)
  208.      
  209.      If success Then
  210.         ProfileGetItem = Left$(ret, success)
  211.      End If
  212.      
  213. End Function
  214.  
  215. Private Sub GetAllFilesSpecified(FP As FILE_PARAMS)
  216.  
  217.    Dim drvCount As Long
  218.    Dim sBuffer As String
  219.    Dim currDrive As String
  220.    
  221.    If FP.sFileRoot = "all fixed disks/partitions" Then
  222.    
  223.      'all drives
  224.    
  225.      'retrieve the available drives on the system
  226.       sBuffer = Space$(64)
  227.       drvCount = GetLogicalDriveStrings(Len(sBuffer), sBuffer)
  228.    
  229.      'drvCount returns the size of the drive string
  230.       If drvCount Then
  231.       
  232.         'strip off trailing nulls
  233.          sBuffer = Left$(sBuffer, drvCount)
  234.               
  235.         'search each drive for the file
  236.          Do Until sBuffer = ""
  237.    
  238.            'strip off one drive item from sBuffer
  239.             FP.sFileRoot = StripItem(sBuffer)
  240.    
  241.            'just search the local file system
  242.             If GetDriveType(FP.sFileRoot) = DRIVE_FIXED Then
  243.             
  244.               'this may take a while, so update the
  245.               'display when the search path changes
  246.               'Text2.Text = "Working ... searching drive " & FP.sFileRoot
  247.                
  248.                DoEvents
  249.                If bCancel Then Exit Do
  250.                
  251.                Call SearchForFilesArray(FP)
  252.                
  253.               'Update the display count
  254.                'Text3.Text = Format$(nCount, sFileSoFar)
  255.                'Text3.Refresh
  256.                
  257.             End If
  258.          
  259.          Loop
  260.       
  261.       End If
  262.       
  263.    Else
  264.          
  265.        Call SearchForFilesArray(FP)
  266.        
  267.    End If
  268.  
  269. End Sub
  270.  
  271. Private Sub SearchForFilesArray(FP As FILE_PARAMS)
  272.  
  273.   'local working variables
  274.    Dim WFD As WIN32_FIND_DATA
  275.    Dim hFile As Long
  276.    Dim sPath As String
  277.    Dim sRoot As String
  278.    Dim sTmp As String
  279.       
  280.   'this routine is primarily interested in the
  281.   'directories, so the file type must be *.*
  282.    sRoot = QualifyPath(FP.sFileRoot)
  283.    sPath = sRoot & "*.*"
  284.    
  285.   'obtain handle to the first match
  286.    hFile = FindFirstFile(sPath, WFD)
  287.    
  288.   'if valid ...
  289.    If hFile <> INVALID_HANDLE_VALUE Then
  290.    
  291.      'GetFileInformation function returns the number,
  292.      'of files matching the filespec (FP.sFileNameExt)
  293.      'in the passed folder.
  294.       Call GetFileInformation(FP)
  295.  
  296.       Do
  297.       
  298.         'if the returned item is a folder...
  299.          If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) Then
  300.             
  301.            'remove trailing nulls
  302.             sTmp = TrimNull(WFD.cFileName)
  303.             
  304.            'and if the folder is not the default
  305.            'self and parent folders...
  306.             If sTmp <> "." And sTmp <> ".." Then
  307.             
  308.               
  309.               'get the file
  310.                FP.sFileRoot = sRoot & sTmp
  311.               
  312.               If InRoot(sTmp) Then
  313.                 Call LoadTreeView(sTmp, True, False)
  314.                 sLastFolder = sTmp
  315.                   
  316.               Else
  317.                 Call LoadTreeView(sTmp, True, False, sLastFolder)
  318.                 sLastFolder = sTmp
  319.               End If
  320.               
  321.               'This next If..Then just prevents adding extra
  322.               'lines and unneeded paths to the array when a
  323.               'file search is performed for a specific file type
  324.                If FP.sFileNameExt = "*.*" Then
  325.                
  326.                  'Depending on the purpose, you may want to
  327.                  'exclude the next 4 optional lines.
  328.                  'The first two lines adds a blank entry
  329.                  'to the array as a separator between new
  330.                  'directories in the output file. The last
  331.                  'two add the directory name alone, before
  332.                  'listing the files underneath. These four
  333.                  'lines can be optionally commented out).
  334.                  'Obviously, these extra entries will skew
  335.                  'the actual file counts.
  336.                   'nCount = nCount + 1
  337.                   'sAllFiles(nCount) = ""
  338. '                  nCount = nCount + 1
  339. '
  340. '                  sLastFolder = FP.sFileRoot
  341. '                  sAllFiles(nCount) = FP.sFileRoot
  342.                   
  343.                   
  344.                End If
  345.                
  346.               'call again
  347.                Call SearchForFilesArray(FP)
  348.             
  349.             End If
  350.                
  351.             
  352.          End If
  353.          
  354.      'continue looping until FindNextFile returns
  355.      '0 (no more matches)
  356.       Loop While FindNextFile(hFile, WFD)
  357.       
  358.      'close the find handle
  359.       hFile = FindClose(hFile)
  360.    
  361.    End If
  362.    
  363. End Sub
  364.  
  365. Function StripItem(startStrg As String) As String
  366.  
  367.   'Take a string separated by Chr(0)'s, and split off 1 item, and
  368.   'shorten the string so that the next item is ready for removal.
  369.    Dim pos As Integer
  370.  
  371.    pos = InStr(startStrg, Chr$(0))
  372.  
  373.    If pos Then
  374.       StripItem = Mid(startStrg, 1, pos - 1)
  375.       startStrg = Mid(startStrg, pos + 1, Len(startStrg))
  376.    End If
  377.  
  378. End Function
  379.  
  380. Private Sub GetSystemDrives(ctl As ComboBox)
  381.  
  382.    Dim drvCount As Long
  383.    Dim sBuffer As String
  384.    Dim currDrive As String
  385.        
  386.   'Retrieve the available drives on the system.
  387.   'The string is padded with enough room to hold
  388.   'the drives, nulls and final terminating null.
  389.    sBuffer = Space$(105)
  390.    drvCount = GetLogicalDriveStrings(Len(sBuffer), sBuffer)
  391.    
  392.   'drvCount returns the size of the drive string
  393.    If drvCount Then
  394.    
  395.      'strip off trailing nulls
  396.       sBuffer = Left$(sBuffer, drvCount)
  397.            
  398.      'search each drive for the file
  399.       Do Until sBuffer = ""
  400.  
  401.         'strip off one drive item from sBuffer
  402.          currDrive = StripItem(sBuffer)
  403.  
  404.         'just search the local file system
  405.          If GetDriveType(currDrive) = DRIVE_FIXED Then
  406.          
  407.             ctl.AddItem Left$(currDrive, 2)
  408.             
  409.          End If
  410.       
  411.       Loop
  412.       
  413.    End If
  414.  
  415. End Sub
  416.    
  417. Private Function GetFolderName(ByVal sPath As String) As String
  418. Dim length As Long
  419. Dim xPos As Long
  420. Dim sTemp As String
  421.  
  422.     GetFolderName = ""
  423.  
  424.     length = Len(sPath)
  425.     xPos = length
  426.     
  427.     If Left(sPath, length) = "\" Then
  428.         sPath = Left(sPath, (length - 1))
  429.     End If
  430.     
  431.     Do Until xPos = 0
  432.         xPos = xPos - 1
  433.         
  434.         If Mid$(sPath, xPos, 1) = "\" Then
  435.             GetFolderName = Mid(sPath, (xPos - 1))
  436.             Exit Do
  437.         End If
  438.         
  439.     Loop
  440.     
  441. End Function
  442.  
  443. Private Sub LoadTreeView(ItemName As String, bFolder As Boolean, bRoot As Boolean, _
  444.     Optional SubItem As String, Optional sURL As String)
  445.         
  446.     If bRoot Then
  447.         Set Itm = frmBrowser.treeFavorites.Nodes.Add(, , "R", ItemName, 4) '#image
  448.         Itm.Tag = FP.sFileRoot
  449.         Exit Sub
  450.     End If
  451.     
  452.     If bFolder Then
  453.         If Len(SubItem) > 0 Then
  454.             Set Itm = frmBrowser.treeFavorites.Nodes.Add(SubItem, tvwChild, ItemName, ItemName, 1, 2) '#image
  455.             
  456.         Else
  457.             Set Itm = frmBrowser.treeFavorites.Nodes.Add("R", tvwChild, ItemName, ItemName, 1, 2) '#image
  458.             
  459.         End If
  460.         
  461.         Itm.Tag = FP.sFileRoot
  462.         
  463.     Else
  464.         If SubItem <> "VF Corporation" Then
  465.             Set Itm = frmBrowser.treeFavorites.Nodes.Add(SubItem, tvwChild, ItemName & "_URL", ItemName, 8) '#image
  466.             Itm.Tag = sURL
  467.         End If
  468.         
  469.     End If
  470.     
  471. End Sub
  472.  
  473. Private Function InRoot(ByVal sPath As String) As Boolean
  474. Dim sTmp As String
  475.  
  476.     InRoot = False
  477.     
  478.     sTmp = favpath & "\" & sPath
  479.     
  480.     If Dir(sTmp, vbDirectory) <> "" Then
  481.         InRoot = True
  482.     End If
  483.     
  484. End Function
  485.  
  486.