optimiert
02.04.2011 11:51:35
Tino
Hallo,
habe den Code etwas optimiert, damit er nicht stehen bleibt bei einem.
kommt als Code in Tabelle1
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngFormel As Range, ArrayFormel, lngRow&
Set rngFormel = Intersect(Range("A2", Cells(Rows.Count, 2)), Target)
If Not rngFormel Is Nothing Then
For Each rngFormel In rngFormel.Areas
If rngFormel.Columns(1).Column = 2 Then
Set rngFormel = rngFormel.Columns(1)
ElseIf rngFormel.Columns(1).Column = 1 Then
Set rngFormel = rngFormel.Columns(1).Offset(0, 1)
End If
ArrayFormel = Range(rngFormel, rngFormel.Offset(0, -1)).Formula
Delete_Comment rngFormel
For lngRow = 1 To Ubound(ArrayFormel)
If InStr(ArrayFormel(lngRow, 2), "=HYPERLINK") > 0 Then
With rngFormel.Cells(lngRow, 1)
.AddComment FileInfo(ArrayFormel(lngRow, 1))
.Comment.Shape.TextFrame.AutoSize = True
End With
End If
Next lngRow
Next rngFormel
End If
End Sub
Private Sub Delete_Comment(rngZelle As Range)
On Error Resume Next
rngZelle.Comment.Delete
End Sub
kommt als Code in Modul1
Option Explicit
Dim fso As Object
Private Declare Function GetFullPathName Lib "kernel32.dll" Alias _
"GetFullPathNameA" (ByVal lpFileName As String, ByVal nBufferLength As Long, _
ByVal lpBuffer As String, ByVal lpFilePart As String) As Long
Public Function GetRelativePath(PathTo As String) As String
Dim pszPath As String
Const MAX_PATH = 255
pszPath = Space(MAX_PATH)
'API-Funktion aufrufen
GetFullPathName PathTo, MAX_PATH, pszPath, vbNullString
'Rückgabe des relativierten Pfads
GetRelativePath = Left$(pszPath, InStr(pszPath, Chr(0)) - 1)
End Function
Function FileInfo(ByVal strHyperlinkAddress$) As String
Dim sFullPath As String
Dim f1 As Object
If strHyperlinkAddress = "" Then FileInfo = "Error": Exit Function
ChDrive Left$(ThisWorkbook.Path, 2)
ChDir ThisWorkbook.Path
If fso Is Nothing Then _
Set fso = CreateObject("Scripting.FileSystemObject")
strHyperlinkAddress = GetRelativePath(strHyperlinkAddress)
If Dir(strHyperlinkAddress, vbNormal) <> "" Then
Set f1 = fso.GetFile(strHyperlinkAddress)
FileInfo = "Letzte Änderung: " & f1.DateLastModified & Chr(10) & "Grösse: " & f1.Size & " Bytes"
Else
FileInfo = "Datei nicht gefunden!"
End If
End Function
Gruß Tino