form1.frm

variant code in this rar zipped package

VERSION 5.00
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "COMCTL32.OCX"
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   4245
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   7050
   LinkTopic       =   "Form1"
   ScaleHeight     =   4245
   ScaleWidth      =   7050
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton Command2 
      Caption         =   "关 闭"
      Height          =   375
      Left            =   4200
      TabIndex        =   2
      Top             =   3720
      Width           =   855
   End
   Begin VB.CommandButton Command1 
      Caption         =   "取得收藏夹内容"
      Height          =   375
      Left            =   1080
      TabIndex        =   1
      Top             =   3720
      Width           =   1815
   End
   Begin ComctlLib.ListView ListView1 
      Height          =   3255
      Left            =   120
      TabIndex        =   0
      Top             =   240
      Width           =   6735
      _ExtentX        =   11880
      _ExtentY        =   5741
      LabelWrap       =   -1  'True
      HideSelection   =   -1  'True
      _Version        =   327682
      ForeColor       =   -2147483640
      BackColor       =   -2147483643
      BorderStyle     =   1
      Appearance      =   1
      NumItems        =   0
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

     
Private Function SearchForFiles(FP As FILE_PARAMS) As Double

  '定义工作变量
   Dim WFD As WIN32_FIND_DATA
   Dim hFile As Long
   Dim nSize As Long
   Dim sPath As String
   Dim sRoot As String
   Dim sTmp As String
      
   sRoot = QualifyPath(FP.sFileRoot)
   sPath = sRoot & "*.*"
  '取得搜索句柄
   hFile = FindFirstFile(sPath, WFD)
  '
   If hFile <> INVALID_HANDLE_VALUE Then
   
     '获取文件信息
   
      Call GetFileInformation(FP)

      Do
      
        '如果返回的是文件夹
         If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) Then
            
           '..and the Recurse flag was specified
            If FP.bRecurse Then
            
              '去除空格
               sTmp = TrimNull(WFD.cFileName)
               
              'and if the folder is not the default
              'self and parent folders...
                If sTmp <> "." And sTmp <> ".." Then
               
               '这个文件夹里可能包含其他子文件夹
               '继续取得子文件夹里的文件信息
                 FP.sFileRoot = sRoot & sTmp
                 Call SearchForFiles(FP)
                End If
            End If
            
         End If
         
     '通过循环取得文件信息 直到获取到所有文件信息
       Loop While FindNextFile(hFile, WFD)
      
     '用FindClose函数关闭这个句柄
      hFile = FindClose(hFile)
   
   End If
   
End Function


Public Function TrimNull(startstr As String) As String

  'returns the string up to the first
  'null, if present, or the passed string
   Dim pos As Integer
   pos = InStr(startstr, Chr$(0))
   
   If pos Then
      TrimNull = Left$(startstr, pos - 1)
      Exit Function
   End If
   TrimNull = startstr
End Function


Private Function GetFileInformation(FP As FILE_PARAMS) As Long

   Dim WFD As WIN32_FIND_DATA
   Dim hFile As Long
   Dim pos As Long
   Dim sPath As String
   Dim sRoot As String
   Dim sTmp As String
   Dim sURL As String
   Dim sShortcut As String
   Dim itmX As ListItem
      
  'FP.sFileRoot (assigned to sRoot) contains
  'the path to search.
  '
  'FP.sFileNameExt (assigned to sPath) contains
  'the full path and filespec.
   sRoot = QualifyPath(FP.sFileRoot)
   sPath = sRoot & FP.sFileNameExt
   
  '获得文件句柄
   hFile = FindFirstFile(sPath, WFD)
   If hFile <> INVALID_HANDLE_VALUE Then

      Do
          sTmp = TrimNull(WFD.cFileName)
         
        'Even though this routine uses filespecs,
        '*.* is still valid and will cause the search
        'to return folders as well as files, so a
        'check against folders is still required.
         If Not (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) _
            = FILE_ATTRIBUTE_DIRECTORY Then
           
           'determine the link name by removing
           'the .url extension
            pos = InStr(sTmp, ".url")
            
            If pos > 0 Then
            sShortcut = Left$(sTmp, pos - 1)
           'extract the URL
           sURL = ProfileGetItem("InternetShortcut", "URL", "", sRoot & sTmp)
            
              '添加到listview
               Set itmX = ListView1.ListItems.Add(, , sShortcut)
               itmX.SubItems(1) = sURL
         
            End If
            
         End If
         
      Loop While FindNextFile(hFile, WFD)
      
     'close the handle
      hFile = FindClose(hFile)
   
   End If
   
End Function


Private Function QualifyPath(sPath As String) As String

  'assures that a passed path ends in a slash
   If Right$(sPath, 1) <> "\" Then
         QualifyPath = sPath & "\"
   Else: QualifyPath = sPath
   End If
      
End Function
Private Function GetFolderPath(CSIDL As Long) As String

   Dim sPath As String
   Dim sTmp As String
  
  'fill pidl with the specified folder item
   sPath = Space$(MAX_LENGTH)
   
   If SHGetFolderPath(Me.hWnd, CSIDL, 0&, SHGFP_TYPE_CURRENT, sPath) = S_OK Then
       sTmp = Left$(sPath, InStr(sPath, Chr$(0)) - 1)
   End If
   
   GetFolderPath = sTmp
   
End Function
Public Function ProfileGetItem(lpSectionName As String, lpKeyName As String, _
                               defaultValue As String, _
                               inifile As String) As String
'读取ini文件
   Dim success As Long
   Dim nSize As Long
   Dim ret As String
   ret = Space$(2048)
   nSize = Len(ret)
   success = GetPrivateProfileString(lpSectionName, lpKeyName, _
                                     defaultValue, ret, nSize, inifile)
   
   If success Then
      ProfileGetItem = Left$(ret, success)
   End If
   
End Function
Private Sub Command1_Click()
Dim FP As FILE_PARAMS
   Dim favPath As String
  '从 收藏夹的文件夹中 重新得到文件路径
   favPath = GetFolderPath(CSIDL_FAVORITES)
   If Len(favPath) > 0 Then
   'set up the search UDT
      With FP
         .sFileRoot = favPath
         .sFileNameExt = "*.url"
         .bRecurse = True
      End With
       '取得文件
      Call SearchForFiles(FP)
    End If
End Sub

Private Sub Command2_Click()
Unload Me
End Sub

Private Sub Form_Load()
With ListView1
      .ColumnHeaders.Add 1, , "网名"
      .ColumnHeaders(1).Width = (ListView1.Width \ 2) - 200
      .ColumnHeaders.Add 2, , "网址"
      .ColumnHeaders(2).Width = (ListView1.Width \ 2) - 200
      .View = lvwReport
   End With
End Sub

Private Sub ListView1_ColumnClick(ByVal ColumnHeader As ComctlLib.ColumnHeader)
'确定ListView中各项顺序
   ListView1.SortKey = ColumnHeader.Index - 1
   ListView1.SortOrder = Abs(ListView1.SortOrder = 0)
   ListView1.Sorted = True
End Sub