例子代码：添加项目到收藏夹

' 代码   Module1.bas   
  Option   Explicit   
    
  Public   Declare   Function   SHGetPathFromIDList   Lib    " shell32.dll "    Alias    " SHGetPathFromIDListA "    (ByVal   pidl   As   Long,   ByVal   pszPath   As   String)   As   Long   
  Public   Declare   Function   SHGetSpecialFolderLocation   Lib    " shell32.dll "    (ByVal   hwndOwner   As   Long,   ByVal   nFolder   As   Long,   pidl   As   Long)   As   Long   
  Public   Const   CSIDL_FAVORITES    =     & H6   
    
  Public   Function   GetSpecialPath(lHandle   As   Long,   CSIDL   As   Long)   As   String   
  On   Error   GoTo   ErrorHandle   
  Dim   lReturn   As   Long   
  Dim   sPath   As   String   
  Dim   lPIDL   As   Long   
  lReturn    =    SHGetSpecialFolderLocation(lHandle,   CSIDL,   lPIDL)   
  If   lReturn    =     0    Then   
      sPath    =    Space$( 512 )   
      lReturn    =    SHGetPathFromIDList(ByVal   lPIDL,   ByVal   sPath)   
      GetSpecialPath    =    Left$(sPath,   InStr(sPath,   Chr$( 0 ))    -     1 )   
      Exit   Function   
  End   If   
  ErrorHandle:   
      GetSpecialPath    =     ""    
      On   Error   GoTo    0    
  End   Function   
    
  Public   Sub   SendToFav(sName   As   String,   sURL   As   String,   lSender   As   Long)   
  Dim   sFav   As   String   
  Dim   iFreeFile   As   Integer   
  sFav    =    GetSpecialPath(lSender,   CSIDL_FAVORITES)   
  If   sFav    <>     ""    Then   
      iFreeFile    =    FreeFile   
      Open   sFav    &     " "   &   sName   &    " .URL "    For   Output   As   #iFreeFile   
          Print   #iFreeFile,    " [InternetShortcut] "     &    vbCrLf   
          Print   #iFreeFile,    " URL= "     &    sURL   
      Close   #iFreeFile   
  Else   
      Err.Raise    9999 ,   ,    " 无法获取收藏夹目录 "    
  End   If   
  End   Sub   
    
   ' 应用   
   ' Form1.frm   
   ' 添加两个正文框和一个命令按纽   
  Option   Explicit   
    
  Private   Sub   Command1_Click()   
  On   Error   GoTo   ErrorHandle   
  SendToFav   Text1,   Text2,   hWnd   
  ErrorHandle:   
      If   Err    <>     0    Then   MsgBox   Err.Description,   vbCritical   
  End   Sub