an Heiko S. (evtl. auch jemand anderes)
23.03.2006 09:36:45
andreas
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