Link auf dem Desktop

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Link auf dem Desktop

03.10.2005 01:23:59

Nepumuk

AW: Link auf dem Desktop

03.10.2005 11:24:18

Jörg

AW: Link auf dem Desktop

03.10.2005 12:03:12

Nepumuk

Danke mT

03.10.2005 13:22:41

Jörg

Hi,
so:
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Public Sub prcCreateLink()
    Dim objShell As Object, objShortcut As Object
    Dim strDesktopPath As String, strFileName As String
    Dim strPath As String
    On Error GoTo exit_err
    Set objShell = CreateObject("wscript.Shell")
    strFileName = Dir(ThisWorkbook.FullName)
    strPath = Left(ThisWorkbook.FullName, Len(ThisWorkbook.FullName) _
        - Len(strFileName))
    If Not Len(strFileName) = 0 Then
        strDesktopPath = objShell.SpecialFolders.Item("Desktop")
        Set objShortcut = objShell.CreateShortcut(strDesktopPath & "\" & _
            strFileName & ".lnk")
        With objShortcut
            .TargetPath = objShell.ExpandEnvironmentStrings( _
                ThisWorkbook.FullName)
            .WorkingDirectory = objShell.ExpandEnvironmentStrings(strPath)
            .WindowStyle = 4
            .IconLocation = objShell.ExpandEnvironmentStrings( _
                Application.Path & "\excel.exe , 1")
            .Save
        End With
    Else
        Err.Raise Number:=vbObjectError + 1, Description:= _
            "Datei wurde noch nicht gespeichert."
    End If
    exit_sub:
    Set objShell = Nothing
    Set objShortcut = Nothing
    Exit Sub
    exit_err:
    MsgBox "Fehler " & CStr(Err.Number) & vbLf & vbLf & _
        Err.Description, 16, "Fehler"
    Resume exit_sub
End Sub

Damit die Makroabfrage nicht kommt, musst du die Makros signieren. Wie das geht, findest du hier: https://www.herber.de/index.html?https://www.herber.de/tutorial/2003/basics12.htm
Gruß
Nepumuk

Hi,
schreib das doch bitt beim nächsten mal gleich so.
Private Sub prcCreateScript()
    Dim objShell As Object
    Dim intFile As Integer
    Dim strFilename
    strFilename = Left$(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
    Reset
    intFile = FreeFile
    Open ThisWorkbook.Path & "\" & strFilename & ".vbs" For Output As #intFile
    Print #intFile, "set xlapp = createobject(" & Chr(34) & "excel.application" & Chr(34) & ")"
    Print #intFile, "xlapp.workbooks.open " & Chr(34) & ThisWorkbook.FullName & Chr(34)
    Print #intFile, "xlapp.visible = true"
    Print #intFile, "set xlapp = nothing"
    Close #intFile
    Set objShell = CreateObject("wscript.Shell")
    With objShell.CreateShortcut(objShell.SpecialFolders("Desktop") _
            & "\" & strFilename & ".lnk")
        .TargetPath = ThisWorkbook.Path & "\" & strFilename & ".vbs"
        .Save
    End With
    Set objShell = Nothing
End Sub

Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

38 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Link auf dem Desktop

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

38 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread