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:

Public Const CSIDL_FAVORITES = &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 = Name der Website
'   URL =      URL der Website
' Rückgabewert: True = erfolgreich, False = sonst
 
Dim pidl As Long, psFullPath As String, 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 S As String) As String
Dim I As Long
  For I = 1 To Len(S)
    If Asc(Mid(S, I, 1)) > 32 Then
      S = Mid(S, I)
      Exit For
    End If
  Next I
  For I = Len(S) To 1 Step -1
    If Asc(Mid(S, I, 1)) > 32 Then
      S = Left(S, I)
      Exit For
    End If
  Next I
  TrimAll = S
End Function

Aufruf

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