调用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收藏并翻译
´联系地址：
´´´´´´´´´´´´´´´´´´´´´´´´´´´´´´´´´´´´´´´´´´´´´´´´´´´´´´´´´´´´´´´
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 = ""
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
文章来源于领测软件测试网 https://www.ltesting.net/
