Attribute VB_Name = "Modul1"
Option Explicit

'    <Renames FOlders after the First name in the Folder>
'    Copyright (C) <2021>  <Konrad Ferlangen>
'
'    This program is free software: you can redistribute it and/or modify
'    it under the terms of the GNU General Public License as published by
'    the Free Software Foundation, either version 3 of the License, or
'    (at your option) any later version.
'
'    This program is distributed in the hope that it will be useful,
'    but WITHOUT ANY WARRANTY; without even the implied warranty of
'    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
'    GNU General Public License for more details.
'
'    You should have received a copy of the GNU General Public License
'    along with this program.  If not, see <https://www.gnu.org/licenses/>.
Private Sub pickFolder()
Dim pick As FileDialog
Dim sFolder As String
Dim fdName As String
Dim sFileName As String
Dim zeile As Long

Set pick = Application.FileDialog(msoFileDialogFolderPicker)


zeile = Cells(Rows.Count, 1).End(xlUp).Row
Cells(1, 1).Clear
Range(Cells(2, 1), Cells(zeile, 6)).Clear
With pick
        .AllowMultiSelect = False
        .Show
        sFolder = .SelectedItems.Item(1) & "\"
End With
Cells(1, 1).Value = sFolder


fdName = Dir(sFolder, vbDirectory)    ' Ersten Eintrag abrufen.
zeile = 2
Do While fdName <> ""    ' Schleife beginnen.
    ' Aktuelles und übergeordnetes Verzeichnis ignorieren.
    If fdName <> "." And fdName <> ".." Then
        ' Mit bit-weisem Vergleich sicherstellen, daß Name1 ein Verzeichnis ist.
        If (GetAttr(sFolder & "\" & fdName) And vbDirectory) = vbDirectory Then
            Cells(zeile, 1).Value = fdName     ' Eintrag nur anzeigen, wenn es sich
            zeile = zeile + 1

        End If    ' um ein Verzeichnis handelt.
    End If
    fdName = Dir   ' Nächsten Eintrag abrufen.
Loop
zeile = 2
Do While IsEmpty(Cells(zeile, 1).Value) = False
            fdName = Cells(zeile, 1).Value
            sFileName = Dir(Cells(1, 1).Value & fdName & "\*.jpg")
            Cells(zeile, 2).Value = sFileName
            zeile = zeile + 1
Loop
End Sub

Private Sub findFilename()
Dim sFileName As String
Dim lenFile As Long
Dim zeile As Long
Dim pos As Long
Dim r As Range

zeile = 2
Do While IsEmpty(Cells(zeile, 1).Value) = False
            sFileName = Cells(zeile, 2).Value
            If sFileName <> "" Then
                lenFile = Len(sFileName)
                If lenFile > 10 Then
                    Cells(zeile, 3).Value = Left(sFileName, lenFile - 4)
                    Cells(zeile, 4).Value = Left(sFileName, lenFile - 10)
                    pos = InStrRev(Cells(zeile, 4).Value, "_")
                    If pos > 0 Then
                        Cells(zeile, 5).Value = Left(sFileName, pos - 1)
                        Else
                        Cells(zeile, 5).Value = Left(sFileName, lenFile - 10)
                        End If
                End If
            End If
            
            zeile = zeile + 1
Loop
Set r = Range(Cells(2, 5), Cells(zeile, 5))
    r.FormatConditions.Delete
    ' r.FormatConditions(1).DupeUnique = xlDuplicate
    r.FormatConditions.AddUniqueValues
    r.FormatConditions(1).DupeUnique = xlDuplicate
    With r.FormatConditions(1).Font
        .Color = -16383844
        .TintAndShade = 0
    End With
    With r.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 13551615
        .TintAndShade = 0
    End With
    r.FormatConditions.Add Type:=xlExpression, Formula1:="=LÄNGE(GLÄTTEN(E2))<=1"
    r.FormatConditions.Add Type:=xlExpression, Formula1:="=LEN(TRIM(E2))<=1"
        With r.FormatConditions(2).Font
        .Color = -16383844
        .TintAndShade = 0
    End With
    With r.FormatConditions(2).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 13551615
        .TintAndShade = 0
    End With
    With r.FormatConditions(3).Font
        .Color = -16383844
        .TintAndShade = 0
    End With
    With r.FormatConditions(3).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 13551615
        .TintAndShade = 0
    End With
    
Set r = Nothing
MsgBox "Loading names complete"
End Sub



Private Sub RenameFolder(clm As Long)
Dim lstRw As Long
Dim rw As Long
On Error Resume Next

lstRw = Cells(Rows.Count, 1).End(xlUp).Row

For rw = 2 To lstRw
    If Cells(rw, clm) <> "" Then
         Name Cells(1, 1).Value & Cells(rw, 1).Value As Cells(1, 1).Value & Cells(rw, clm).Value
    End If
Next rw

MsgBox "Renaming complete"
End Sub


Public Sub prepareFlderList(Optional a)
Modul1.pickFolder
Modul1.findFilename

End Sub


'Public Sub ColumnC()
'RenameFolder (3)
'End Sub
'
'Public Sub ColumnD()
'RenameFolder (4)
'End Sub

Public Sub ColumnE()
RenameFolder (5)
End Sub