导入ie收藏夹.bas

来自「个人VB学习源码精选,自己学习时的一些编程小程序,希望对大家有帮助」· BAS 代码 · 共 44 行

Attribute VB_Name = "Module1"
Public Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Public Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Public Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Public Const REG_SZ = 1
Public Const HKEY_CURRENT_USER = &H80000001
Public Function GetFavoritesPath() As String
    Dim KeyValue As String
    Dim KeyID As Long
    Dim SubKey As String
    Dim BufferSize As Long
    Dim Ret As Long
    Ret = RegCreateKey(HKEY_CURRENT_USER, "Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders", KeyID)
    SubKey = "Favorites"    '获取注册表一个项目的值
    Ret = RegQueryValueEx(KeyID, SubKey, 0&, REG_SZ, 0&, BufferSize)
    KeyValue = String(BufferSize - 1, " ")
    Ret = RegQueryValueEx(KeyID, SubKey, 0&, REG_SZ, ByVal KeyValue, BufferSize)
    GetFavoritesPath = KeyValue
End Function
Public Function GetINI(fName As String, sSection As String, KeyWord As String) As String
    Dim sResult As String * 128
    Dim r As Long
    r = GetPrivateProfileString(sSection, KeyWord, "", sResult, 128, fName)
    GetINI = Left(sResult, r)
End Function
Public Sub ImportFavorites(fd As Folder, Lindex As Long)
    Dim sfd As Folder
    Dim f As File
    Dim strLink
    For Each f In fd.Files
        If UCase(f.Name) Like "*.URL" Then
            strLink = GetINI(f.Path, "InternetShortcut", "URL")
            If strLink <> "" Then
                Form1!ListView1.ListItems.Add Lindex, , Left(f.Name, Len(f.Name) - 4)
                Form1!ListView1.ListItems(Lindex).SubItems(1) = strLink
                Lindex = Lindex + 1
            End If
        End If
    Next
    For Each sfd In fd.SubFolders
        ImportFavorites sfd, Lindex
    Next
End Sub