Hyperlinks automatisch auf Dateien erstellen

Private Function FileArray(strPath As String, strPattern As String) Dim arrDateien() Dim intCounter As Integer Dim strDatei As String If Right(strPath, 1) <> "\" Then strPath = strPath & "\" strDatei = Dir(strPath & strPattern) Do While strDatei <> "" intCounter = intCounter + 1 ReDim Preserve arrDateien(1 To intCounter) arrDateien(intCounter) = strDatei strDatei = Dir() Loop FileArray = arrDateien End Function

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

HI Roland
lege 2 module an
Modul2
'Verzeichniss einlesen als Hyperlink
Private Sub Link_Click()
  Application.ScreenUpdating = False

    Dim strInitialDir As String, strPath As String
    Dim sFile As String, sPattern As String, sPath As String
    Dim iRow As Integer
    Columns(1).ClearContents

    sPath = BrowseDirectory()
    If sPath = "" Then Exit Sub
'einlesen
    If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
    sPattern = "*.*" 'auch andere endung möglich mp3,jpg usw.
    sFile = Dir(sPath & sPattern)
    Do Until sFile = ""
        iRow = iRow + 1
        ActiveSheet.Hyperlinks.Add Anchor:=Cells(iRow, 1), _
        Address:=sPath & sFile, TextToDisplay:=sFile
        sFile = Dir()
    Loop
