bestandnaam uit window explorer naar EXCEL

[Warme bakkertje]

Dit heb ik er van gemaakt.

Sub GetFilesInFolder()

  With Application.FileDialog(msoFileDialogFolderPicker)
      If .Show Then folder = .SelectedItems(1) & "\"
  End With
  If InStr(1, folder, " ", vbBinaryCompare) > 0 Then
    sn = Split(CreateObject("wscript.shell").exec("cmd /c dir " & """" & folder & "*.jp*" & """" & " /b").stdout.readall, vbCrLf)
  Else
    sn = Split(CreateObject("wscript.shell").exec("cmd /c dir " & folder & "*.jp* /b").stdout.readall, vbCrLf)
  End If
  With ActiveSheet
      .UsedRange.ClearContents
      .Cells(1) = folder
      .Cells(2, 1).Resize(UBound(sn) + 1) = Application.Transpose(sn)
  End With
  
End Sub

Sub ChangeNameInFolder()
    
    With Sheets("Blad1")
        fDir = .Cells(1).Value
        sn = .Cells(1).CurrentRegion
        For i = 2 To UBound(sn)
            On Error Resume Next
            Name fDir & sn(i, 1) As fDir & sn(i, 2) & Right(sn(i, 1), Len(sn(i, 1)) - InStrRev(sn(i, 1), ".") + 1)
        Next
    End With
    On Error GoTo 0
    
End Sub

De redenen waarom ik het zo gemaakt zijn volgende
1. Geen inputbox omdat typo's snel gemaakt zijn. Door te laten selecteren in een verkenner sluit je dit uit.
2. Omdat je als extensie 'jpg' als ook 'jpeg' hebt moet je hier veralgemenen door 'jp*' te gebruiken.
3. Omdat er directorys kunnen zijn met spaties in moet je hierop anticiperen.
4. Wederom door de extensies kan je niet veralgemenen met het hernoemen en gebruik je best de originele extensie v/d bestandsnaam.
Dit zijn allemaal persoonlijke indrukken dus is het nu aan de echte experts voor aanpassingen en verbeteringen.

 

[snb]

Voortbordurend op...:

Sub M_snb()
  With Application.FileDialog(msoFileDialogFolderPicker)
    .Show
    sn = Split(.SelectedItems(1) & vbCrLf & CreateObject("wscript.shell").exec("cmd /c dir """ & .SelectedItems(1) & "\*.jp*"" /b").stdout.readall, vbCrLf)
  End With
      
  With Sheets("namen")
      .UsedRange.ClearContents
      .Cells(1).Resize(UBound(sn) + 1) = Application.Transpose(sn)
  End With
End Sub

PS. Ik vermijd bij voorkeur 'activesheet', omdat ik dan niet zeker weet waar het resultaat tercht zal komen.

 

[Warme bakkertje]

Nog 1 kleine aanpassing zodat de laatste backslash automatisch toegevoegd wordt aan het pad, dit om bij later gebruik eventuele foutmeldingen of extra controle te vermijden.

Sub GetFilesInFolder()
  With Application.FileDialog(msoFileDialogFolderPicker)
    .Show
    sn = Split(.SelectedItems(1) & [COLOR="#FF0000"]"\"[/COLOR] & vbCrLf & CreateObject("wscript.shell").exec("cmd /c dir """ & .SelectedItems(1) & "\*.jp*"" /b").stdout.readall, vbCrLf)
  End With
      
  With Sheets("namen")
      .UsedRange.ClearContents
      .Cells(1).Resize(UBound(sn) + 1) = Application.Transpose(sn)
  End With
End Sub

En zo is het ophalen v/d bestanden mi perfect en supersnel
Tip: Als je het filter (*.jp*) nu ook nog variabel maakt kan deze procedure ook gebruikt worden om andere soorten bestanden op te halen.

 

[snb]

@WB

Kijk nog eens goed naar de code: die backslash voegt niets toe en voorkomt ook geen fout, omdat het alleen om de naam van de folder gaat die in cel A1 terecht komt.

en dan is het nog maar een kleine stap naar:

Function fls_snb(c00, c01)
    fls_snb = Split(CreateObject("wscript.shell").exec("cmd /c dir """ & c00 & "\*." & c01 & """ /b").stdout.readall, vbCrLf)
End Function

Sub M_snb()
    sn = fls_snb("G:\OF", "jpg")
    
    Cells(1).Resize(UBound(sn) + 1) = Application.Transpose(sn)
End Sub

 

[Warme bakkertje]

Toch wel want die waarde wordt gebruikt door de volgende macro om de directory aan te geven waarin de naamsverandering moet gebeuren.

 

[snb]

@WB

Niet als:

Sub ChangeNameInFolder()
  sn= Sheets("Blad1").Cells(1).CurrentRegion

  For j = 2 To UBound(sn)
    Name sn(1,1) & "\" & sn(j, 1) As sn(1,1) & "\" & sn(j, 2) & "." & createobject("scripting.filesystemobject").getextensionname(sn(j,1))
  Next
End Sub

 

[Warme bakkertje]

Dan wel deze

Name sn([COLOR="#FF0000"]1[/COLOR],1) & "\" & sn(j, 1) As sn([COLOR="#FF0000"]1[/COLOR],1) & "\" & sn(j, 2) & "." & createobject("scripting.filesystemobject").getextensionname(sn(j,1))

 

[snb]

Mee eens.:thumb:

 

[Warme bakkertje]

Moest TS ondertussen door de bomen het bos niet meer zien
Dit zijn ze dus.

Sub GetFilesInFolder()

    With Application.FileDialog(msoFileDialogFolderPicker)
        .Show
        sn = Split(.SelectedItems(1) & vbCrLf & CreateObject("wscript.shell").exec("cmd /c dir """ & .SelectedItems(1) & "\*.jp*"" /b").stdout.readall, vbCrLf)
    End With
    With Sheets("namen")
        .UsedRange.ClearContents
        .Cells(1).Resize(UBound(sn) + 1) = Application.Transpose(sn)
    End With
  
End Sub

Sub ChangeNameInFolder()
    
    With Sheets("namen")
        sn = .Cells(1).CurrentRegion
        For i = 2 To UBound(sn)
            On Error Resume Next
            Name sn(1, 1) & "\" & sn(i, 1) As sn(1, 1) & "\" & sn(i, 2) & "." & CreateObject("scripting.filesystemobject").GetExtensionName(sn(i, 1))
        Next
    End With
    On Error GoTo 0
    
End Sub

 

[snb]

Wat is de zin van 'on error resume next' ?

 

[Humadgen]

Heren, (neem tenminste aan dat jullie heren zijn)
Ik was inderdaad de weg kwijt en dacht al: " ik wacht het even af en kijk wel wat er na al deze discussie uitkomt. " dus bedankt voor de samenvatting.
Ga vanavond op mijn gemak met de code uit #29 uitproberen en zal laten weten of ik nog problemen tegenkom.
Zover bedankt voor alle moeite
Humadgen

Even een aanvulling, moest "verplicht" mijn computer een weekje rust geven van mijn echtgenote en mee op vakantie.
Ben vanavond thuisgekomen, dus kan nu eindelijk weer verder met testen, want ik had nog wel een probleempje ontdekt voordat ik wegging......to be continued.