Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
840to844
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
840to844
840to844
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Hyperlinks ändern > Laufwerksänderung

Hyperlinks ändern > Laufwerksänderung
30.01.2007 19:50:02
Stefan
Hallo
ich habe eine Datei mit einer Vielzahl an Hyperlinks auf Dateien auf einem Laufwerk. Jetzt hat sich der Laufwerksbuchstabe geändert :
von Laufwerk Z:\ auf Laufwerk e:\
Wie kann ich alle Hyperlinks zum öffnen der Dateien ändern.
Wie gesagt: es hat sich nur der Laufwerksbuchstabe geändert.
Zur weiteren Verdeutlichung:
Ich nutze folgendes Makro, um eine Auflistung der Verzeichnisse mit Hyperlink
zu erhalten
Vorab vielen Dank für einen Tip
Gruss Stefan
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Sub Verzeichnisse_auflisten()
Dim Pfad1, Name1, Anzahl, x, X0, X1, X2, Verz, Anzverz, Größe
Dim TB1, TB2 As Worksheet
Dim msg As String
Set TB1 = ThisWorkbook.Worksheets(1)
Set TB2 = ThisWorkbook.Worksheets(2)
Start = Now
TB1.[a:e] = "" 'zellinhalte spalte a bis e löschen
TB2.[a:e] = ""
'überflüssige Tabellenblätter löschen
If ThisWorkbook.Worksheets.Count > 2 Then
Application.DisplayAlerts = False
For x = 3 To ThisWorkbook.Worksheets.Count
ThisWorkbook.Worksheets(3).Delete
Next x
Application.DisplayAlerts = True
End If
' Pfad abfragen
msg = "Wählen Sie bitte einen Ordner aus:"
Pfad1 = getdirectory(msg)
If Pfad1 = "" Then Exit Sub
Name1 = Dir(Pfad1, vbDirectory) ' Ersten Eintrag abrufen.
TB1.[a2] = Pfad1
Anzahl = 2
TB1.[a1] = "Pfad"
TB1.[b1] = "UnterVerz."
TB1.[C1] = "Anz. Dateien"
TB1.[d1] = "Datgröße in Verz."
X0 = 2
X1 = 2
Do While TB1.Cells(Rows.Count, 1).End(xlUp).Row TB1.Cells(Rows.Count, 2).End(xlUp).Row
For X2 = X0 To X1
Pfad1 = TB1.Cells(X2, 1) ' Pfad setzen.
If Right(Pfad1, 1) "\" Then Pfad1 = Pfad1 & "\"
Name1 = Dir(Pfad1, vbDirectory) ' Ersten Eintrag abrufen.
Verz = 0
Do While Name1 "" ' Schleife beginnen.
' Aktuelles und übergeordnetes Verzeichnis ignorieren.
If Name1 "." And Name1 ".." Then
' Mit bit-weisem Vergleich sicherstellen, daß Name1 ein
' Verzeichnis ist.
If (GetAttr(Pfad1 & Name1) And vbDirectory) = vbDirectory Then
Anzahl = Anzahl + 1
TB1.Cells(Anzahl, 1) = Pfad1 & Name1 & "\"
Verz = Verz + 1
'Eintrag nur anzeigen, wenn es sich um ein Verzeichnis handelt.
End If
End If
Name1 = Dir ' Nächsten Eintrag abrufen.
Loop
TB1.Cells(X2, 2) = Verz
Next X2
X0 = X1 + 1
X1 = X2
Loop
'Dateien aus den Verzeichnissen auslesen
TB2.[a1] = "Dat"
TB2.[b1] = "Link"
TB2.[C1] = "Groesse"
TB2.[d1] = "Speicherdat"
TB2.[e1] = "owner"
Anzverz = TB1.Cells(Rows.Count, 2).End(xlUp).Row ' ab zeile 2 eintragen rows.count
I = 1
ii = 0
For Verz = 2 To Anzverz
Anzahl = 0
Größe = 0
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(TB1.Cells(Verz, 1))
Set fc = f.Files
For Each f1 In fc
If I = 65536 Then
ii = ii + 1
ThisWorkbook.Worksheets.Add.Move After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
ThisWorkbook.Worksheets(ii + 2).name = "Dateien " & ii + 1
Set TB2 = ThisWorkbook.Worksheets(ii + 2)
I = 1
End If
I = I + 1
Anzahl = Anzahl + 1
TB2.Cells(I, 1) = f1.name
TB2.Cells(I, 2) = f & "\" & f1.name
'Hyperlink auf die Datei einfügen
TB2.Hyperlinks.Add Anchor:=TB2.Cells(I, 2), Address:= _
f & "\" & f1.name
TB2.Cells(I, 3) = FileLen(f1)
TB2.Cells(I, 4) = FileDateTime(f1)
Größe = Größe + FileLen(f1)
Next
TB1.Cells(Verz, 3) = Anzahl
TB1.Cells(Verz, 4) = Größe / 1024 / 1024
Next Verz
'MsgBox (ii * 65536) + i
ende = Now
MsgBox "Anzahl der Verzeichnisse: " & Verz & Chr(13) & _
"Anzahl der Dateien: " & (ii * 65536) + I & Chr(13) & _
Chr(13) & "Dauer: " & Format(ende - Start, "nn:ss")
SortVerz
UntersteEbenehervorhebenVerz
SortDat
UntersteEbenehervorhebenDat
Dat_Tab_aufbereiten
spaltenbreite
'formel - funktion besitzer in spalte e einfügen
Range("E4:E" & Cells(Rows.Count, "D").End(xlUp).Row).Formula = "=besitzer(b4)"
'formel =besitzer() in Werte umwandeln
Range("E4:E" & Cells(Rows.Count, "E").End(xlUp).Row).Value = _
Range("E4:E" & Cells(Rows.Count, "E").End(xlUp).Row).Value
End Sub

Private Function getdirectory(Optional msg) As String
Dim bInfo As BROWSEINFO
Dim Path As String
Dim r As Long, x As Long, pos As Integer
' Ausgangsordner = Desktop
bInfo.pidlRoot = 0&
' Dialogtitel
If IsMissing(msg) Then
bInfo.lpszTitle = "Wählen Sie bitte einen Ordner aus."
Else
bInfo.lpszTitle = msg
End If
' Rückgabe des Unterverzeichnisses
bInfo.ulFlags = &H1
' Dialog anzeigen
x = SHBrowseForFolder(bInfo)
' Ergebnis gliedern
Path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal Path)
If r Then
pos = InStr(Path, Chr$(0))
getdirectory = Left(Path, pos - 1)
Else
getdirectory = ""
End If
End Function


Private Sub SortVerz()
Sheets("Verzeichnisse").Select
Range("A1").Select
Columns("A:D").Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("A1").Select
End Sub


Private Sub SortDat()
Sheets("Dateien").Select
Range("A1").Select
Columns("A:D").Select
Selection.Sort Key1:=Range("b2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("A1").Select
End Sub


Private Sub UntersteEbenehervorhebenVerz()
Dim c As Range
Set r = Range("a1:a65000")
For Each c In r.Cells
With c
For int_Pos = Len(c) - 1 To 1 Step -1
If Mid(.Text, int_Pos, 1) = "\" Then
.Characters(1, int_Pos).Font.Bold = False
.Characters(int_Pos + 1, Len(.Text)).Font.Bold = True
Exit For
End If
Next
End With
Next
End Sub


Private Sub UntersteEbenehervorhebenDat()
Dim c As Range
Dim int_Pos1 As Integer
Dim int_Pos2 As Integer
Dim int_Vonrechts As Integer
Set r = Range("b1:b65000")
int_Vonrechts = 2
For Each c In r.Cells
int_Ebene = 0
int_Pos2 = 0
With c
For int_Pos1 = Len(c) - 1 To 1 Step -1
If Mid(.Text, int_Pos1, 1) = "\" Then
int_Ebene = int_Ebene + 1
If int_Ebene = int_Vonrechts Then
.Font.Bold = False
.Characters(int_Pos1 + 1, int_Pos2 - int_Pos1).Font.Bold = True
Exit For
Else
int_Pos2 = int_Pos1
End If
End If
Next
End With
Next
End Sub


Private Sub Dat_Tab_aufbereiten()
On Error Resume Next
If Not ActiveSheet.AutoFilter Is Nothing Then ActiveSheet.Cells.AutoFilter
Cells.Select
Range("A1").Select
ActiveWindow.FreezePanes = False
Rows("1:2").Select
Selection.Insert Shift:=xlDown
Range("A4").Select
ActiveWindow.FreezePanes = True
Range("A3:F3").Select
Selection.AutoFilter
Range("B2").Select
ActiveCell.FormulaR1C1 = "=AF_KRIT()"
End Sub


Private Function FilterKriterien(Rng As Range) As String
Dim Filter As String
Application.Volatile
Filter = ""
On Error GoTo Finish
With Rng.Parent.AutoFilter
If Intersect(Rng, .Range) Is Nothing Then GoTo Finish
With .Filters(Rng.Column - .Range.Column + 1)
If Not .On Then GoTo Finish
Filter = .Criteria1
Select Case .Operator
Case xlAnd
Filter = Filter & " UND " & .Criteria2
Case xlOr
Filter = Filter & " ODER " & .Criteria2
End Select
End With
End With
Finish:
FilterKriterien = Filter
End Function


Private Function AF_KRIT()
Dim intCol As Integer
Dim intFilter As Integer
Dim rngFilter As Range
Dim strFilter As String
Dim WS As Worksheet
Application.Volatile
Set WS = ActiveSheet
If WS.FilterMode And WS.AutoFilterMode Then
Set rngFilter = WS.AutoFilter.Range
For intCol = 1 To rngFilter.Columns.Count
With WS.AutoFilter.Filters(intCol)
If .On Then
If strFilter <> "" Then strFilter = strFilter & vbLf
strFilter = strFilter & rngFilter.Cells(1, intCol) & ": " & .Criteria1
Select Case .Operator
Case xlAnd
strFilter = strFilter & " UND " & .Criteria2
Case xlOr
strFilter = strFilter & " ODER " & .Criteria2
End Select
End If
End With
Next intCol
End If
AF_KRIT = strFilter
End Function


Private Sub spaltenbreite()
Dim Blatt As Object
For Each Blatt In Sheets
Blatt.Columns("A:E").EntireColumn.AutoFit
Next
End Sub

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Hyperlinks ändern > Laufwerksänderung
30.01.2007 20:31:02
Anton
Hallo Stefan,
versuch's damit:

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Shell ("subst z: /d")
End Sub
Private Sub Workbook_Open()
Shell ("subst z: e:\")
End Sub

MfG Anton
Anzeige

300 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige