' ------------------------------------------------------------------------------------------------------------
' XLS-Makro zum Auslesen von Dateinamen in einer Ordnerstruktur und
' Vorbefüllung der RL_035 - VL_223_ASF_Vorlage_CSV_Vx.xx.xlsx
'
' Freeware - zur freien Verwendung und individuellen Anpassung
'
' Ersteller: DI. Gerald Egger, ASFINAG-BMG, Tel. +43 50108 14968 , email: gerald.egger@asfinag.at
' ------------------------------------------------------------------------------------------------------------

Option Explicit

Public FolderName0 As String
Public lenFolderName0 As Long
    

Sub Files_to_RL_035_CSV()

  Dim fd As FileDialog
  Dim Myfolder As Variant
  
  Set fd = Application.FileDialog(msoFileDialogFolderPicker)
  
  With fd
    .AllowMultiSelect = False
    If .Show Then
      For Each Myfolder In .SelectedItems
        FolderName0 = Myfolder & "\"
        lenFolderName0 = Len(FolderName0)
        Call ListFiles(FolderName0, , True)
      Next
    End If
  End With

End Sub




Public Function ListFiles(strPath As String, Optional strFileSpec As String, _
                          Optional bIncludeSubfolders As Boolean)

 On Error GoTo Err_Handler
    'Purpose:   List the files in the path.
    'Arguments: strPath = the path to search.
    '           strFileSpec = "*.*" unless you specify differently.
    '           bIncludeSubfolders: If True, returns results from subdirectories of strPath as well.
    
    'Method:    FilDir() adds items to a collection, calling itself recursively for subfolders.
    
    Dim colDirList As New Collection
    Dim varItem As Variant
    
    Call FillDir(colDirList, strPath, strFileSpec, bIncludeSubfolders)
    
    Sheets("Dateiliste").Select
    
    Dim sRow As Long
    sRow = 3
    
    For Each varItem In colDirList
      If CheckFilenaOK(get_filena(CStr(varItem))) Then                                      ' Spalten ->
        Cells(sRow, 2).Value = get_Stichwoerter(Mid(CStr(varItem), lenFolderName0 + 1))     ' Ablageregister = Ordnerbezeichnungen
        Cells(sRow, 3).Value = "Bestandsdokumentation"                                      ' Kategorisierung
        Cells(sRow, 4).Value = get_filena(CStr(varItem))                                    ' Dateiname
                                                                                            ' Dokumentart - Teil-Erkennung
            If UCase(Right(get_filena(CStr(varItem)), 3)) = "DWG" Then
                Cells(sRow, 5).Value = "Plan"
            ElseIf UCase(Right(get_filena(CStr(varItem)), 3)) = "DXF" Then
                Cells(sRow, 5).Value = "Plan"
            ElseIf UCase(Right(get_filena(CStr(varItem)), 3)) = "PLT" Then
                Cells(sRow, 5).Value = "Plan"
            ElseIf UCase(Right(get_filena(CStr(varItem)), 3)) = "JPG" Then
                Cells(sRow, 5).Value = "Foto"
            ElseIf UCase(Right(get_filena(CStr(varItem)), 3)) = "SOR" Then
                Cells(sRow, 5).Value = "Protokoll"
            ElseIf Right(LCase(get_filena(CStr(varItem))), InStr(1, StrReverse(get_filena(CStr(varItem))), ".") - 1) Like "*xls*" Then
                Cells(sRow, 5).Value = "Aufstellung/Liste"
            ElseIf LCase(get_filena(CStr(varItem))) Like "*protokoll*" Then
                Cells(sRow, 5).Value = "Protokoll"
            ElseIf LCase(get_filena(CStr(varItem))) Like "*gutachten*" Then
                Cells(sRow, 5).Value = "Gutachten"
            ElseIf LCase(get_filena(CStr(varItem))) Like "*prüfbe*" Then
                Cells(sRow, 5).Value = "Prüfbericht/-befund"
            ElseIf LCase(get_filena(CStr(varItem))) Like "*datenblatt*" Then
                Cells(sRow, 5).Value = "Datenblatt"
            ElseIf LCase(get_filena(CStr(varItem))) Like "*betriebshandbuch*" Then
                Cells(sRow, 5).Value = "Betriebshandbuch"
            ElseIf LCase(get_filena(CStr(varItem))) Like "*aufstellung*" Then
                Cells(sRow, 5).Value = "Aufstellung/Liste"
            ElseIf LCase(get_filena(CStr(varItem))) Like "*schulungsunterlage*" Then
                Cells(sRow, 5).Value = "Schulungsunterlage"
            End If

        Cells(sRow, 6).Value = get_Stichwoerter(Mid(CStr(varItem), lenFolderName0 + 1))     ' Stichwörter = Ordnerbezeichnungen
 
       sRow = sRow + 1
      End If
    Next

Exit_Handler:
    Exit Function

Err_Handler:
    MsgBox "Error " & Err.Number & ": " & Err.Description
    Resume Exit_Handler
End Function


Private Function FillDir(colDirList As Collection, ByVal strFolder As String, strFileSpec As String, _
    bIncludeSubfolders As Boolean)
    'Build up a list of files, and then add add to this list, any additional folders
    Dim strTemp As String
    Dim colFolders As New Collection
    Dim vFolderName As Variant

    'Add the files to the folder.
    strFolder = TrailingSlash(strFolder)
    strTemp = Dir(strFolder & strFileSpec)
    Do While strTemp <> vbNullString
        colDirList.Add strFolder & strTemp
        strTemp = Dir
    Loop

    If bIncludeSubfolders Then
        'Build collection of additional subfolders.
        strTemp = Dir(strFolder, vbDirectory)
        Do While strTemp <> vbNullString
            If (strTemp <> ".") And (strTemp <> "..") Then
                If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0& Then
                    colFolders.Add strTemp
                End If
            End If
            strTemp = Dir
        Loop
        'Call function recursively for each subfolder.
        For Each vFolderName In colFolders
            Call FillDir(colDirList, strFolder & TrailingSlash(vFolderName), strFileSpec, True)
        Next vFolderName
    End If
End Function


Public Function TrailingSlash(varIn As Variant) As String
    If Len(varIn) > 0& Then
        If Right(varIn, 1&) = "\" Then
            TrailingSlash = varIn
        Else
            TrailingSlash = varIn & "\"
        End If
    End If
End Function


Function get_Stichwoerter$(T_txt As String)
' ------------------------------------------------------------------------------------------------------------
' -> Austausch von "\" in "|"
' ------------------------------------------------------------------------------------------------------------

   Dim Fnd_str_pos, lst_str_pos As Long
   Dim n_txt As String

   n_txt = LTrim$(RTrim$(T_txt))
   Fnd_str_pos = 1

   Do While Not (Fnd_str_pos = 0)
    lst_str_pos = Fnd_str_pos
    Fnd_str_pos = InStr(lst_str_pos + 1, n_txt, "\")
   Loop

   get_Stichwoerter$ = Replace(Mid$(n_txt, 1, lst_str_pos - 1), "\", "|")
End Function


Function get_filena$(ByRef T_txt As Variant)
' ------------------------------------------------------------------------------------------------------------
' -> Filename ohne Pfad
' ------------------------------------------------------------------------------------------------------------

   Dim Fnd_str_pos, lst_str_pos As Long
   Dim n_txt As String

   n_txt = LTrim$(RTrim$(T_txt))
   Fnd_str_pos = 1

   Do While Not (Fnd_str_pos = 0)
    lst_str_pos = Fnd_str_pos
    Fnd_str_pos = InStr(lst_str_pos + 1, n_txt, "\")
   Loop

   get_filena$ = Mid$(n_txt, lst_str_pos + 1)
End Function


Function CheckFilenaOK(ByVal T_Filena As String) As Boolean
' ------------------------------------------------------------------------------------------------------------
' -> Filenamen von Verarbeitung ausgeschlossen
' ------------------------------------------------------------------------------------------------------------

  CheckFilenaOK = True
  
  If UCase(T_Filena) = "THUMBS.DB" Then
    CheckFilenaOK = False
    Exit Function
  End If

  If UCase(T_Filena) = "PLOT.LOG" Then
    CheckFilenaOK = False
    Exit Function
  End If
 
End Function