调用IE的收藏夹

调用IE的收藏夹（系统需要IE4以上版本）

 

Internet Explorer 库--shdocvw.dll包含了许多可以操纵IE收藏夹的API。其中的两个API是调用IE的“添加到收藏夹”和“整理收藏夹”对话框。下面的示例程序就是如何使用这两个对话框

。

“添加到收藏夹”的Dialog很像Windows的通用对话框中的SaveAs Dialog，它自身没有任何机能（不能创建或保存一个文件）。然而他却提供了一种机制，当用户创建并保存一个

internet的快捷方式时，可以让开发人员能够得到需要的“收藏夹”中的信息。因为它会接受到一个pidl参数，当调用SHGetSpecialFolderLocation函数时指定了CSIDL_FAVORITES，

就会返回用户“收藏夹”的pidl描述。再把它用作API中的一个成员，我们想要的“添加到收藏夹”对话框就会出现了。

“整理收藏夹”对话框可以提供我们创建创建文件夹、重命名文件夹和删除文件夹等功能。

代码：
新建标准EXE工程，加入3个Button（Command1-Command3），3个Text文本框（Text1-Text3）............

Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'40Star收藏并翻译
'联系地址：40Star@163.com
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Const MAX_PATH As Long = 260
Private Const ERROR_SUCCESS As Long = 0
Private Const S_OK As Long = 0
Private Const S_FALSE As Long = 1
Private Const SHGFP_TYPE_CURRENT As Long = &H0
Private Const SHGFP_TYPE_DEFAULT As Long = &H1
Const CSIDL_FAVORITES As Long = &H6

Private Declare Function DoAddToFavDlg Lib "shdocvw" _
  (ByVal hWnd As Long, _
   ByVal szPath As String, _
   ByVal nSizeOfPath As Long, _
   ByVal szTitle As String, _
   ByVal nSizeOfTitle As Long, _
   ByVal pidl As Long) As Long
  
Private Declare Function DoOrganizeFavDlg Lib "shdocvw" _
  (ByVal hWnd As Long, _
   ByVal lpszRootFolder As String) As Long

Private Declare Function SHGetFolderPath Lib "shfolder" _
   Alias "SHGetFolderPathA" _
  (ByVal hwndOwner As Long, _
   ByVal nFolder As Long, _
   ByVal hToken As Long, _
   ByVal dwReserved As Long, _
   ByVal lpszPath As String) As Long

Private Declare Function SHGetSpecialFolderLocation Lib "shell32" _
  (ByVal hwndOwner As Long, _
   ByVal nFolder As Long, _
   pidl As Long) As Long
  
Private Declare Function WritePrivateProfileString Lib "kernel32" _
   Alias "WritePrivateProfileStringA" _
  (ByVal lpSectionName As String, _
   ByVal lpKeyName As Any, _
   ByVal lpString As Any, _
   ByVal lpFileName As String) As Long
  
Private Declare Sub CoTaskMemFree Lib "ole32" _
   (ByVal pv As Long)

 

Private Sub Form_Load()

   Text1.Text = "youkuaiyun.com--中国最大的开发者网络，为开发人员和相关企业提供全面的信息服务和技术服务"
   Text2.Text = "http://www.youkuaiyun.com/"
   Text3.Text = ""
  
End Sub

Private Sub Command1_Click()
'调用“整理收藏夹”对话框
  Dim lpszRootFolder As String
  Dim success As Long
 
   lpszRootFolder = GetFolderPath(CSIDL_FAVORITES)
   success = DoOrganizeFavDlg(hWnd, lpszRootFolder)
  
End Sub

Private Sub Command2_Click()
'调用“添加到收藏夹”对话框
   Dim szTitle As String
   Dim sURL As String
   Dim sResult As String

  '指定添加到收藏夹后的快捷方式的名称
   szTitle = Text1.Text
  
  '指定添加到收藏夹后的快捷方式的URL
   sURL = Text2.Text
  
  '调用MakeFavouriteEntry函数，打开对话框
   sResult = MakeFavouriteEntry(szTitle, sURL)
  
   Text1.Text = szTitle
   Text2.Text = sURL
   Text3.Text = sResult

End Sub

Private Sub Command3_Click()

   Unload Me
  
End Sub

Private Function MakeFavouriteEntry(szTitle As String,sURL As String) As String

  '变量定义
   Dim success As Long
   Dim pos As Long
   Dim nSizeOfPath As Long
   Dim nSizeOfTitle As Long
   Dim pidl As Long
   Dim szPath As String
 
  '追加chr$(0)字符
   szTitle = szTitle & Chr$(0)
   nSizeOfTitle = Len(szTitle)
  
  '返回路径的字符串
   szPath = Space$(MAX_PATH) & Chr$(0)
   nSizeOfPath = Len(szPath)
  
  '得到用户“收藏夹”路径的PIDL (pointer to item identifier list)
  '成功后返回值为ERROR_SUCCESS
   If SHGetSpecialFolderLocation(hWnd, _
                                 CSIDL_FAVORITES, _
                                 pidl) = ERROR_SUCCESS Then
       
     '调用“添加到收藏夹”对话框
     'hwnd   =  本窗口的句柄
     'szPath =  所选择文件夹的绝对路径，包括文件名和所需的URL
     '                例如，在我的系统里就是C:/Documents and Settings/40Star/Favorites/youkuaiyun.com--中国最大的开发者网络.url
     'szTitle =   标题
     'pidl    =    PIDL 描述用户的收藏夹的信息
      success = DoAddToFavDlg(hWnd, _
                              szPath, nSizeOfPath, _
                              szTitle, nSizeOfTitle, _
                              pidl)

     '如果路径有效并指定了标题，而且用户选择了“确定”，success 返回 1
      If success = 1 Then
     
        '删除最后的Chr$(0)
         pos = InStr(szPath, Chr$(0))
         szPath = Left(szPath, pos - 1)
        
         pos = InStr(szTitle, Chr$(0))
         szTitle = Left(szTitle, pos - 1)
     
        '在Text中显示结果
         Text1.Text = szPath
         Text2.Text = szTitle
     
         Call ProfileSaveItem("InternetShortcut", "URL", sURL, szPath)
        
        '返回创建成功的路径
         MakeFavouriteEntry = szPath
     
      End If
     
     '清空PIDL
      Call CoTaskMemFree(pidl)

   End If

End Function

Public Sub ProfileSaveItem(lpSectionName As String, _
                           lpKeyName As String, _
                           lpValue As String, _
                           iniFile As String)

   Call WritePrivateProfileString(lpSectionName, lpKeyName, lpValue, iniFile)

End Sub

Private Function GetFolderPath(CSIDL As Long) As String

   Dim sPath As String
   Dim sTmp As String
   
   sPath = Space$(MAX_PATH)
  
   If SHGetFolderPath(Me.hWnd, _
                      CSIDL, _
                      0&, _
                      SHGFP_TYPE_CURRENT, _
                      sPath) = S_OK Then
                     
       GetFolderPath = Left$(sPath, InStr(sPath, Chr$(0)) - 1)
   End If
     
End Function