Viele Verknüpfungen anlegen

Sub shortcut() Dim WSHShell As Object, MyShortcut Dim strDatei As String, strName As String strDatei = "C:\Program Files (x86)\Nova\nova.exe" strName = "P:\Bodo GmbH\BA-SAR16\Daten\Users\profil\Nova Sergej.lnk" Set WSHShell = CreateObject("WScript.Shell") Set MyShortcut = WSHShell.CreateShortcut(strName) MyShortcut.TargetPath = strDatei MyShortcut.WorkingDirectory = "C:\Program Files (x86)\Nova\" MyShortcut.Arguments = "-upSergej" MyShortcut.WindowStyle = 0 ' Maximiert MyShortcut.Description = "Userprofil" MyShortcut.Save Set MyShortcut = Nothing Set WSHShell = Nothing End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Sergej,
teste mal:


Option Explicit
Public Sub CreateShortcuts()
Const FOLDER_PATH As String = "P:\"
Dim astrFolders() As String, strPath As String
Dim ialngFolders As Long, ialngPath As Long
Dim avntTemp As Variant
Dim objShell As Object, objFolder As Object, objItem As Object
astrFolders = GetFolders(FOLDER_PATH)
Set objShell = CreateObject(Class:="Shell.Application")
For ialngFolders = LBound(astrFolders) To UBound(astrFolders)
avntTemp = Split(astrFolders(ialngFolders), "\")
If UBound(avntTemp) > 3 Then
If avntTemp(UBound(avntTemp) - 1) = "profil" And _
avntTemp(UBound(avntTemp) - 2) = "Users" Then
strPath = astrFolders(ialngFolders)
Set objFolder = objShell.Namespace(CVar(strPath))
For Each objItem In objFolder.Items
If objItem.IsLink Then Call Kill(PathName:=objItem.Path)
Next
ElseIf avntTemp(UBound(avntTemp) - 2) = "users" And _
avntTemp(UBound(avntTemp) - 3) = "Users" Then
If avntTemp(UBound(avntTemp) - 1)  "_DATA_" And _
avntTemp(UBound(avntTemp) - 1)  "_LOG_" Then
Call SetShortcut(strPath, avntTemp(UBound(avntTemp) - 1))
End If
End If
End If
Next
Set objFolder = Nothing
Set objShell = Nothing
End Sub
Private Sub SetShortcut(ByVal pvstrPath As String, ByVal pvstrName As String)
Const FILE_PATH As String = "C:\Program Files (x86)\Nova\nova.exe"
Const FOLDER_PATH As String = "C:\Program Files (x86)\Nova\"
Dim objWSHShell As Object, objShortcut As Object
Dim strPath As String
strPath = pvstrPath & "Nova " & pvstrName & ".lnk"
Set objWSHShell = CreateObject("WScript.Shell")
Set objShortcut = objWSHShell.CreateShortcut(strPath)
With objShortcut
.TargetPath = FILE_PATH
.WorkingDirectory = FOLDER_PATH
.Arguments = "-up" & pvstrName
.WindowStyle = 0 ' Maximiert
.Description = "Userprofil"
.Save
End With
Set objShortcut = Nothing
Set objWSHShell = Nothing
End Sub
Private Function GetFolders(ByVal pvstrPath As String) As String()
Dim astrFolders() As String
Dim strFolder As String, strPath As String
Dim ialngIndex1 As Long, ialngIndex2 As Long
ReDim Preserve astrFolders(ialngIndex1)
astrFolders(ialngIndex1) = pvstrPath
ialngIndex1 = 1
ialngIndex2 = 1
strPath = pvstrPath
Do
strFolder = Dir$(PathName:=strPath & "*", Attributes:=vbDirectory)
Do Until strFolder = vbNullString
If strFolder  "." And strFolder  ".." Then
If GetAttr(PathName:=strPath & strFolder) And vbDirectory Then
ReDim Preserve astrFolders(0 To ialngIndex1)
astrFolders(ialngIndex1) = strPath & strFolder & "\"
ialngIndex1 = ialngIndex1 + 1
End If
End If
strFolder = Dir$
Loop
If ialngIndex1 = ialngIndex2 Then Exit Do
strPath = astrFolders(ialngIndex2)
ialngIndex2 = ialngIndex2 + 1
Loop
GetFolders = astrFolders
End Function

Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread