<![CDATA[Серый форум — VBS: Перенос фото в папку с датой съемки]]> 2015-07-02T00:48:27Z PunBB https://forum.script-coding.com/viewtopic.php?id=10731 <![CDATA[Re: VBS: Перенос фото в папку с датой съемки]]> Flasher пишет:
Folder.GetDetailsOf(Folder.ParseName(Name), 12)

12? А у меня 25.
Сталкиваюсь с подобным явлением не впервые.
Поэтому, если возможно, предпочитаю ShellFolderItem.ExtendedProperty().
В данном случае:

Folder.ParseName(Name).ExtendedProperty("WhenTaken")

(или 

Folder.Items().Item(Name).ExtendedProperty("WhenTaken")

).

В этом случае возвращемое значение имеет тип именно Date, а не String, т.е. к нему применима функция DatePart() (у меня, правда, не возникло ошибки и при применении её к строке, возвращённой .GetDetailsOf()).

Ещё замечу, что значения возвращаемые GetDetailsOf и ExtendedProperty (после преобразования в строку) всё-таки отличаются, у меня для одного и того же файла, соответственно:
«26.08.2012 11:35» и
«26.08.2012 08:35:30» — осмелюсь утверждать, что первично именно второе, а первое строится на его основе с потерей точности и учётом часового пояса.

]]> https://forum.script-coding.com/profile.php?id=3850 2015-07-02T00:48:27Z https://forum.script-coding.com/viewtopic.php?pid=94855#p94855 <![CDATA[Re: VBS: Перенос фото в папку с датой съемки]]> Итоговая версия скрипта раскладывающая фото по дате съемки. Файлы у которых нет даты съемки, помещает в папку "Без даты":

Dim FSO, FldN, Fls, Fl, D, DtN, FlN
Set FSO = WScript.CreateObject("Scripting.FileSystemObject")

Do
    Set objFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Выберите каталог размещения файлов:", 0) 
    'Если пользователь не выбрал папку, завершаем приложение &H0001 + &H4000
    If objFolder Is Nothing Then Exit Do
    'Получаем путь к выбранной папке
    FldN = objFolder.Self.Path
    FoundColon = InStr(1,FldN,":",vbTextCompare)
    If FoundColon = 1 Then
        MsgBox "Вы выбрали некорректную папку размещения файлов попробуйте еще раз!"
    End if
Loop while(FoundColon = 1)

If objFolder Is Nothing Then
    MsgBox "Не выбран каталог размещения файлов"
