Gruppe
Extern
Bereich
Internet
Thema
HTML-Seiten den Favoriten hinzufügen
Problem
Den Favoriten soll ein neuer Ordner mit Internetadressen hinzugefügt werden.
Lösung
Geben Sie den nachfolgenden Code in ein Standardmodul ein und weisen Sie ihn einer Schaltfläche zu.
StandardModule: basMain
Sub SetFavorites()
Dim rng As Range
Dim sPath As String
sPath = WindowsFolder & "\Favoriten"
On Error Resume Next
MkDir sPath
sPath = sPath & "\" & ActiveSheet.Name
MkDir sPath
On Error GoTo 0
Close
For Each rng In Range("A1").CurrentRegion.Cells
If rng.Hyperlinks.Count > 0 Then
Open sPath & "\" & rng.Value & ".URL" For Output As #1
Print #1, CreateLink(rng.Hyperlinks(1).Address)
Close
End If
Next rng
MsgBox "Die Favoriten wurden angelegt!"
End Sub
Private Function CreateLink(sLink As String)
Dim sTxt As String
sTxt = "[Default]" & vbLf
sTxt = sTxt & "BASEURL=" & sLink & vbLf & vbLf
sTxt = sTxt & "[InternetShortcut]" & vbLf
sTxt = sTxt & "URL=" & sLink & vbLf
CreateLink = sTxt
End Function
StandardModule: basFunctions
Declare Function GetWindowsDirectory Lib "kernel32.dll" _
Alias "GetWindowsDirectoryA" ( _
ByVal lpBuffer As String, ByVal nSize As Long) As Long
Function WindowsFolder()
Dim lLength As Long
Dim sWinDir As String
sWinDir = Space(255)
lLength = GetWindowsDirectory(sWinDir, 255)
WindowsFolder = Left(sWinDir, lLength)
End Function