Dieser Tipp basiert auf meinem Tipp Das Projekt muss dazu so eingestellt sein, dass das "Anwendungsframework aktivieren" NICHT eingestellt ist. Dann kann das Projekt mit einer SUB Main gestartet werden. Mein erweiterter Code der Sub Main sieht so aus: ''' <summary> ''' Start - SubMain ''' </summary> Public Class Start <STAThread()> Public Shared Sub Main(ByVal args As String()) Application.EnableVisualStyles() Application.SetCompatibleTextRenderingDefault(False) Dim deskTopPath As String = Environment.GetFolderPath(Environment.SpecialFolder.Desktop) Dim p As String = Application.StartupPath Dim aField() As String = {"/strtFrm=", "/lnkIcon="} Dim fField() As Form = {Form1, Form2, Form3, Form4, Form5, Form6, frmUnicodes, Form7, Form8, Form9, Form10, Form11, Form12, frmSetSettings} Dim fnField() As String = {Form1.Name, Form2.Name, Form3.Name, Form4.Name, Form5.Name, Form6.Name, frmUnicodes.Name, Form7.Name, Form8.Name, Form9.Name, Form10.Name, Form11.Name, Form12.Name, frmSetSettings.Name} Dim lnkField() As String = {"", "", "", "", "", "", "", "", "", "", "", "dhTest - Emoji", "dhTest - WEB", "dhTest - SetSettings"} Dim icoField() As String = {"", "", "", "", "", "", "", "", "", "", "", "grinning-face_1f600.ico", "agt_web.ico", "preferences_system.ico"} Dim idx As Short, sp(), nl, ni, lnkDir As String Dim startFlag As Boolean = False, nf As New Form ' Startparameter einstellen Dim clFeld As Array = ParseCommandLineArgs(aField) For i As Short = 0 To clFeld.Length - 1 sp = Split(clFeld(i), "=") Select Case sp(0) Case "/strtFrm" ' Startform einstellen idx = fnField.IndexOf(fnField, sp(1)) nf = fField(idx) If icoField(idx) <> "" Then _ nf.Icon = New Icon(p + "" + icoField(idx)) ' ist Icon-File angegeben? Case "/lnkIcon" ' zugehöriges Icon einstellen startFlag = True ni = sp(1) + ".ico" ' Icon-File wählen p = PathOnly(ni) ' ist Pfad angegeben im Startparameter If p <> "" Then _ ni = Replace(Replace(ni, p, ""), "", "") End Select Next ' Icon der Verknüpfung einstellen Try nl = "" + lnkField(idx) + ".lnk" ' Name der Verknüpfung If Not startFlag Then ni = icoField(idx) ' Name des Icons If ni <> "" Then ni = "" + ni If IsShortcut(deskTopPath + nl) Then ' gibt es eine Verknüpfung? lnkDir = ReadLnk(deskTopPath + nl, , "Icon") ' Verknüpfungsdaten lesen sp = Split(lnkDir, ",") ' Debug.Print(sp(0)) If sp(0) <> p + ni Then _ ChangeShortCutIcon(deskTopPath + nl, p + ni) ' ändern des Verknüpfungs-Icon End If End If Catch ex As Exception End Try Application.Run(nf) ' starten der Application End Sub End Class Die Variablen aFied, fField und fnField sind im Vorgängertipp erklärt. Der Code ist um folgende spezielle Variablen ergänzt:
Das individuelle Icon wird nur in eine vorhandene Verknüpfung gespeichert und dann auch nur, wenn die existierende Verknüpfung ein andres Icon besitzt als im Icon-Namenfeld angegeben! Ich verwende vorzugsweise Icons der Größe 32x32. Für die Anwendung des Tipps ist die Funktion ParseCommandLineArgs notwendig (siehe Vorgängertipp). Imports System.IO Imports System.Runtime.InteropServices Imports IWshRuntimeLibrary Module dhmodShortCut Public Const SHCNE_ASSOCCHANGED As Integer = &H8000000 Public Const SHCNF_IDLIST = 0 'Notify the shell of a change <DllImport("Shell32.dll")> Public Sub SHChangeNotify(wEventId As Integer, uFlags As Integer, dwItem1 As IntPtr, dwItem2 As IntPtr) End Sub <DllImport("Shell32.dll", EntryPoint:="#660")> Public Function FileIconInit(<MarshalAs(UnmanagedType.Bool)> ByVal fRestoreCache As Boolean) _ As <MarshalAs(UnmanagedType.Bool)> Boolean End Function ' SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_IDLIST, IntPtr.Zero, IntPtr.Zero) ''' <summary> ''' Erstellung ShortCut (Verknüpfung) ''' </summary> ''' <param name="folder">der Ordner, in dem die Verknüpfung erstellt wird</param> ''' <param name="name">der Name der Verknüpfung, der angezeigt wird</param> ''' <param name="target">die Application, die von der Verknüpfung ausgeführt wird</param> ''' <param name="description">eine Beschreibung (Tooltip) der Verknüpfung</param> ''' <param name="arguments">Befehlszeilenargumente für die Verknüpfung</param> ''' <param name="iconPath">der Pfad zum Icon der Verknüpfung</param> ''' <param name="workingdir">das Arbeitsverzeichnis der Verknüpfung</param> Public Sub CreateShortcut2(folder As String, name As String, target As String, description As String, arguments As String, iconPath As String, workingdir As String) Dim shortcutFullName As String = Path.Combine(folder, name + ".lnk") shortcutFullName = Replace(shortcutFullName, ".EXE", "") Try Dim shell As New WshShell Dim link As WshShortcut = shell.CreateShortcut(shortcutFullName) With link .Arguments = arguments .Description = description .IconLocation = iconPath .TargetPath = target '+ ".exe" .WorkingDirectory = workingdir .Save() End With Catch ex As Exception MessageBox.Show(String.Format("Die Verknüpfung ""{0}"" konnte nicht erstellt werden." _ + vbLf + vbLf + "{1}", shortcutFullName, ex.ToString()), "Create Shortcut", MessageBoxButtons.OK, MessageBoxIcon.Information) End Try End Sub ''' <summary> ''' Verknüpfungsdaten auslesen ''' </summary> ''' <param name="filename">der Dateiname der Verknüpfung</param> ''' <param name="dbg">Daten im Direktfenster zeigen ja|nein</param> ''' <param name="retVal">festlegen des Rückgabewertes</param> ''' <remarks></remarks> ''' <returns></returns> Public Function ReadLnk(filename As String, Optional dbg As Boolean = False, Optional retVal As String = "") As String Dim direc As String Dim shortCut As IWshShortcut shortCut = CType((New WshShell).CreateShortcut(filename), IWshShortcut) If dbg Then Debug.Print("") Debug.Print("Lnk-Datei: " + filename) With shortCut Debug.Print("Auszuführende Datei: " + .TargetPath) Debug.Print("Arbeitsverzeichnis: " + .WorkingDirectory) Debug.Print("Beschreibung: " + .Description) Debug.Print("Start-Parameter: " + .Arguments) Debug.Print("HotKey: " + .Hotkey) Debug.Print("Icon: " + .IconLocation) End With End If ' Rückgabe der Verknüpfung If shortCut.WorkingDirectory = "" Then ' bspw. bei Office-Programmen direc = filename Else direc = shortCut.WorkingDirectory End If Select Case retVal Case "" Return If(shortCut.WorkingDirectory.Contains("%"), shortCut.TargetPath, direc) Case "Target" : Return shortCut.TargetPath Case "Working" : Return shortCut.WorkingDirectory Case "Descript" : Return shortCut.Description Case "Arguments" : Return shortCut.Arguments Case "HotKey" : Return shortCut.Hotkey Case "Icon" : Return shortCut.IconLocation End Select End Function Public Function IsShortcut(strPath As String) As Boolean If Not IO.File.Exists(strPath) Then Return False Dim directory As String = Path.GetDirectoryName(strPath) Dim strFile As String = Path.GetFileName(strPath) Dim shell As Shell32.Shell = New Shell32.Shell() Dim folder As Shell32.Folder = shell.NameSpace(directory) Dim folderItem As Shell32.FolderItem = folder.ParseName(strFile) If folderItem IsNot Nothing Then Return folderItem.IsLink Return False End Function Public Function ResolveShortcut(strPath As String) As String If IsShortcut(strPath) Then Dim directory As String = Path.GetDirectoryName(strPath) Dim strFile As String = Path.GetFileName(strPath) Dim shell As Shell32.Shell = New Shell32.Shell() Dim folder As Shell32.Folder = shell.NameSpace(directory) Dim folderItem As Shell32.FolderItem = folder.ParseName(strFile) Dim link As Shell32.ShellLinkObject = folderItem.GetLink Return link.Path Else Return String.Empty End If End Function ''' <summary> ''' Extract ShortCut-Icon ''' </summary> ''' <param name="fileName"></param> ''' <param name="art"></param> ''' <returns></returns> Public Function GetShortCutIcon(fileName As String, Optional art As Short = 1) As Object Dim ShortcutIcon As Icon, ShortcutImage As Image Dim shortCut As IWshShortcut shortCut = CType((New WshShell).CreateShortcut(fileName), IWshShortcut) If art = 1 Then ShortcutImage = Icon.ExtractAssociatedIcon((CType(New WshShell().CreateShortcut(fileName), IWshShortcut)).TargetPath).ToBitmap() Return ShortcutImage Else ShortcutIcon = Icon.ExtractAssociatedIcon((CType(New WshShell().CreateShortcut(fileName), IWshShortcut)).TargetPath) Return ShortcutIcon End If End Function ''' <summary> ''' Change the Icon in .lnk file ''' COM reference to 'Microsoft Shell Controls And Automation' needed ''' </summary> ''' <param name="shortcutFullPath"></param> ''' <param name="newIconPath"></param> Public Sub ChangeShortCutIcon(shortcutFullPath As String, newIconPath As String, Optional ix As Short = 0) ' Load the shortcut Dim shell As New Shell32.Shell() Dim folder As Shell32.Folder = shell.[NameSpace](Path.GetDirectoryName(shortcutFullPath)) Dim folderItem As Shell32.FolderItem = folder.Items().Item(Path.GetFileName(shortcutFullPath)) Dim currentLink As Shell32.ShellLinkObject = DirectCast(folderItem.GetLink, Shell32.ShellLinkObject) currentLink.SetIconLocation(newIconPath, ix) ' Save the link to commit the changes currentLink.Save() shell = Nothing folder = Nothing folderItem = Nothing currentLink = Nothing End Sub ''' <summary> ''' Change link-target in .lnk file ''' COM reference to 'Microsoft Shell Controls And Automation' needed ''' </summary> ''' <param name="shortcutFullPath"></param> ''' <param name="newTarget"></param> Public Sub ChangeShortCutTarget(shortcutFullPath As String, newTarget As String) ' Load the shortcut Dim shell As New Shell32.Shell() Dim folder As Shell32.Folder = shell.[NameSpace](Path.GetDirectoryName(shortcutFullPath)) Dim folderItem As Shell32.FolderItem = folder.Items().Item(Path.GetFileName(shortcutFullPath)) Dim currentLink As Shell32.ShellLinkObject = DirectCast(folderItem.GetLink, Shell32.ShellLinkObject) ' Assign the new path here currentLink.Path = newTarget ' Save the link to commit the changes currentLink.Save() End Sub ' überprüfen, was sich in der Zwischenablage befindet Public Function testClipboard() As String Dim cTyp As String With My.Computer.Clipboard If .ContainsImage Then cTyp = "img" ElseIf .ContainsAudio Then cTyp = "aud" ElseIf .ContainsFileDropList Then cTyp = "fdl" ElseIf .ContainsData("specialFormat") Then cTyp = "dat" ElseIf .ContainsText Then cTyp = "txt" Else cTyp = "not" End If End With Return cTyp End Function ' lesen aus der Zwischenablage Public Function readClipboard(ByVal cTyp As String) As Object Dim obj As Object With My.Computer.Clipboard Select Case cTyp Case "img" obj = .GetImage Case "aud" obj = .GetAudioStream Case "fdl" obj = .GetFileDropList Case "dat" obj = .GetData("specialFormat") Case "txt" obj = .GetText Case Else obj = Nothing End Select End With Return obj End Function End Module Und die Funktion PathOnly: Public Function PathOnly(ByVal mPath As String) As String Return Path.GetDirectoryName(mPath) End Function Dieser Tipp wurde bereits 4.659 mal aufgerufen.
Anzeige
![]() ![]() ![]() Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv! - nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten - Symbol-Galerie mit mehr als 3.200 Icons im modernen Look Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m. |
vb@rchiv CD Vol.6 ![]() ![]() Geballtes Wissen aus mehr als 8 Jahren vb@rchiv! Online-Update-Funktion Entwickler-Vollversionen u.v.m. Tipp des Monats ![]() Dieter Otter sevTabStrip: Rechtsklick auf Reiter erkennen Eine Funktion, mit der sich prüfen lässt, auf welchen Tab-Reiter ein Mausklick erfolgte Neu! sevCommand 4.0 ![]() Professionelle Schaltflächen im modernen Design! Mit nur wenigen Mausklicks statten auch Sie Ihre Anwendungen ab sofort mit grafischen Schaltflächen im modernen Look & Feel aus (WinXP, Office, Vista oder auch Windows 8), inkl. große Symbolbibliothek. |
||||||||||||||||
Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein. |