Else

    If Not FSO.FolderExists(FldN) Then
        MsgBox "Папка """ & FldN & """ не существует. ", vbExclamation, "Ошибка"
        WScript.Quit
    End If

    Set Fls = FSO.GetFolder(FldN).Files

    Dim Path1, Folder, Name1, dd

    For Each Fl In Fls

        Path1 = FldN
        Name1 = Fl.Name
        'MsgBox "File is " &Fl.Name &" " &D &" = " &Fl.DateLastModified
        Set Folder = CreateObject("Shell.Application").NameSpace(Path1)
        dd = Folder.GetDetailsOf(Folder.ParseName(Name1), 12)
        'D = GetDateName(dd)

        If dd = "" Then
            D = "Нет_даты"
        Else
            dd = Split(Replace(dd, Left(dd, 1), ""))(0)
            D = Day(dd)   : If Len(D) = 1 Then D = "0" & D
            M = Month(dd) : If Len(M) = 1 Then M = "0" & M
            D = Year(dd) & "." & M & "." & D
        End If
        
        DtN = FSO.BuildPath(FldN, D)
        If Not FSO.FolderExists(DtN) Then 
        
            Dim tt
            tt = "Будет создана папка " &D &" и помещен файл " &Fl.Name &" " &D &" = " &Fl.DateLastModified
            'Создание папок по запросу
            'ExitFromName = MsgBox (tt, 36, "Прекратить создание папки?") 
            
            If ExitFromName = 6 Then 
                Exit For
            End If  
        
            FSO.CreateFolder DtN
        End If

        FlN = FSO.BuildPath(DtN, Fl.Name)
        If FSO.FileExists(FlN) Then
            If MsgBox("Файл """ & Fl.Name & """ уже существует в папке """ & D & """. " & vbCr & "Перезаписать?", vbQuestion + vbOKCancel, "Внимание") = vbOK Then
                FSO.DeleteFile FlN, True
                Fl.Move FlN
            End If
        Else
            Fl.Move FlN
        End If

    Next

    MsgBox "Скрипт завершен. ", vbInformation, "Финиш"
    WScript.Quit

End If

Если нужно контролировать создание папок вручную можно снять комментарий в коде "'"

'ExitFromName = MsgBox (tt, 36, "Прекратить создание папки?")
]]> https://forum.script-coding.com/profile.php?id=30994 2015-06-28T12:54:38Z https://forum.script-coding.com/viewtopic.php?pid=94785#p94785 <![CDATA[Re: VBS: Перенос фото в папку с датой съемки]]> Можно вообще избавиться от функции. И не забыть про потенциально отсутствующие нули.

    dd = Folder.GetDetailsOf(Folder.ParseName(Name1), 12)
    dd = Split(Replace(dd, Left(dd, 1), ""))(0)
    D = Day(dd)   : If Len(D) = 1 Then D = "0" & D
    M = Month(dd) : If Len(M) = 1 Then M = "0" & M
    D = Year(dd) & "-" & M & "-" & D
]]> https://forum.script-coding.com/profile.php?id=27593 2015-06-27T21:58:41Z https://forum.script-coding.com/viewtopic.php?pid=94782#p94782 <![CDATA[Re: VBS: Перенос фото в папку с датой съемки]]> Решил так:

Private Function GetDateName(Dt)

'MsgBox Dt
DMY = Split(Dt,".")
YYYY = Split(DMY(2)," ")
GetDateName = DMY(0) & "-" & DMY(1) & "-" & YYYY(0)
MsgBox GetDateName

End Function

Но думаю наверное можно более правильно это сделать.

]]> https://forum.script-coding.com/profile.php?id=30994 2015-06-27T21:07:55Z https://forum.script-coding.com/viewtopic.php?pid=94781#p94781 <![CDATA[Re: VBS: Перенос фото в папку с датой съемки]]> Наверное можно просто распарсить строку, точка разделитель.

]]> https://forum.script-coding.com/profile.php?id=30994 2015-06-27T20:58:31Z https://forum.script-coding.com/viewtopic.php?pid=94780#p94780 <![CDATA[Re: VBS: Перенос фото в папку с датой съемки]]> Спасибо получилось, Дату съемки получил, но теперь появилась другая ошибка когда произвожу перевод даты в другой формат.
Здесь пишет несоответствие типа:

      DateNow = Dt
    ' год
    y = DatePart("yyyy", DateNow)

Это весь код:

Dim FSO, FldN, Fls, Fl, D, DtN, FlN
Set FSO = WScript.CreateObject("Scripting.FileSystemObject")

'If WScript.Arguments.Count = 0 Then
'  MsgBox "Не задано имя папки для распределения файлов по датам. ", vbExclamation, "Ошибка"
'  WScript.Quit
'End If

Do
    Set objFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Выберите каталог размещения файлов:", 0) 
    'Если пользователь не выбрал папку, завершаем приложение &H0001 + &H4000
    If objFolder Is Nothing Then Exit Do
    'Получаем путь к выбранной папке
    objPath = objFolder.Self.Path

    FoundColon = InStr(1,objPath,":",vbTextCompare)
    'msgBox FoundColon
    If FoundColon = 1 Then
        MsgBox "Вы выбрали некорректную папку размещения файлов попробуйте еще раз!"
    End if

Loop while(FoundColon = 1)

If objFolder Is Nothing Then
    MsgBox "Не выбран каталог размещения файлов"
    'DynamicContent_Div.InnerHTML = "Не выбран каталог размещения файлов"
    
Else

FldN = objPath

'FldN = WScript.Arguments(0)


If Not FSO.FolderExists(FldN) Then
  MsgBox "Папка """ & FldN & """ не существует. ", vbExclamation, "Ошибка"
  WScript.Quit
End If

Set Fls = FSO.GetFolder(FldN).Files




Dim Path1, Folder, Name1, dd
For Each Fl In Fls

    Path1 = FldN
    Name1 = Fl.Name
    
    'MsgBox Path1
    
    'MsgBox "File is " &Fl.Name &" " &D &" = " &Fl.DateLastModified
    Set Folder = CreateObject("Shell.Application").NameSpace(Path1)
    dd = Folder.GetDetailsOf(Folder.ParseName(Name1), 12)
    D = GetDateName(dd)

    Dim tt
    tt = "File is " &Fl.Name &" " &D &" = " &Fl.DateLastModified
    ExitFromName = MsgBox (tt, 36, "Прекратить создание папки?") 
    'MsgBox ExitFromName
    If ExitFromName = 6 Then 
        Exit For
    End If  

  DtN = FSO.BuildPath(FldN, D)
  If Not FSO.FolderExists(DtN) Then FSO.CreateFolder DtN

  FlN = FSO.BuildPath(DtN, Fl.Name)
  If FSO.FileExists(FlN) Then
    If MsgBox("Файл """ & Fl.Name & """ уже существует в папке """ & D & """. " & vbCr & "Перезаписать?", vbQuestion + vbOKCancel, "Внимание") = vbOK Then
      FSO.DeleteFile FlN, True
      Fl.Move FlN
    End If
  Else
    Fl.Move FlN
  End If
Next

MsgBox "Скрипт завершен. ", vbInformation, "Финиш"
WScript.Quit


End If

Private Function GetDateName(Dt)
  Dim y, m, d, h, n, s
  

  
      DateNow = Dt
    ' год
    y = DatePart("yyyy", DateNow) 
    ' месяц
    m = DatePart("m", DateNow) 
    ' день
    d = DatePart("d", DateNow) 
    'чаc
    h = DatePart("h", DateNow) 
    'минута
    n = DatePart("n", DateNow) 
    'секунда
    s = DatePart("s", DateNow) 
    
    If Len(m) = 1 Then
        m = "0" &m
    End If
    
    If Len(d) = 1 Then
        d = "0" &d
    End If
    
    If Len(h) = 1 Then
        h = "0" &h
    End If
    
    If Len(n) = 1 Then
        n = "0" &n
    End If
    
    If Len(s) = 1 Then
        s = "0" &s
    End If
        
    NameDDMMYYYY = d &"_" &m &"_" &y
    NameHHNNSS = h &"_" &n &"_" &s

    
    

  GetDateName = y & "-" & m & "-" & d
End Function
]]> https://forum.script-coding.com/profile.php?id=30994 2015-06-27T20:26:36Z https://forum.script-coding.com/viewtopic.php?pid=94779#p94779 <![CDATA[Re: VBS: Перенос фото в папку с датой съемки]]> 
Path = "C:\Fotos"
Name = "File.jpg"
Set Folder = CreateObject("Shell.Application").NameSpace(Path)
MsgBox Folder.GetDetailsOf(Folder.ParseName(Name), 12)
]]> https://forum.script-coding.com/profile.php?id=27593 2015-06-27T18:58:31Z https://forum.script-coding.com/viewtopic.php?pid=94778#p94778 <![CDATA[VBS: Перенос фото в папку с датой съемки]]> Доброго времени суток

Написал код для сортировки фото по дате съемки, но есть проблема не могу считать из фото дату съемки могу считать только дату изменения. Может кто сможет подсказать как считать "Дату съемок" фото

Dim FSO, FldN, Fls, Fl, D, DtN, FlN
Set FSO = WScript.CreateObject("Scripting.FileSystemObject")

'If WScript.Arguments.Count = 0 Then
'  MsgBox "Не задано имя папки для распределения файлов по датам. ", vbExclamation, "Ошибка"
'  WScript.Quit
'End If

Do
    Set objFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Выберите каталог размещения файлов:", 0) 
    'Если пользователь не выбрал папку, завершаем приложение &H0001 + &H4000
    If objFolder Is Nothing Then Exit Do
    'Получаем путь к выбранной папке
    objPath = objFolder.Self.Path

    FoundColon = InStr(1,objPath,":",vbTextCompare)
    'msgBox FoundColon
    If FoundColon = 1 Then
        MsgBox "Вы выбрали некорректную папку размещения файлов попробуйте еще раз!"
    End if

Loop while(FoundColon = 1)

If objFolder Is Nothing Then
    MsgBox "Не выбран каталог размещения файлов"
    'DynamicContent_Div.InnerHTML = "Не выбран каталог размещения файлов"
    
Else

FldN = objPath

'FldN = WScript.Arguments(0)


If Not FSO.FolderExists(FldN) Then
  MsgBox "Папка """ & FldN & """ не существует. ", vbExclamation, "Ошибка"
  WScript.Quit
End If

Set Fls = FSO.GetFolder(FldN).Files
For Each Fl In Fls
  D = GetDateName(Fl.DateLastModified)
  
'  MsgBox "File is " &Fl.Name &" " &D &" = " &Fl.DateLastModified
  Dim tt
  tt = "File is " &Fl.Name &" " &D &" = " &Fl.DateLastModified
    ExitFromName = MsgBox (tt, 36, "Прекратить создание папки?") 
    'MsgBox ExitFromName
    If ExitFromName = 6 Then 
        Exit For
    End If  
  
  
  DtN = FSO.BuildPath(FldN, D)
  If Not FSO.FolderExists(DtN) Then FSO.CreateFolder DtN

  FlN = FSO.BuildPath(DtN, Fl.Name)
  If FSO.FileExists(FlN) Then
    If MsgBox("Файл """ & Fl.Name & """ уже существует в папке """ & D & """. " & vbCr & "Перезаписать?", vbQuestion + vbOKCancel, "Внимание") = vbOK Then
      FSO.DeleteFile FlN, True
      Fl.Move FlN
    End If
  Else
    Fl.Move FlN
  End If
Next

MsgBox "Скрипт завершен. ", vbInformation, "Финиш"
WScript.Quit


End If
        
        


Private Function GetDateName(Dt)
  Dim M, D

  M = Month(Dt)
  D = Day(Dt)
  If M < 10 Then M = "0" & M
  If D < 10 Then D = "0" & D

  GetDateName = Year(Dt) & "-" & M & "-" & D
End Function
]]> https://forum.script-coding.com/profile.php?id=30994 2015-06-27T18:45:24Z https://forum.script-coding.com/viewtopic.php?pid=94777#p94777