VBA Tipp: Website in die Favoritenliste des MS Internet Explorers eintragen

Aus DBWiki
Wechseln zu: Navigation, Suche

Aufgabenstellung

Ich möchte eine Website in die Favoriten des Microsoft Internet Explorers eintragen.

Lösung

Das geht so:

Option Explicit
 
Public Const CSIDL_FAVORITES As Long = &H6
 
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
   Alias "SHGetPathFromIDListA" ( _
   ByVal pidl As Long, _
   ByVal pszPath As String) As Long
 
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" ( _
   ByVal hwndOwner As Long, _
   ByVal nFolder As Long, _
   pidl As Long) As Long
 
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
 
 
Public Function AddFavorite(SiteName As String, Url As String) As Boolean
 
   'Favoriten für IE 4 or 5 hinzufügen
 
   'Parameter:
   'SiteName  String  Name der Website
   'Url       String  URL der Website
   'Rückgabewert:
   '                  True = erfolgreich
   '                  False = sonst
 
   Dim pidl       As Long
   Dim psFullPath As String
   Dim iFile      As Integer
 
   On Error GoTo Er
 
   iFile = FreeFile()
   psFullPath = Space$(255)
 
   If SHGetSpecialFolderLocation(0, CSIDL_FAVORITES, pidl) = 0 Then
      If pidl Then
         If SHGetPathFromIDList(pidl, psFullPath) Then
            psFullPath = TrimAll(psFullPath)
            If Right$(psFullPath, 1) <> "\" Then psFullPath = psFullPath & "\"
            psFullPath = psFullPath & SiteName & ".URL"
            Open psFullPath For Output As iFile
            Print #iFile, "[InternetShortcut]"
            Print #iFile, "URL=" & Url
            Close iFile
         End If
         CoTaskMemFree pidl
         AddFavorite = True
      End If
   End If
 
Er:
End Function
 
Private Function TrimAll(ByVal Text As String) As String
 
   Dim i As Long
 
   For i = 1 To Len(Text)
      If Asc(Mid$(Text, i, 1)) > 32 Then
         Text = Mid$(Text, i)
         Exit For
      End If
   Next
 
   For i = Len(Text) To 1 Step -1
      If Asc(Mid$(Text, i, 1)) > 32 Then
         Text = Left$(Text, i)
         Exit For
      End If
   Next
   TrimAll = Text
End Function

Aufruf

   AddFavorite "DB Wiki", "http://www.dbwiki.net/"