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 = "VBnet - The Dev Resource Centre"
   Text2.Text = "http://vbnet.mvps.org/"
   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

  'assign a title to the url. This is the
  'name that appears under Favourites
   szTitle = Text1.Text
   
  'assign the url. This is the
  'value saved to the Favourite file.
   sURL = Text2.Text
   
  'call the Make routine, returning the
  'file created as a success
   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

  'working variables
   Dim success As Long
   Dim pos As Long
   Dim nSizeOfPath As Long
   Dim nSizeOfTitle As Long
   Dim pidl As Long
   Dim szPath As String
  
  'set up the szTitle size, appending a chr$(0)
   szTitle = szTitle & Chr$(0)
   nSizeOfTitle = Len(szTitle)
   
  'pad a string for the return path
   szPath = Space$(MAX_PATH) & Chr$(0)
   nSizeOfPath = Len(szPath)
   
  'get the PIDL (pointer to item identifier list)
  'of the user's Favourites path.
  'If successful, the return value is ERROR_SUCCESS
   If SHGetSpecialFolderLocation(hWnd, _
                                 CSIDL_FAVORITES, _
                                 pidl) = ERROR_SUCCESS Then
        
     'call the Add to Favourites dialog.
     'hwnd   =  the owner of the dialog, in this case our form.
     'szPath =  the absolute path returned to the selected folder,
     '          including the full file name appended, and the
     '          requisite .url extension. For example, on my system,
     '          using the Title specified above, and saving the file
     '          to the root Favourites folder, the szPath returned is:
     '          C:\WINNT\Profiles\birchr\Favorites\VBnet Res Centre.url
     'szTitle = the title (Favourite name) for the URL
     'pidl    = the PIDL representing the user's Favourites folder
      success = DoAddToFavDlg(hWnd, _
                              szPath, nSizeOfPath, _
                              szTitle, nSizeOfTitle, _
                              pidl)

     'if a valid file path and title was specified,
     'and the user pressed OK, success will = 1
      If success = 1 Then
      
        'remove trailing nulls
         pos = InStr(szPath, Chr$(0))
         szPath = Left(szPath, pos - 1)
         
         pos = InStr(szTitle, Chr$(0))
         szTitle = Left(szTitle, pos - 1)
      
        'show the results in the text boxes
         Text1.Text = szPath
         Text2.Text = szTitle
      
        'a little tom-foolery. Since a favourite link
        'is nothing more than an ini file entry, we can
        'use the WritePrivateProfileString API to create
        'the Favourite entry! The 'ini file name' will
        'be the szPath returned value from the
        'DoAddToFavDlg call, and the value saved to
        'the file will be the URL passed to this procedure
         Call ProfileSaveItem("InternetShortcut", "URL", sURL, szPath)
         
        'return the path/file created as a measure of success
         MakeFavouriteEntry = szPath
      
      End If
      
     'clean up by freeing the PIDL
      Call CoTaskMemFree(pidl)

   End If

End Function


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

  'This function saves the passed value to the file,
  'under the section and key name specified.
  'If the ini file does not exist, it is created.
  'If the section does not exist, it is created.
  'If the key name does not exist, it is created.
  'If the key name exists, its value is replaced.
   
   Call WritePrivateProfileString(lpSectionName, lpKeyName, lpValue, iniFile)

End Sub


Private Function GetFolderPath(CSIDL As Long) As String

   Dim sPath As String
   Dim sTmp As String
    
  'fill pidl with the specified folder item
   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