End Sub
'################################################
modul1
Private Declare Function SHBrowseForFolder Lib "shell32" _
    (lpbi As BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" _
    (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
    (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
     lParam As Any) As Long
Private Declare Function SHSimpleIDListFromPath Lib "shell32" Alias "#162" _
    (ByVal szPath As String) As Long
Private Const BIF_RETURNONLYFSDIRS As Long = 1
Private Const BIF_DONTGOBELOWDOMAIN As Long = 2
Private Const BFFM_INITIALIZED As Long = 1
Private Const MAX_PATH As Long = 260
Private Const WM_USER As Long = &H400
Private Const BFFM_SETSTATUSTEXTA As Long = (WM_USER + 100)
Private Const BFFM_SETSELECTIONA As Long = (WM_USER + 102)
Private Const BFFM_SETSELECTIONW As Long = (WM_USER + 103)
Private Const BFFM_SETSTATUSTEXTW As Long = (WM_USER + 104)
Private Type BROWSEINFO
    hwndOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfnCallback As Long
    lParam As Long
    iImage As Long
End Type
' Callback für die Browse-Directory-Methode - "pidList"-Methode
' zur Verwendung in der BrowseDirectory()-Funktion
Private Function BrowseCallBackProc(ByVal hWnd As Long, _
        ByVal uMsg As Long, ByVal lParam As Long, _
        ByVal lpData As Long) As Long
    'Voreinstellung des Verzeichnisses im Verzeichnis-
    'Dialog unter Verwendung des Parameters "pidList"
    Select Case uMsg
    Case BFFM_INITIALIZED
        Call SendMessage(hWnd, BFFM_SETSELECTIONA, False, ByVal lpData)
    Case Else
    End Select
End Function
' Dummy-Methode, um den Inhalt des AddressOf-Operators zu erhalten und
' zur Verwendung in der BrowseDirectory()-Funktion zurückzugeben
Private Function FARPROC(pfn As Long) As Long
    'Einstellen und Erhalten der Adresse für ein Callback. Das ist notwendig,
    'weil man "AddressOf" nicht direkt einem benutzerdefinierten Typ zuweisen
    'kann. Man kann es aber einer anderen Variablen vom Typ "Long" zuweisen,
    'der - wie hier auch von der Function zurückgegeben - weiter verwendet
    'werden kann.
    FARPROC = pfn
End Function
' "pidList"-Parameter für den vorgegebenen Pfad wird durch den Aufruf
' der undokumenteierten API-Funktion #162 zurückgegeben.
Private Function GetPIDLFromPath(ByVal sPath As String) As Long
    'If IsWinNT Then
        GetPIDLFromPath = SHSimpleIDListFromPath(StrConv(sPath, vbUnicode))
    'Else
    '    GetPIDLFromPath = SHSimpleIDListFromPath(sPath)
    'End If
End Function
Public Function BrowseDirectory(Optional ByVal strInitialDir As String, Optional ByVal _
        hWnd As Long) As String
    Dim lpIDList As Long
    Dim sBuffer As String
    Dim szTitle As String
    Dim tBrowseInfo As BROWSEINFO
    szTitle = "Please select a directory"
    With tBrowseInfo
        .hwndOwner = hWnd
        .pidlRoot = 0
        .lpszTitle = szTitle
'        .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
        .lpfnCallback = FARPROC(AddressOf BrowseCallBackProc)
        .lParam = GetPIDLFromPath(strInitialDir)
    End With
    lpIDList = SHBrowseForFolder(tBrowseInfo)
    If (lpIDList) Then
        sBuffer = Space(MAX_PATH)
        SHGetPathFromIDList lpIDList, sBuffer
        sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
        BrowseDirectory = sBuffer
        ' Ressourcen freigeben
        CoTaskMemFree lpIDList
    Else
        BrowseDirectory = strInitialDir
    End If
    ' Ressourcen freigeben
    CoTaskMemFree tBrowseInfo.lParam
End Function
Sub OrdnerAuswahl()
    Dim strInitialDir As String, strPath As String

    strPath = BrowseDirectory()

End Sub
    'Verzeichnisdialog mit Voreinstellung anzeigen
'    strInitialDir = "C:\Daten"
'    strPath = BrowseDirectory(strInitialDir)
gruss
ivan

Private Sub Link_Click() Application.ScreenUpdating = False Dim strInitialDir As String, strPath As String Dim sFile As String, sPattern As String, sPath As String Dim iRow As Integer Columns(1).ClearContents sPath = BrowseDirectory() If sPath = "" Then Exit Sub 'einlesen If Right(sPath, 1) <> "\" Then sPath = sPath & "\" sPattern = "*.*" 'auch andere endung möglich mp3,jpg usw. sFile = Dir(sPath & sPattern) Do Until sFile = "" iRow = iRow + 1 ActiveSheet.Hyperlinks.Add Anchor:=Cells(iRow, 1), _ Address:=sPath & sFile, TextToDisplay:=sFile sFile = Dir() Loop End Sub

Private Function BrowseCallBackProc(ByVal hWnd As Long, _ ByVal uMsg As Long, ByVal lParam As Long, _ ByVal lpData As Long) As Long 'Voreinstellung des Verzeichnisses im Verzeichnis- 'Dialog unter Verwendung des Parameters "pidList" Select Case uMsg Case BFFM_INITIALIZED Call SendMessage(hWnd, BFFM_SETSELECTIONA, False, ByVal lpData) Case Else End Select End Function

Private Function FARPROC(pfn As Long) As Long 'Einstellen und Erhalten der Adresse für ein Callback. Das ist notwendig, 'weil man "AddressOf" nicht direkt einem benutzerdefinierten Typ zuweisen 'kann. Man kann es aber einer anderen Variablen vom Typ "Long" zuweisen, 'der - wie hier auch von der Function zurückgegeben - weiter verwendet 'werden kann. FARPROC = pfn End Function

Private Function GetPIDLFromPath(ByVal sPath As String) As Long 'If IsWinNT Then GetPIDLFromPath = SHSimpleIDListFromPath(StrConv(sPath, vbUnicode)) 'Else ' GetPIDLFromPath = SHSimpleIDListFromPath(sPath) 'End If End Function

Private Sub Link_Klick() ist ein commandbutton der umbenant ist Privat Sub CommandBotton1()'ursprung Sub Link_Klick() KANN NUR IM MODUL AUFGERUFEN WEDEN beispiel: Privat Sub CommandBotton1() Call Link End Sub

Hallo Ivan,
mit suchbegriff subdirectoties habe ich folgenden Beitrag gefunden.
Vieleicht kannst Du damit ja was anfangen und in Deinen Code übernehmen.
An Deinem gesamtwerk wäre ich natürlci weiterhin interessiert.
Roland
Zitat von Helmut T. vom 08.05.2003:
"Hi,
hatte vor kurzem ein ähnliches Problem.
Anbei ein paar Code-Zeilen, die Dir helfen sollten. Ist noch nicht optimiert, aber läuft.
Die Datei mail ich Dir zu.
Das Makro generiert einen Report mit allen xls-Dateien und den Links darin.
Grüße,
Helmut.


Sub FSearch()
' macro to analyse xls files in a given path and all subdirectories
' reading created/modified date, password status, link sources, no. of sheets and sheet protection status
' setting report and control sheets and clearing report output area
Set my_reps1 = ThisWorkbook.Worksheets("Report1")
my_reps1.Range("A2:IV65536").Clear
Set my_ctrls = ThisWorkbook.Worksheets("Control")
' read search path from control sheet and reset statistic fields
my_path = my_ctrls.Cells(2, 2).Value
my_ctrls.Range("B3:B20").ClearContents
' ensure path exists
Set check_path = CreateObject("Scripting.FileSystemObject")
If check_path.folderexists(my_path) = False Then
MsgBox "Path " & my_path & " not found." & Chr(13) & _
"Please enter correct path in control sheet." & Chr(13) & _
"Exiting macro ..."
Exit Sub
End If
' write start time to control sheet
my_starttime = Now()
my_ctrls.Cells(3, 2) = my_starttime
' speed up macro by suppressing recalc and screen redrawing
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' capture errors, especially when opening files, and deal with them by error code
On Error GoTo MyErrorHandler1:
' open file search loop, setting file counters to zero
my_filecounter = 0
my_pwfilecounter = 0
my_pws_filecounter = 0
' display progress
Application.ScreenUpdating = True
my_ctrls.Cells(5, 2) = "Scanning path " & my_path
Application.ScreenUpdating = False
With Application.FileSearch
.NewSearch
.LookIn = my_path
.SearchSubFolders = True
.Filename = "*.xls"                     ' only xls files, no xlk or other Excel type files
If .Execute(SortBy:=msoSortByLastModified, Sortorder:=msoSortOrderDescending) > 0 Then
my_row = 2                              ' initiate row counter for report output
my_totalfiles = .FoundFiles.Count       ' see how many files are found
For IndFile = 1 To .FoundFiles.Count
cur_file = .FoundFiles(IndFile)     ' cur_file holds full file name incl. path
Set FS = CreateObject("Scripting.FileSystemObject")
Set f = FS.GetFile(cur_file)        ' get filedates from file object, without opening workbooks
repf_1 = f.DateCreated
repf_2 = f.datelastmodified
repf_3 = f.Size
repf_4 = f.Name
repf_5 = f.ParentFolder
my_pw = "NO"                ' default: no password
' write filename and dates to report before touching file
my_reps1.Cells(my_row, 1).Value = repf_5        ' folder
my_reps1.Cells(my_row, 2).Value = repf_4        ' filename
my_reps1.Cells(my_row, 3).Value = cur_file      ' full filename incl. path
my_reps1.Cells(my_row, 4).Value = repf_1        ' created date
my_reps1.Cells(my_row, 5).Value = repf_2        ' modified date
my_reps1.Cells(my_row, 6).Value = repf_3        ' filesize in bytes
' trying to open workbook now, using no password - and making sure this workbook is not re-opened
If cur_file <> ThisWorkbook.FullName Then
' stop auto exec macros from starting
Application.EnableEvents = False
Workbooks.Open Filename:=cur_file, updatelinks:=False, password:="", ReadOnly:=True
End If
' if opening fails due to password protection, record this in report
If my_pw = "YES" Then
my_reps1.Cells(my_row, 8).Value = my_pw
my_reps1.Cells(my_row, 11).Value = "N/A"
my_reps1.Cells(my_row, 9).Value = "N/A"
my_reps1.Cells(my_row, 10).Value = "N/A"
Else
' otherwise set link counter to zero and change it later if links are found
my_reps1.Cells(my_row, 11).Value = 0
End If
' if opening works, get required information from the workbook
If my_pw = "NO" Then
' write password status to report
my_reps1.Cells(my_row, 8).Value = my_pw
' write author to report
my_reps1.Cells(my_row, 7).Value = ActiveWorkbook.Author
' count number of sheets in the workbook
my_reps1.Cells(my_row, 9).Value = ActiveWorkbook.Sheets.Count
' loop through sheets and count protected sheets
my_prot_sheet_ctr = 0
For Each s In ActiveWorkbook.Sheets
If s.ProtectContents = True Then
my_prot_sheet_ctr = my_prot_sheet_ctr + 1
End If
Next s
my_reps1.Cells(my_row, 10).Value = my_prot_sheet_ctr
If my_prot_sheet_ctr > 0 Then
my_pws_filecounter = my_pws_filecounter + 1
End If
' check if there are links to other files
alinks = ActiveWorkbook.LinkSources()
If Not IsEmpty(alinks) Then
' write number of links to report
my_reps1.Cells(my_row, 11).Value = UBound(alinks)
' loop through links and record related files
For i = 1 To UBound(alinks)
my_reps1.Cells(my_row, 12).Value = alinks(i)
If i < UBound(alinks) Then
my_row = my_row + 1
End If
Next i
End If
End If
' close workbook in case it was opened
If my_pw = "NO" And ActiveWorkbook.FullName <> ThisWorkbook.FullName Then
ActiveWorkbook.Close savechanges:=False
Application.EnableEvents = True
End If
' start next report row
my_row = my_row + 1
' save this reporting file after every x-th workbook to avoid data loss in case
' the macro crashes due to filesystem errors or other imponderables
If my_row Mod 5 = 0 Then
ThisWorkbook.Save
End If
'increase filecounter
my_filecounter = my_filecounter + 1
If my_pw = "YES" Then
my_pwfilecounter = my_pwfilecounter + 1
End If
' update file counter field on control sheet and display briefly
Application.ScreenUpdating = True
my_ctrls.Cells(5, 2) = my_filecounter & " of " & my_totalfiles
my_ctrls.Cells(6, 2) = cur_file
Application.ScreenUpdating = False
Next IndFile
End If
End With
MyErrorHandler1:
If Err.Number <> 0 Then
If Err.Number = 1004 Then my_pw = "YES"     ' err 1004 = cannot open password protected file
Resume Next
End If
' write end time and statistics to control sheet
my_endtime = Now()
my_ctrls.Cells(4, 2) = my_endtime
my_runtime = my_endtime - my_starttime
my_ctrls.Cells(7, 2) = Format(my_runtime, "HH:MM:SS")
my_ctrls.Cells(5, 2) = my_filecounter & " of " & my_totalfiles
my_ctrls.Cells(6, 2) = "done."
my_ctrls.Cells(8, 2) = my_pwfilecounter
my_ctrls.Cells(9, 2) = my_pws_filecounter
MsgBox "File Analysis completed." & Chr(13) & my_filecounter & " files read."
End Sub

Beliebteste Forumthreads (12 Monate)

Hyperlinks automatisch auf Dateien erstellen

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Hyperlinks automatisch auf Dateien erstellen

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread