Thema: HTML-Seiten den Favoriten hinzufügen

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

Beiträge aus dem Excel-Forum zu den Themen Extern und Internet