AW: Desktop Icon bei Verknüpfung
07.08.2020 00:28:01
volti
Hallo Michel,
den Artikel habe ich gelesen, allerdings werden die Bilder als jpg oder als bmp exportiert.
Selbst wenn, wie angeführt, BMP-Dateien als Icon eingebunden werden könnten, fehlt ihnen jedoch mindestens eine Eigenschaft:
Der Urtyp aller Bilddateien hat keine transparente Farbe. Mit jpg und png habe ich mich jetzt nicht rumgeschlagen, sondern mal eine andere Idee verfolgt.
Ico-Dateien sind 16x16 bzw. 32x32 Pixel groß, also eher klein. Warum die Binärdaten nicht einfach in einem Excelsheet speichern....
Falls Du also das Bild in Excel nicht unbedingt sehen musst, können wir es in einem hidden Sheet "Icon" als Daten einfügen, und später für den Link verwenden.
Genau das macht folgendes Makro:
Probiere es einfach mal aus:
[+][-]
Sub Verknuepfung_Erstellen()
'Legt eine Verknüpfung mit eigenem Icon an für
'Dateien mit 4er Suffix
Dim sData As String, iff As Integer, iZeile As Long
Dim oLink As Object
Dim sFilename As String, sPathname As String, sLinkFile As String
sPathname = ThisWorkbook.Path & "\" 'Pfad zur Datei
sFilename = ThisWorkbook.Name 'Exceldatei
On Error GoTo Fehler
With CreateObject("WScript.Shell")
With .CreateShortcut(.SpecialFolders("Desktop") & "\" _
& Replace(sFilename, Right(sFilename, 5), ".lnk"))
.TargetPath = sPathname & sFilename
'Icon-Daten aus dem Sheet "Icon" auslesen
With Sheets("Icon")
For iZeile = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
If .Cells(iZeile, "A").Value = "#End" Then Exit For
sData = sData & Chr(Val(.Cells(iZeile, "A").Value))
Next iZeile
iff = FreeFile
On Error Resume Next
sLinkFile = Environ("TEMP") & "\" & .Cells(1, "A").Value
Kill sLinkFile 'vorh. Ico-Datei löschen
Open sLinkFile For Binary As iff
Put iff, , sData: Close iff
End With
.IconLocation = sLinkFile 'Icon setzen
.Save 'Link speichern
End With
End With
Fehler:
End Sub
Sub LoadIconDataInSheet()
'Icon-Daten in Tabelle sichern
Dim sData As String, sFilename As String, sPathname As String
Dim iff As Integer, iZeile As Long
sPathname = "C:\ControlApp\" 'Hier den Pfad zum Ico angeben
sFilename = "gagamel.ico" 'Hier die Ico-Datei angeben
If Dir(sPathname & sFilename) <> "" Then
iff = FreeFile
Open sPathname & sFilename For Binary As iff
sData = Space$(LOF(iff)) 'Ico-Daten einlesen
Get iff, , sData 'und in Variable schaffen
With Sheets("Icon") 'Blatt Icon muss vorhanden sein
.Cells.Clear 'Alte Daten löschen
.Cells(1, "A").Value = sFilename 'Dateinamen sichern
For iZeile = 1 To Len(sData) 'Ico-Daten in Blatt schreiben
.Cells(iZeile + 1, "A").Value = Asc(Mid(sData, iZeile, 1))
Next iZeile
.Cells(iZeile + 1, "A").Value = "#End" 'Endepoint setzen
.Visible = xlVeryHidden 'Blatt ausblenden
End With
Close iff 'Ico-Datei schließen
End If
End Sub
viele Grüße aus Freigericht
Karl-Heinz