Форум программистов
 
Контакты: о проблемах с регистрацией, почтой и по другим вопросам пишите сюда - alarforum@yandex.ru, проверяйте папку спам! Обязательно пройдите активизацию e-mail.

Вернуться   Форум программистов > Microsoft Office и VBA > Microsoft Office Excel
Регистрация

Восстановить пароль
Повторная активизация e-mail


Донат для форума - использовать для поднятия настроения себе и модераторам

А ещё здесь можно купить рекламу за 25 тыс руб в месяц! ) пишите сюда - alarforum@yandex.ru

Ответ
 
Опции темы
Старый 11.02.2010, 13:07   #1
choky
 
Регистрация: 29.12.2009
Сообщений: 6
Репутация: 10
По умолчанию Использование информации атрибута файла для таблицы Excel

Доброго всем дня, помогите, пожалуйста реализовать следующий макрос:
Необходимо чтобы макрос пробежался по папке, нашёл в ней все эксель файлы и записал даты создания этих файлов в таблицу рабочего листа, если дата создания изменилась подкрасить это, если дата создания сегодняшняя, то подкрасить в другой цвет.
Собственно вопрос - как макросом реализовать считывание значения даты создания файла?
Заранее благодарю.
choky вне форума   Ответить с цитированием
Старый 11.02.2010, 13:13   #2
EducatedFool
Программист VBA
СуперМодератор
 
Аватар для EducatedFool
 
Регистрация: 13.07.2008
Адрес: Россия, Урал
Сообщений: 6,840
Репутация: 1286

skype: ExcelVBA.ru
По умолчанию

Задал Гуглу вопрос: "excel получить дату создания файла"

В первом же результате поиска - 3 варианта макроса: http://forum.sysman.ru/index.php?showtopic=20151


Пример нужного Вам макроса есть в этой теме: http://www.programmersforum.ru/showthread.php?t=30219
Надо лишь добавить условие, чтобы в таблицу попадали только файлы с расширением XLS
EducatedFool вне форума   Ответить с цитированием
Старый 11.02.2010, 13:17   #3
choky
 
Регистрация: 29.12.2009
Сообщений: 6
Репутация: 10
По умолчанию

большое спасибо...видно плохо искал, прошу прощения
choky вне форума   Ответить с цитированием
Старый 11.02.2010, 15:15   #4
choky
 
Регистрация: 29.12.2009
Сообщений: 6
Репутация: 10
По умолчанию

еще раз здравствуйте.
а не подскажете как все-таки реализовать фильтрацию файлов по расширению (возможно ли это сделать на стадии получения информации об атрибутах файлов с помощью FSO, или это можно сделать только с готовым результатом, который уже попал в таблицу).
на примере вашего кода:
Код:
Sub CreateDirectoryListing()
    On Error Resume Next
    'Dim fso As FileSystemObject, f As Folder, fl As File, fld As Folder

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set f = fso.GetFolder("c:\mydocs")

    Application.ScreenUpdating = False
    Dim sh As Worksheet: Set sh = ActiveWorkbook.Worksheets.Add
    ro = 2
    With sh
        .Cells(1, 1).Resize(1, 4).Interior.Color = vbGreen:
        .Cells(1, 1) = "название папки": .Cells(1, 2) = "тип":
        .Cells(1, 3) = "дата создания": .Cells(1, 4) = "размер папки":
        For Each fld In f.Subfolders
            .Cells(ro, 1) = fld.Name
            .Cells(ro, 2) = fld.Type
            .Cells(ro, 3) = fld.DateCreated
            .Cells(ro, 4) = FileOrFolderSize(fld.Size)
            ro = ro + 1: DoEvents
        Next
        ro = ro + 1
        .Cells(ro, 1) = "Название файла": .Cells(ro, 2) = "Тип файла":
        .Cells(ro, 3) = "Дата создания": .Cells(ro, 4) = "Размер файла"
        .Cells(ro, 1).Resize(1, 4).Interior.Color = vbMagenta: ro = ro + 1
        For Each fl In f.Files
            .Cells(ro, 1) = fl.Name
            .Cells(ro, 2) = fl.Type
            .Cells(ro, 3) = fl.DateCreated
            .Cells(ro, 4) = FileOrFolderSize(fl.Size)
            ro = ro + 1: DoEvents
        Next
        .Columns("a:e").AutoFit
        .UsedRange.HorizontalAlignment = xlCenter
        SetRangeBordersEx .UsedRange, xlContinuous, xlThin
    End With
    Application.ScreenUpdating = True
