Sub delMails()
Dim lngRow As Long, strLink As String, strFile As String
Dim strPath As String, strName As String, strExt As String
Dim lngIndex As Long, lngPos As Long
Dim rng As Range
With ActiveSheet
strPath = .Range("M1")
strPath = IIf(Right(strPath, 1) = "\", strPath, strPath & "\")
For lngRow = 2 To Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row)
If LCase(.Cells(lngRow, 7)) = "löschen" Then
If .Cells(lngRow, 1).Hyperlinks.Count > 0 Then
strLink = .Cells(lngRow, 1).Hyperlinks(1).Address
If Dir(strLink, vbNormal) <> "" Then
If rng Is Nothing Then
Set rng = .Rows(lngRow)
Else
Set rng = Union(rng, .Rows(lngRow))
End If
Kill strLink
End If
End If
ElseIf LCase(.Cells(lngRow, 7)) = "verschieben" Then
strLink = .Cells(lngRow, 1).Hyperlinks(1).Address
If Dir(strLink, vbNormal) <> "" Then
strFile = Mid(strLink, InStrRev(strLink, "\") + 1)
If Dir(strPath & strFile, vbNormal) <> "" Then
lngPos = InStrRev(strFile, ".")
strName = Left(strFile, lngPos - 1)
strExt = Mid(strFile, lngPos)
Do
lngIndex = lngIndex + 1
strFile = strName & "(" & CStr(lngIndex) & ")" & strExt
Loop While Dir(strPath & strFile, vbNormal) <> ""
End If
Name strLink As strPath & strFile
End If
ElseIf LCase(.Cells(lngRow, 7)) = "kopieren" Then
If .Cells(lngRow, 1).Hyperlinks.Count > 0 Then
strLink = .Cells(lngRow, 1).Hyperlinks(1).Address
If Dir(strLink, vbNormal) <> "" Then
If Dir(.Cells(lngRow, 11).Text, vbDirectory) <> "" Then
strFile = Mid(strLink, InStrRev(strLink, "\"))
FileCopy strLink, .Cells(lngRow, 11).Text & strFile
End If
End If
End If
End If
Next
If Not rng Is Nothing Then rng.Delete
End With
End Sub
Private Function copyFile(ByVal sourceFileName As String, targetFileName As String) As Long
Dim objFSO As Object, objFile As Object
On Error GoTo ErrExit:
copyFile = -1
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.GetFile(sourceFileName)
objFile.Copy targetFileName, True
GoTo GoOut
ErrExit:
copyFile = 0
GoOut:
Set objFSO = Nothing
Set objFile = Nothing
End Function