Porządkowanie zdjęć na foldery wg daty wykonania zdjęcia   strona główna:
A po co ten Excel ;-)
     Program pisze specjalnie "dla Beatki"… może Ci się przyda :-)  
 
Powiedzmy że mamy folder ze zdjęciami z pewnego okresu czasu. Jest ich masa i marzy się nam poukładać je w folderach wg, no właśnie,    skrypt do pobrania:
daty wykonania zdjęcia. Data wykonania zdjęcia to właściwość pliku
  przenoszenie.zip
która nie zmienia się podczas kopiowania pliku lub jego np.: zmniejszaniu,  
czy prostej obróbce(np.: w MS Paint). Chodzi o tą -------> właściwość :-)  
 
Program ma za zadanie:  
 - odczyt z danego pliku ww właściwości.  
 - sprawdzenie czy Folder o nazwie: 'odczytana data' już istnieje. Jak nie to go   
   tworzy  
 - przeniesienie pliku do tego folderu  
 - powtórzenie tej procedury dla wszystkich plików w danym folderze  
 
Dodatkowo:  
 - chce żeby program działał w folderze w którym znajduje się plik z programem   Kurs VBA (1-4)
VB Magazine
   i tu też tworzył foldery wg dat odczytanych z plików  
 - nie chcę żeby program był częścią pliku Excela (nie był od niego uzależniony)  
   Przedstawione tu rozwiązanie będzie w vbs.  
  Centrum skryptów
http://technet.microsoft.com/
Program realizujący wymienione zadania wg określonych założeń może  
wyglądać np. tak:  
 
Dim strVBSFolder 'As String  
Dim strVBSFile 'AS String  
 
strVBSFolder = Left(WScript.ScriptFullName, _  
            InStrRev(WScript.ScriptFullName, _  
                            "\", _  
                            Len(WScript.ScriptFullName)))  
strVBSFile = Right(WScript.ScriptFullName, _  
                   Len(WScript.ScriptFullName) - InStrRev(WScript.ScriptFullName, _  
                                                          "\", _  
                                                          Len(WScript.ScriptFullName)))  
 
If MsgBox("Czy napewno chcech posortować folder: " & Chr(10) & strVBSFolder, _  
          vbQuestion + vbOKCancel, _  
         "Nie będzie odwrotu!!!") = vbOK Then  
 
    Dim objShell 'As Shell32.Shell  
    Dim objFolder 'As Shell32.Folder  
    Dim oFile 'As Shell32.FolderItem  
    Dim strTime 'As String  
 
    Dim objFSO 'As Object 'Scripting.FileSystemObject  
    Set objFSO = CreateObject("Scripting.FileSystemObject")  
    Dim strNewDir 'As String  
      
    Set objShell = CreateObject("Shell.Application")  
    Set objFolder = objShell.Namespace(strVBSFolder)  
 
    Dim i 'As Integer ' ilość nowych folderów  
    Dim j 'As Long    ' ilość przeniesionych plików  
    Dim k 'AS Long    ' ilość plików nie przeniesopnych  
 
    Const sHeading = 12 'Date taken  
      
    For Each oFile In objFolder.Items  
        If Not oFile.IsFolder Then  
            If oFile.Name <> strVBSFile Then  
                strTime = Replace_RegExp(objFolder.GetDetailsOf(objFolder.Parsename(oFile.Name), _  
                                                                sHeading), "[^\d\-\: ]", "")  
                If Len(strTime) > 0 Then  
                    strNewDir = objFolder.Self.Path & "\" & Left(strTime, 10)  
                    With objFSO  
                        If Not .FolderExists(strNewDir) Then  
                           .CreateFolder strNewDir  
                           i = i + 1  
                        End If  
                        .MoveFile oFile.Path, strNewDir & "\" & oFile.Name  
                        j = j + 1  
                    End With  
                Else  
                    k = k + 1  
                End If  
            End If  
        End If  
    Next  
      
    If i > 0 Then  
        MsgBox "przeniesionych plików: " & j & Chr(10) & _  
               "utworzonych nowych folderów: " & i, vbInformation, "Koniec :-)"  
    Else  
        MsgBox "Nie ma tu nic do roboty :-|", vbInformation  
    End If  
 
    If k > 0 Then  
    MsgBox "Pozostałe pliki (szt: " & k & ") mają nieokreśloną datę utworzenia pliku" & Chr(10) & _  
           "Ktoś przy nich grzebał!" & Chr(10) & Chr(10) & _  
           "Z tym nic nie zrobię :-) sorka!", vbInformation  
    End If  
 
    Set objFSO = Nothing  
    Set objShell = Nothing  
    Set objFolder = Nothing  
End If  
 
Function Replace_RegExp(vText, strFind, vReplace) 'As String  
      
    Dim objRegExp 'As VBScript.RegExp  
    Set objRegExp = CreateObject("VBScript.RegExp")  
    With objRegExp  
        .Global = True  
        .Pattern = strFind  
        Replace_RegExp = .Replace(vText, vReplace)  
    End With  
    Set objRegExp = Nothing  
      
End Function