@BST - noch ne Frage
02.08.2005 15:16:11
Michael
es geht leider noch mal um das Versenden, siehe deine Makro unten!
und zwar überneimmt OL den Pfad nicht immer KOMPLETT als Link!
der geht: \\daten\laufwerk_k\ALLE\Mappe2.xls
der NICHT!!: \\daten\laufwerk_k\ALLE\Mappe2 test.xls
liegt das am Leerschritt? wenn ja, kann man das irgendwie "abstellen",
ohne sämtliche Dateinamen zu ändern?
hier dein Makro:
*************************************************************************
Option Explicit
Declare
Function WNetGetConnection32 Lib "MPR.DLL" Alias _
"WNetGetConnectionA" (ByVal lpszLocalName As String, ByVal _
lpszRemoteName As String, lSize As Long) As Long
Function GetUNCPath(Pathname As String) As String
Dim UNCPath As String, lw As String, pfad As String
Dim Names As String
GetUNCPath = Pathname
If Len(Pathname) > 1 Then
lw = Left(Pathname, 2)
If lw Like "[A-Za-z]:" Then
pfad = Mid(Pathname, 3)
UNCPath = String(256, 0)
If WNetGetConnection32(lw, UNCPath, 256) = 0 Then
GetUNCPath = Left(UNCPath, InStr(1, UNCPath, Chr(0)) - 1) & pfad
End If
End If
End If
End Function
Sub Hyperlink_senden()
Dim Name As String, UNCName As String
Dim App As Object, Itm As Object
Dim Username As String
On Error GoTo myERR
Name = ActiveWorkbook.FullName
UNCName = GetUNCPath(Name)
Set App = CreateObject("Outlook.Application")
Set Itm = App.CreateItem(0)
With Itm
.Subject = UNCName
.To = ""
.body = "ich habe unten folgende Datei als Hyperlink angehängt!" & Chr(13) & Chr(13) & "Mit freundlichen Grüßen" & Chr(13) & "Mein Name" & Chr(13) & Chr(13) & UNCName
'.Attachments.Add Name, 3
.Display
End With
Set App = Nothing
Set Itm = Nothing
myERR:
If Err.Number <> 0 Then MsgBox "Fehler " & Err.Number & " : " & Err.Description
End Sub
*************************************************************************
Nochmals vielen Dank für deine Mühen!
Gruss
Micha