Shortcut per Makro festlegen

Question

Hallo, liebe Exelianer,

ich habe ein Makro geschrieben, das mir e-Mails schickt, damit ich - gemäß dem 4-Augen Prinzip - kontrollieren kann, ob meine Mitarbeiter alles richtig eingetragen haben. Hier ist es:

Private Sub Worksheet_Deactivate()

Dim olapp As Object
Dim wbname As String
Dim wbpath As String

wbname = ActiveWorkbook.Name
wbpath = ActiveWorkbook.Path

Set olapp = CreateObject("Outlook.application")
With olapp.createItem(0)
.Recipients.Add "sachsepeter@johndeere.com"
.Subject = "Changes in sheet ""Cockpit"" !"
.body = "Pls kindly check the sheets ""Base"" and ""Cockpit"" in " & wbname & "! " & wbpath & "\" & wbname
.send
End With
Set olapp = Nothing

End Sub

Ich habe noch 2 kleine Schönheitsfehler drin, bei denen ich mich über Eure Hilfe freuen würde.

1. In den Teil von & wbpath & "\" & wbname erhalte ich z. B. Laufwerk W: aber das kann ja bei jeden Mitarbeiter anders sein. Kann man deshalb per VBA diesen Teil so ändern, so dass der tatsächliche Laufwerksname angegeben wird?
2. Aufbauend auf Frage 1 würde ich gerne diesen Teil als Shortcut haben, so dass ich in der Mail einfach nur noch draufklicken muss. Wie bekomme ich das hin?

Ich hoffe, dass meine Angaben ausreichend präzise sind.

In jedem Fall wünsche ich Euch erstmal ein schönes WE.

Vielen Dank.

Peter

Answer 1

Hallo Peter,

den Laufwerksnamen kannst du mit der DIR-Funktion auslesen.

wbServerPath = "\\" & Dir(wbPath, vbVolume) & Right(wbPath, Len(wbPath) - 2)

Wie man einen Link erstellt, weiß ich nicht hundertprozentig aber versuche mal:

Link = "<a href='file://" & wbServerPath & "'>wbName</a>"

Testen kann ich das Ganze leider selbst erst im Lauf der nächsten Woche, da ich hier kein Outlook habe. So oder ähnlich müsste es aber klappen.

Mr. K.

Answer 2

Den Link natürlich inklusive Dateinamen:

Link = "<a href='file://" & wbServerPath & "\" & wbName & "'>wbName</a>"

Answer 3

Hallo Mr. K,

vielen Dank für Deine zügige Antwort, Ich hatte am WE gar nicht damit gerechnet.

Bezüglich der DIr Funktion bekomme ich ein Ergebnis, indem der Servername fehlt. Das Ergebnis sieht wie folgt aus:

\\\Ordner 1\Datei a.xlsm

Es müsste aber so aussehen:

\\Server 1\Ordner 1\Datei a.xlsm

Ich habe hin und her probiert, aber vba scheint nicht den vbvolume Teil zu nehmen. Da es sich um eine größere Serverstruktur handelt, brauch man vielleicht CHDir oder CHDrive? Bin da drüber gestolpert, als ich im Internet gestöbert habe.

Bezüglich des Shortcuts in der e-Mail bekomme ich folgendes:

<a href='file://W:\Ordner 1'>/wbName<a> wobei als Link markiert der Teil file://W:\Ordner markiert ist. Der Rest ist nicht als Link angezeigt.

Es wäre wirklich toll, wenn Du mir hier noch helfen könntest.

Vielen Dank und noch einen schönen Sonntag.

Gruss

Peter

Answer 4

OK, dann war DIR doch nicht die richtige Funktion. Dachte nicht, dass man für sowas lapidares die API-Funktionen bemühen muss.

dank dieser Seite www.office-loesung.de/ftopic237236_0_0_asc.php klappt aber wenigstens erst mal das Auslesen.

Beim Versenden muss der Pfad dann noch in zusätzlichen < > stehen. War davon ausgegangen, dass die für den Link verwendeten < > diese Kriterium bereits erfüllen.
Leider erzeugen die zusätzlichen < > einen eigenen Link. Hab auf die Schnelle noch keine Möglichkeit gefunden, wie man da einen Shortlink draus macht. Der gewohnte Weg, scheint aufgrund der eigenständigen Verlinkung nicht zu funktionieren.
Werde da in den nächsten Tagen noch ein wenig nachforschen.

Aber zumindest hast du erstmal ein funktionierendes Makro.

Private Declare Function WNetGetConnection Lib "mpr.dll" _
Alias "WNetGetConnectionA" (ByVal lpszLocalName As String, _
ByVal lpszRemoteName As String, _
cbRemoteName As Long) As Long

Public Function GetUNCPath(ByVal sLocalPath As String) As String
Const NO_ERROR As Long = 0
Dim sUNCPath As String
Dim sResult As String
Dim sDrive As String

GetUNCPath = sLocalPath
If VBA.Mid$(sLocalPath, 2, 1) <> ":" Then Exit Function
sDrive = VBA.Left$(sLocalPath, 2)
sUNCPath = VBA.String(260, 0)
If WNetGetConnection(sDrive, sUNCPath, VBA.Len(sUNCPath)) = NO_ERROR Then
sResult = VBA.Left$(sUNCPath, VBA.InStr(sUNCPath, vbNullChar) - 1)
If VBA.Len(sResult) > 0 Then
GetUNCPath = sResult & VBA.Mid$(sLocalPath, 3)
End If
End If
End Function

Sub test()

MsgBox GetUNCPath(ActiveWorkbook.Path)

Dim olapp As Object
Dim wbname As String
Dim wbpath As String

wbname = ActiveWorkbook.Name
wbpath = ActiveWorkbook.Path
wbServerPath = GetUNCPath(ActiveWorkbook.Path)

Set olapp = CreateObject("Outlook.application")
With olapp.createItem(0)
.Recipients.Add "sachsepeter@johndeere.com"
.Subject = "Changes in sheet ""Cockpit"" !"
'Link = "<a href='file:///<" & wbServerPath & "\" & wbname & "'>wbName</a>>"
Link = "<" & wbServerPath & "\" & wbname & ">Test</a>"
.body = "Pls kindly check the sheets ""Base"" and ""Cockpit"" in " & Link
.send
End With
Set olapp = Nothing


End Sub

Gruß Mr. K.

Answer 5

Das Test</a> hinter dem Link kannst du entfernen. War nur für meine Tests

Answer 6

Hab versehentlich eine meiner Testmails an dich geschickt. Bitte einfach löschen

Answer 7

Hallo Mr. K.,

vielen Dank für das tolle Makro. Um ehrlich zu sein, habe ich es noch nicht begriffen. Es ist doch noch sehr abstrakt für mich und es ist immer wieder toll für mich, zu erfahren, was man alles so mit xls machen kann.

Bis auf den kleinen Schönheitsfehler, den Du angesprochen hast, läuft es wirklich toll.

Vielen Dank erstmal.

Gruss

Peter