sådan laver du en genvej til regnemaskinen med notepads ikon:
1. sæt en reference til Windows Script Host Object Model (Ver 1.0) 2. Paste nedenstående ind i koden vinduet: Private Sub Form_Load() Dim o As IWshRuntimeLibrary.IWshShell Dim lLink As IWshRuntimeLibrary.IWshShortcut_Class
Set o = New IWshRuntimeLibrary.IWshShell_Class Set lLink = o.CreateShortcut(\"C:\\Data\\test.lnk\")
lLink.Description = \"Dette er en beskrivelse!\" lLink.IconLocation = \"Notepad.exe, 0\" lLink.WorkingDirectory = \"c:\\winnt\\system32\\\" lLink.TargetPath = \"calc.exe\" lLink.Save
/ bliver lavet om til \\ og \" \" bibeholdtes, spørgsmålet om der er andre muligheder, det må da være muligt at kunne skrive til en genvejs egenskaber når de kan sættes ind manuelt
L_Welcome_MsgBox_Message_Text = \"Dette script laver en genvej til Notesblok på dit skrivebord.\" L_Welcome_MsgBox_Title_Text = \"Scripteksempel til Windows Scripting Host\" Call Welcome()
WScript.Echo \"En genvej til Notesblok ligger nu på dit skrivebord.\"
\' ******************************************************************************** \' * \' * Velkomst \' * Sub Welcome() Dim intDoIt
intDoIt = MsgBox(L_Welcome_MsgBox_Message_Text, _ vbOKCancel + vbInformation, _ L_Welcome_MsgBox_Title_Text ) If intDoIt = vbCancel Then WScript.Quit End If End Sub
Jøps, her er koden som du paster ind i et modul. Se funktionen CreateShellLink, det skulle være selvforklarende....
Det er ikke elegant, men det er der.!
Option Explicit \'--------------------------------------------------------------- \'- Public API Declares... \'--------------------------------------------------------------- #If UNICODE Then Public Declare Function SHGetPathFromIDList Lib \"Shell32\" Alias \"SHGetPathFromIDListW\" (ByVal pidl As Long, ByVal szPath As Long) As Long #Else Public Declare Function SHGetPathFromIDList Lib \"Shell32\" Alias \"SHGetPathFromIDListA\" (ByVal pidl As Long, ByVal szPath As String) As Long #End If
Public Declare Function SHGetSpecialFolderLocation Lib \"Shell32\" (ByVal hwndOwner As Long, ByVal nFolder As Integer, ppidl As Long) As Long
\'--------------------------------------------------------------- \'- Public constants... \'--------------------------------------------------------------- Public Const MAX_PATH = 255 Public Const MAX_NAME = 40
Public Enum SHOWCMDFLAGS SHOWNORMAL = 5 SHOWMAXIMIZE = 3 SHOWMINIMIZE = 7 End Enum
\'--------------------------------------------------------------- Public Function GetSystemFolderPath(ByVal hwnd As Long, ByVal Id As Integer, sfPath As String) As Long \'--------------------------------------------------------------- Dim rc As Long \' Return code Dim pidl As Long \' ptr to Item ID List Dim cbPath As Long \' char count of path Dim szPath As String \' String var for path \'--------------------------------------------------------------- szPath = Space(MAX_PATH) \' Pre-allocate path string for api call
rc = SHGetSpecialFolderLocation(hwnd, Id, pidl) \' Get pidl for Id... If (rc = 0) Then \' If success is 0 #If UNICODE Then rc = SHGetPathFromIDList(pidl, StrPtr(szPath)) \' Get Path from Item Id List #Else rc = SHGetPathFromIDList(pidl, szPath) \' Get Path from Item Id List #End If If (rc = 1) Then \' If success is 1 szPath = Trim$(szPath) \' Fix path string cbPath = Len(szPath) \' Get length of path If (Asc(Right(szPath, 1)) = 0) Then cbPath = cbPath - 1 \' Adjust path length If (cbPath > 0) Then sfPath = Left$(szPath, cbPath) \' Adjust path string variable GetSystemFolderPath = True \' Return success End If End If \'--------------------------------------------------------------- End Function \'---------------------------------------------------------------
\'--------------------------------------------------------------- Public Function CreateShellLink(lnkFile As String, ExeFile As String, WorkDir As String, _ ExeArgs As String, IconFile As String, IconIdx As Long, _ ShowCmd As SHOWCMDFLAGS, Description As String) As Long \'--------------------------------------------------------------- Dim rc As Long Dim pidl As Long \' Item id list Dim dwReserved As Long \' Reserved flag Dim cShellLink As ShellLinkA \' An explorer IShellLinkA(Win 95/Win NT) instance Dim cPersistFile As IPersistFile \' An explorer IPersistFile instance \'--------------------------------------------------------------- If ((lnkFile = \"\") Or (ExeFile = \"\")) Then Exit Function \' Validate min. input requirements.
On Error GoTo ErrHandler Set cShellLink = New ShellLinkA \' Create new IShellLink interface Set cPersistFile = cShellLink \' Implement cShellLink\'s IPersistFile interface
With cShellLink .SetPath ExeFile \' set command line exe name & path to new ShortCut.
If (WorkDir <> \"\") Then .SetWorkingDirectory WorkDir \' Set working directory in shortcut
If (ExeArgs <> \"\") Then .SetArguments ExeArgs \' Add arguments to command line
\' if (LnkDesc <> \"\") then .SetDescription pszName \' Set shortcut description \' .SetHotkey wHotKey
If (IconFile <> \"\") Then .SetIconLocation IconFile, IconIdx \' Set shortcut icon location & index
.SetShowCmd ShowCmd \' Set shortcut\'s startup mode (min,max,normal) End With
cShellLink.Resolve 0, SLR_UPDATE cPersistFile.Save StrConv(lnkFile, vbUnicode), 0 \' Unicode conversion hack... This must be done! CreateShellLink = True \' Return Success
\'--------------------------------------------------------------- ErrHandler: \'--------------------------------------------------------------- Set cPersistFile = Nothing \' Destroy Object Set cShellLink = Nothing \' Destroy Object \'--------------------------------------------------------------- End Function \'---------------------------------------------------------------
\'--------------------------------------------------------------- Public Function GetShellLinkInfo(lnkFile As String, ExeFile As String, WorkDir As String, _ ExeArgs As String, IconFile As String, IconIdx As Long, _ ShowCmd As Long, Description As String) As Long \'--------------------------------------------------------------- Dim pidl As Long \' Item id list Dim wHotKey As Long \' Hotkey to shortcut... Dim fd As WIN32_FIND_DATA
Dim buffLen As Long Dim cShellLink As ShellLinkA \' An explorer IShellLink instance Dim cPersistFile As IPersistFile \' An explorer IPersistFile instance \'--------------------------------------------------------------- If (lnkFile = \"\") Then Exit Function \' Validate min. input requirements.
Set cShellLink = New ShellLinkA \' Create new IShellLink interface Set cPersistFile = cShellLink \' Implement cShellLink\'s IPersistFile interface
\' Load Shortcut file...(must do this UNICODE hack!) On Error GoTo ErrHandler cPersistFile.Load StrConv(lnkFile, vbUnicode), STGM_DIRECT
With cShellLink \' Get command line exe name & path of shortcut ExeFile = Space(MAX_PATH) buffLen = Len(ExeFile) .GetPath ExeFile, buffLen, fd, SLGP_UNCPRIORITY Dim s As String s = fd.cFileName \' Not returned to calling function
\' Get working directory of shortcut WorkDir = Space(MAX_PATH) buffLen = Len(WorkDir) .GetWorkingDirectory WorkDir, buffLen
\' Get command line arguments of shortcut ExeArgs = Space(MAX_PATH) buffLen = Len(ExeArgs) .GetArguments ExeArgs, buffLen
\' Get description of shortcut Description = Space(MAX_PATH) buffLen = Len(Description) .GetDescription Description, buffLen
\' Get the HotKey for shortcut .GetHotkey wHotKey \' Not returned to calling function
\' Get shortcut icon location & index IconFile = Space(MAX_PATH) buffLen = Len(IconFile) .GetIconLocation IconFile, buffLen, IconIdx
\' Get Item ID List... .GetIDList pidl \' Not returned to calling function
\' Set shortcut\'s startup mode (min,max,normal) .GetShowCmd ShowCmd End With
GetShellLinkInfo = True \' Return Success \'--------------------------------------------------------------- ErrHandler: \'--------------------------------------------------------------- Set cPersistFile = Nothing \' Destroy Object Set cShellLink = Nothing \' Destroy Object \'--------------------------------------------------------------- End Function \'---------------------------------------------------------------
\'--------------------------------------------------------------- Public Function cmdGetLinkPath(lnkFile As String, oDescription As String) As String \'--------------------------------------------------------------- Dim ExeFile As String \' Link - Exe file name Dim WorkDir As String \' - Working directory Dim ExeArgs As String \' - Command line arguments Dim IconFile As String \' - Icon File name Dim IconIdx As Long \' - Icon Index Dim ShowCmd As Long \' - Program start state... Dim Description As String Dim s As String Dim i As Integer \'---------------------------------------------------------------
GetShellLinkInfo lnkFile, _ ExeFile, _ WorkDir, _ ExeArgs, _ IconFile, _ IconIdx, _ ShowCmd, Description \' Get Info for shortcut file...
s = Description i = InStr(s, Chr(0)) If i <> 0 Then s = Mid(s, 1, i - 1) oDescription = s
s = ExeFile i = InStr(s, Chr(0)) If i <> 0 Then s = Mid(s, 1, i - 1) cmdGetLinkPath = s End Function
Problemet med at skrive til en genvej deltager jeg gerne i. Jeg har prøvet ligge ovenstående kode fra Jazper ind under et form modul, men får fejlmeddelsen: Compile error Constants, fixed-length strings, arrays, user-defined types and declare statements not allowed as public members of object modules.
Ups der blev min uvidenhed på VB vist afsløret. Det virkede selvfølig da det blev lagt ind i et kode modul. Nu vil jeg se hvad der kan gøres med den genvejs funktion.
Min husmandsprogrammering rækker ikke. Jazper kan du forklare hvordan funktions kaldet kommer til at fungere, funktions erklæringen ligger i module1.bas. Funktions kaldet ligger under en knap på form1. Først har jeg prøvet at lave variabler (vist udkommenteret)som blev indsat som parametre i funktionen, da det ikke virkede har jeg prøvet at skrive værdierne direkte ind i funktionskaldet, det giver så fejlen \"Statement invalid outside Type block\" Jeg er heller ikke helt sikker på hvad de forskellige parametre skal indeholde. Jeg håber du kan give mig et vink med en vognstang. #:-(
Private Sub Command1_Click()
\'Dim lnkFile As String \'Dim ExeFile As String \'Dim WorkDir As String \'Dim ExeArgs As String \'Dim IconFile As String \'Dim ShowCmd As SHOWCMDFLAGS \'Dim IconIdx As Long \'Dim Description As String
\'CreateShellLink(lnkFile, ExeFile, WorkDir, ExeArgs, IconFile, IconIdx, ShowCmd, Description) As Long CreateShellLink(\"C:\\WINDOWS\\Skrivebord\\Genvej til LogIn.Ina\", \"C:\\Programmer\\CadArc\\DataManager\\DataManagerRun.exe\", \"T:\\DokArkiv\\Login\", \"/S T:\\DokArkiv\\Login\\LogIn.Ina\", \"T:\\Dokarkiv\\Icons\\CRDFLE04.ICO\", \"\", SHOWNORMAL, \"\") As Long CreateShellLink() As Long
Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.
Ny bruger
Nybegynder
Opret
Preview
