調用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收藏並翻譯
'聯繫地址：[email protected]
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
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 = "CSDN.NET--中國最大的開發者網絡，爲開發人員和相關企業提供全面的信息服務和技術服務"
Text2.Text = "http://www.CSDN.net/"
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/CSDN.NET--中國最大的開發者網絡.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