Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
744to748
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
744to748
744to748
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

an Heiko S. (evtl. auch jemand anderes)

an Heiko S. (evtl. auch jemand anderes)
23.03.2006 09:36:45
andreas
Hallo Heiko,
ich benötige noch einmal Deine Hilfe.
Du hast mir kürzlich bei einem Problem geholfen.
https://www.herber.de/forum/archiv/740to744/t743952.htm
Ich habe mir Deinen code so angepasst, dass ich mir ein verlinktes automatisches Inhaltsverzeichnis erstellen kann.
code:
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
Option Explicit
Dim strDirs() As String
Dim strPaths() As String
Dim intTiefe() As Integer
Dim intArrayCounter As Integer, intTiefeMerker As Integer
Sub auto_Open()
Cells.Select
Selection.ClearContents
Cells(10, 5) = "Daten werden gelesen"
Range("A1").Select
Call ShowDir
End Sub
Sub ShowDir()
Dim inthelp As Integer, intN As Integer, intI As Integer, intJ As Integer
Dim strPfad As String
Application.ScreenUpdating = False
strPfad = ActiveWorkbook.path & "\"
If strPfad = "" Then Exit Sub
Erase strDirs
Erase intTiefe
Erase strPaths
ReDim Preserve strDirs(intArrayCounter)
ReDim Preserve strPaths(intArrayCounter)
ReDim Preserve intTiefe(intArrayCounter)
strDirs(0) = strPfad
strPaths(0) = strPfad
intTiefe(0) = 1
intTiefeMerker = 1
intArrayCounter = 1
ShowFolderList1 (strPfad)
ActiveSheet.Cells.Delete
intN = 1
intJ = 2
For inthelp = LBound(strDirs) To UBound(strDirs)
ActiveSheet.Hyperlinks.Add ActiveSheet.Cells(intN, intTiefe(inthelp)), _
Address:=strPaths(inthelp), TextToDisplay:=strDirs(inthelp)
ActiveSheet.Cells(intN, intTiefe(inthelp)).Font.Bold = True
ActiveSheet.Cells(intN, intTiefe(inthelp)).Font.ColorIndex = 3
With Application.FileSearch
.NewSearch
.LookIn = strPaths(inthelp)
.SearchSubFolders = False
.FileType = msoFileTypeAllFiles
.Execute
If .FoundFiles.Count > 0 Then
For intI = 1 To .FoundFiles.Count
ActiveSheet.Hyperlinks.Add ActiveSheet.Cells(intJ, intTiefe(inthelp) + 1), _
.FoundFiles(intI)
intN = intN + 1
intJ = intJ + 1
Next intI
End If
End With
intN = intN + 2
intJ = intJ + 2
Next inthelp
Application.ScreenUpdating = True
End Sub

