參考如下：
新建壹標準EXE工程->在窗體上添加如下控件:
richTEXT1(超級文本框<部件Microsoft RichText Controls>),
command1(按鈕),
command2(按鈕),
INET1(INET控件<部件Microsoft Internet Transfer Controls>),
CommonDiaLog1(<部件Microsoft Common Dialog Controls>),
'窗體代碼
private sub command1_click()
richtext1.text=Inet1.openUrl("/")'打開對應網址的原代碼
end sub
private sub command2_click()
CommonDiaLog1.filtter="網頁文件(*.htm)|*.htm|網頁文件(*.html)|*.html"'設置欲保存文件的格式
CommonDiaLog1.showsave
richtext1.savefile CommonDiaLog1.filename,rtftext'保存richtext1的內容(即網頁源代碼)到指定位置.
msgbox"文件已經保存到" & CommonDiaLog1.filename
end sub
添加2個txet控件,壹個command(實現添加至收藏夾)
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)
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 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
Private Sub Command1_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)
End Sub
Private Sub Form_Load()
End Sub