End Sub

Последний раз редактировалось choky; 11.02.2010 в 15:17.
choky вне форума   Ответить с цитированием
Старый 11.02.2010, 15:56   #5
EducatedFool
Программист VBA
СуперМодератор
 
Аватар для EducatedFool
 
Регистрация: 13.07.2008
Адрес: Россия, Урал
Сообщений: 6,840
Репутация: 1286

skype: ExcelVBA.ru
По умолчанию

Попробуйте такой вариант:

Код:
Sub CreateDirectoryListing()
    On Error Resume Next

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set f = fso.GetFolder("D:\Документы")

    Application.ScreenUpdating = False
    Dim sh As Worksheet: Set sh = ActiveWorkbook.Worksheets.Add
    ro = 1
    With sh
        .Cells(ro, 1) = "Название файла": .Cells(ro, 2) = "Тип файла":
        .Cells(ro, 3) = "Дата создания": .Cells(ro, 4) = "Размер файла"
        .Cells(ro, 1).Resize(1, 4).Interior.Color = vbMagenta: ro = ro + 1

        For Each fl In f.Files
            If fl.Name Like "*.xls" Then
                .Cells(ro, 1) = fl.Name
                .Cells(ro, 2) = fl.Type
                .Cells(ro, 3) = fl.DateCreated
                .Cells(ro, 4) = FileOrFolderSize(fl.Size)
                ro = ro + 1: DoEvents
            End If
        Next
        .Columns("a:e").AutoFit
        .UsedRange.HorizontalAlignment = xlCenter
        SetRangeBordersEx .UsedRange, xlContinuous, xlThin
    End With
    Application.ScreenUpdating = True
End Sub


Function FileOrFolderSize(ByVal s) As String
    Size = Fix(Val(s)):    ' If s = "" Then FileOrFolderSize = "<нет доступа>"
    Select Case Size
        Case Is < 1000: FileOrFolderSize = Size & " байт"
        Case Is < 10000: FileOrFolderSize = FormatNumber(Size / 1024, 1) & " Кб"
        Case Is < 1000000: FileOrFolderSize = FormatNumber(Size \ 1024, 0) & " Кб"
        Case Is < 10000000: FileOrFolderSize = FormatNumber(Size / 1024 / 1024, 1) & " Mб"
        Case Is < 1000000000: FileOrFolderSize = FormatNumber(Size / 1024 / 1024, 0) & " Мб"
        Case Else: FileOrFolderSize = FormatNumber(Size / 1024 / 1024 / 1024, 1) & " Гб"
    End Select
End Function

Sub SetRangeBordersEx(ByRef ra As Range, ByVal BordersLineStyle As XlLineStyle, ByVal BordersWeight As XlBorderWeight)
    ra.Borders.LineStyle = BordersLineStyle
    ra.Borders.Weight = BordersWeight
    ra.Borders(xlDiagonalDown).LineStyle = xlNone
    ra.Borders(xlDiagonalUp).LineStyle = xlNone
End Sub
EducatedFool вне форума   Ответить с цитированием
Старый 11.02.2010, 17:17   #6
choky
 
Регистрация: 29.12.2009
Сообщений: 6
Репутация: 10
По умолчанию

Всё здорово и изящно работает - спасибо большое
choky вне форума   Ответить с цитированием
Ответ

Опции темы

Ваши права в разделе
Вы не можете создавать новые темы
Вы не можете отвечать в темах
Вы не можете прикреплять вложения
Вы не можете редактировать свои сообщения

BB коды Вкл.
Смайлы Вкл.
[IMG] код Вкл.
HTML код Выкл.

Быстрый переход

Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Использование процедур(функций) при обработке экономической информации (delphi) Shadow_rus Помощь студентам 2 12.12.2009 19:11
вывод информации из файла pautina Общие вопросы Delphi 12 26.01.2009 09:54
Присваивание атрибута папке. papa_serg Общие вопросы Delphi 2 05.01.2009 17:45
Вывод информации в Memo из файла. Фибер Оптик Общие вопросы Delphi 11 04.05.2007 00:13


06:16.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2019, Jelsoft Enterprises Ltd.