Private Function ShowFolderList1(strPath As String)
Dim objFileSystemOb As Object, objGetFolder As Object, objSubFolderList As Object
Dim objSubFolder As Object
Dim strSubName As String
Set objFileSystemOb = CreateObject("Scripting.FileSystemObject")
Set objGetFolder = objFileSystemOb.GetFolder(strPath)
Set objSubFolder = objGetFolder.SubFolders
On Error GoTo errorhandler
For Each objSubFolderList In objSubFolder
strSubName = objSubFolderList.Name
' Versteckte Verzeichnisse und Systemordner nicht mit ausgeben.
If (GetAttr(strPath & strSubName) And vbDirectory) And _
(GetAttr(strPath & strSubName) And vbHidden) = False And _
(GetAttr(strPath & strSubName) And vbSystem) = False Then
ReDim Preserve strDirs(intArrayCounter)
ReDim Preserve strPaths(intArrayCounter)
ReDim Preserve intTiefe(intArrayCounter)
strDirs(intArrayCounter) = strSubName
strPaths(intArrayCounter) = objSubFolderList.path
intTiefe(intArrayCounter) = intTiefeMerker
intArrayCounter = intArrayCounter + 1
intTiefeMerker = intTiefeMerker + 1
ShowFolderList1 (strPath & objSubFolderList.Name & "\")
intTiefeMerker = intTiefeMerker - 1
End If
Next
errorhandler:
strSubName = "Kein Zugriff"
Resume Next
End Function

Jetzt mein Anliegen:
Einige Mitarbeiter speichern meine Vorlage irgendwo auf einem Server.
Dadurch können die Pfade sehr lang werden und machen mein Inhaltsverzeichnis unübersichtlich, da die erstellten Hyperlinks den kompletten Pfad als Text anzeigen.
Kannst Du (oder jemand anderes) den code so ändern, dass als Text in den Hyperlinks nur der Dateiname mit Endung aber ohne den ganzen Pfad steht?
Ich habe es selbst schon probiert, aber einfach nicht geschafft. :-(
Wäre für jede Hilfe dankbar.
Gruß Andreas

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: an Heiko S. (evtl. auch jemand anderes)
23.03.2006 09:50:05
Heiko
Hallo Andreas,
bevor sich da jemand anderes reindenken muss, so sollte es gehen:

Sub ShowDir()
Dim inthelp As Integer, intN As Integer, intI As Integer
Dim strPfad As String
Application.ScreenUpdating = False
strPfad = "D:\"
Erase strDirs
Erase intTiefe
Erase strPaths
ReDim Preserve strDirs(intArrayCounter)
ReDim Preserve strPaths(intArrayCounter)
ReDim Preserve intTiefe(intArrayCounter)
strDirs(0) = strPfad
strPaths(0) = strPfad
intTiefe(0) = 1
intTiefeMerker = 1
intArrayCounter = 1
ShowFolderList1 (strPfad)
ActiveSheet.Cells.Delete
intN = 1
For inthelp = LBound(strDirs) To UBound(strDirs)
ActiveSheet.Hyperlinks.Add ActiveSheet.Cells(intN, intTiefe(inthelp)), _
Address:=strPaths(inthelp), TextToDisplay:=strDirs(inthelp)
ActiveSheet.Cells(intN, intTiefe(inthelp)).Font.Bold = True
ActiveSheet.Cells(intN, intTiefe(inthelp)).Font.ColorIndex = 3
With Application.FileSearch
.NewSearch
.LookIn = strPaths(inthelp)
.SearchSubFolders = False
.FileType = msoFileTypeAllFiles
.Execute
If .FoundFiles.Count > 0 Then
For intI = 1 To .FoundFiles.Count
ActiveSheet.Hyperlinks.Add ActiveSheet.Cells(intN, intTiefe(inthelp) + 1), _
Address:=.FoundFiles(intI), TextToDisplay:= _
Right(.FoundFiles(intI), Len(.FoundFiles(intI)) - InStrRev(.FoundFiles(intI), "\"))
intN = intN + 1
Next intI
End If
End With
intN = intN + 1
Next inthelp
Application.ScreenUpdating = True
End Sub

Gruß Heiko
PS: Rückmeldung wäre nett !
Anzeige
Zusatzinfo
23.03.2006 09:52:59
Heiko
Hallo Andreas,
habe das mit meinem Ursprungsmakro getestet, muss du also für deine Version noch anpassen. Der Bereich der geändert wurde ist dieser hier !!!
For intI = 1 To .FoundFiles.Count
ActiveSheet.Hyperlinks.Add ActiveSheet.Cells(intN, intTiefe(inthelp) + 1), _
Address:=.FoundFiles(intI), TextToDisplay:= _
Right(.FoundFiles(intI), Len(.FoundFiles(intI)) - InStrRev(.FoundFiles(intI), "\"))
intN = intN + 1
Next intI
Gruß Heiko
PS: Rückmeldung wäre nett !
AW: an Heiko S. (evtl. auch jemand anderes)
23.03.2006 09:55:17
andreas
Perfekt!!
Vielen Dank
Gruß Andreas

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige