Вы не вошли. Пожалуйста, войдите или зарегистрируйтесь.
Страницы 1
Чтобы отправить ответ, вы должны войти или зарегистрироваться
Необходимо в определенном каталоге найти все сегодняшние файлы с расширением rtf. Имена файлов - цифры от 1.rtf до 99.rtf. Текст на полстраницы, необходимо скопировать второй раз, установить поля по 1 см, распечатать и удалить файл
Так по какому критерию искать? По дате или по имени?
Нужны все файлы rtf, созданные сегодня и имена которых - цифры.
Необходимо 2 критерия. Если такой возможности нет, то лучше по имени
Ну, два, так два
Sub OpenCopyPrintDelete()
Dim sFolderPath As String 'Путь к папке
Dim sFileName As String 'Имя файла
Dim FSO As Object, File As Object
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Выбор папки"
.ButtonName = "Выбрать"
If .Show Then sFolderPath = .SelectedItems(1) Else Exit Sub
End With
Application.ScreenUpdating = False
Set FSO = CreateObject("Scripting.FileSystemObject")
sFileName = Dir(sFolderPath & Application.PathSeparator & "*.rtf")
While Len(sFileName) > 0
Set File = FSO.GetFile(sFolderPath & Application.PathSeparator & sFileName)
If IsNumeric(Mid(sFileName, 1, InStrRev(sFileName, ".") - 1)) Then
If Day(File.DateLastModified) = Day(Date) And _
Month(File.DateLastModified) = Month(Date) _
And Year(File.DateLastModified) = Year(Date) Then
Select Case Val(Mid(sFileName, 1, InStrRev(sFileName, ".") - 1))
Case 1 To 99
With Documents.Open(sFolderPath & Application.PathSeparator & sFileName, False, False, True)
.Range.Select
Selection.Copy
Selection.Collapse wdCollapseEnd
Selection.Paste
.PrintOut
.Close True
Kill sFolderPath & Application.PathSeparator & sFileName
End With
Case Else
End Select
End If
End If
sFileName = Dir
DoEvents
Wend
Do While Application.BackgroundPrintingStatus > 0
DoEvents
Loop
Application.ScreenUpdating = True
MsgBox "Обработка закончена"
End SubФайлы не обязательно будут печататься по порядку номеров. Печать будет производиться на принтер по умолчанию или на последний использовавшийся принтер.
Две просьбы
1). Указать конкретную папку для файлов (например, D:\Print\.
2). Как сделать параметры страницы (поля слева 1,5, остальные - по 1 см)?
И у меня не печатается - Постановка в очередь. Только при выходе из Word происходит печать
Отредактировано alex (20.04.2010 16:01:59)
Совсем забыл про поля 
Sub OpenCopyPrintDelete()
Dim sFolderPath As String 'Путь к папке
Dim sFileName As String 'Имя файла
Dim FSO As Object, File As Object
' With Application.FileDialog(msoFileDialogFolderPicker)
' .Title = "Выбор папки"
' .ButtonName = "Выбрать"
' If .Show Then sFolderPath = .SelectedItems(1) Else Exit Sub
' End With
sFolderPath = "D:\Temp" 'Путь к папке
Application.ScreenUpdating = False
Set FSO = CreateObject("Scripting.FileSystemObject")
sFileName = Dir(sFolderPath & Application.PathSeparator & "*.rtf")
While Len(sFileName) > 0
Set File = FSO.GetFile(sFolderPath & Application.PathSeparator & sFileName)
If IsNumeric(Mid(sFileName, 1, InStrRev(sFileName, ".") - 1)) Then
If Day(File.DateLastModified) = Day(Date) And _
Month(File.DateLastModified) = Month(Date) _
And Year(File.DateLastModified) = Year(Date) Then
Select Case Val(Mid(sFileName, 1, InStrRev(sFileName, ".") - 1))
Case 1 To 99
With Documents.Open(sFolderPath & Application.PathSeparator & sFileName, False, False, True)
.Range.Select
Selection.Copy
Selection.Collapse wdCollapseEnd
Selection.Paste
'Границы страницы
With .PageSetup
.LeftMargin = CentimetersToPoints(1.5)
.RightMargin = CentimetersToPoints(1)
.TopMargin = CentimetersToPoints(1)
.BottomMargin = CentimetersToPoints(1)
End With
.PrintOut 'Печать документа
'Ожидаем завершения печати
Do While Application.BackgroundPrintingStatus > 0
DoEvents
Loop
'Закрытие документа
.Close True
'Удаление документа
Kill sFolderPath & Application.PathSeparator & sFileName
End With
Case Else
End Select
End If
End If
sFileName = Dir
DoEvents
Wend
Do While Application.BackgroundPrintingStatus > 0
DoEvents
Loop
Application.ScreenUpdating = True
MsgBox "Обработка закончена"
End Sub'Ожидаем завершения печати
Do While Application.BackgroundPrintingStatus > 0
DoEventsи ??? Наверно DoEvents?
Loop
Надо зайти в Word и выполнить данный макрос?
Печать происходит только при выходе из Ворда.
И еще небольшое пожелание - изменить параметры страницы на А4 и сделать во всем тексте междустрочный интервал точно 8 пт.
Что то похожее на
Sub OpenCopyPrintDelete()
Dim sFolderPath As String 'Путь к папке
Dim sFileName As String 'Имя файла
Dim FSO As Object, File As Object
' With Application.FileDialog(msoFileDialogFolderPicker)
' .Title = "Выбор папки"
' .ButtonName = "Выбрать"
' If .Show Then sFolderPath = .SelectedItems(1) Else Exit Sub
' End With
sFolderPath = "D:\Print" 'Путь к папке
Application.ScreenUpdating = False
Set FSO = CreateObject("Scripting.FileSystemObject")
sFileName = Dir(sFolderPath & Application.PathSeparator & "*.rtf")
While Len(sFileName) > 0
Set File = FSO.GetFile(sFolderPath & Application.PathSeparator & sFileName)
If IsNumeric(Mid(sFileName, 1, InStrRev(sFileName, ".") - 1)) Then
If Day(File.DateLastModified) = Day(Date) And _
Month(File.DateLastModified) = Month(Date) _
And Year(File.DateLastModified) = Year(Date) Then
Select Case Val(Mid(sFileName, 1, InStrRev(sFileName, ".") - 1))
Case 1 To 99
With Documents.Open(sFolderPath & Application.PathSeparator & sFileName, False, False, True)
.Range.Select
Selection.Copy
Selection.Collapse wdCollapseEnd
Selection.Paste
'Границы страницы
With .PageSetup
.LineNumbering.Active = False
.Orientation = wdOrientPortrait
.TopMargin = CentimetersToPoints(0.6)
.BottomMargin = CentimetersToPoints(0.6)
.LeftMargin = CentimetersToPoints(1)
.RightMargin = CentimetersToPoints(1)
.Gutter = CentimetersToPoints(0)
.HeaderDistance = CentimetersToPoints(1.27)
.FooterDistance = CentimetersToPoints(1.27)
.PageWidth = CentimetersToPoints(21)
.PageHeight = CentimetersToPoints(29.7)
.FirstPageTray = wdPrinterDefaultBin
.OtherPagesTray = wdPrinterDefaultBin
.SectionStart = wdSectionNewPage
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.VerticalAlignment = wdAlignVerticalTop
.SuppressEndnotes = True
.MirrorMargins = False
.TwoPagesOnOne = False
.BookFoldPrinting = False
.BookFoldRevPrinting = False
.BookFoldPrintingSheets = 1
.GutterPos = wdGutterPosLeft
End With
With Selection.ParagraphFormat
.SpaceBeforeAuto = False
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceExactly
.LineSpacing = 8
End With
.PrintOut Range:=wdPrintRangeOfPages, Item:= _
wdPrintDocumentContent, Copies:=1, Pages:="1", PageType:=wdPrintAllPages, _
ManualDuplexPrint:=False, Collate:=False, Background:=True, PrintToFile _
:=False, PrintZoomColumn:=0, PrintZoomRow:=0, PrintZoomPaperWidth:=0, _
PrintZoomPaperHeight:=0
'Закрытие документа
.Close True
'Удаление документа
Kill sFolderPath & Application.PathSeparator & sFileName
End With
Case Else
End Select
End If
End If
sFileName = Dir
DoEvents
Wend
Do While Application.BackgroundPrintingStatus > 0
DoEvents
Loop
Application.ScreenUpdating = True
MsgBox "Обработка закончена"
End SubОтредактировано alex (21.04.2010 08:51:21)
Странно, у меня тоже сетевой принтер, и всё печатается. Для установки параметров страницы, совсем не обязательно переписывать всё, что записал макрорекордер, тем более, что практически все параметры стоят по умолчанию.
Перед печатью документа вставить:
'Границы страницы
With .PageSetup
.LeftMargin = CentimetersToPoints(1.5)
.RightMargin = CentimetersToPoints(1)
.TopMargin = CentimetersToPoints(1)
.BottomMargin = CentimetersToPoints(1)
.PaperSize = wdPaperA4 'Формат страницы
End With
'Междустрочный интервал
.Paragraphs.LineSpacingRule = wdLineSpaceExactly
.Paragraphs.LineSpacing = 8А чтобы разобраться с печатью, давайте попробуем печатать не в фоне. Для этого перед печатью пишем:
Options.PrintBackground = FalseА перед сообщением о завершении работы, вернём значение назад:
Options.PrintBackground = TrueА может у Вас наоборот, установлена печать не в фоне?
'Междустрочный интервал
.Paragraphs.LineSpacingRule = wdLineSpaceExactly
.Paragraphs.LineSpacing = 8
Options.PringBackground = False
.PrintOut 'Печать документа
'Ожидаем завершения печати
Do While Application.BackgroundPrintingStatus > 0
DoEvents
Loop
'Закрытие документа
.Close True
'Удаление документа
Kill sFolderPath & Application.PathSeparator & sFileName
End With
Case Else
End Select
End If
End If
sFileName = Dir
DoEvents
Wend
Do While Application.BackgroundPrintingStatus > 0
DoEvents
Loop
Options.PringBackground = True
Application.ScreenUpdating = True
MsgBox "Обработка закончена"
End SubНе работает с Options.PringBackground, пишет нет такого параметра
Без него печать происходит только при закрытии Ворда. И файлы не удаляются. В остальном все просто замечательно.
А как узнать в фоне происходит печать или нет?
Не работает с Options.PringBackground, пишет нет такого параметра
Опечатка. Должно быть Options.PrintBackground. В предыдущем коде исправил.
А как узнать в фоне происходит печать или нет?
Если Вы можете работать с документом во время его печати, то печать выполняется в фоне.
Спасибо, все работает!! 
Т.е. помогла отмена печати в фоне?
Получается, что так.
Вот и хорошо. Буду знать.
Страницы 1
Чтобы отправить ответ, вы должны войти или зарегистрироваться
(Решено) Открытие по очереди несколиких файлов rtf
У многих людей работа на компьютере связана с написание текстов или вычиткой чужих. И как же жалко, порой бывает, когда человек пишет по сто раз в тексте на 10 000 страниц «В Урюпинском районе», не подозревая, что в умной программе Microsoft Word спряталась кнопка автозамены, или убивает вечер, стирая по одному лишние пробелы в чужом, небрежном дипломном проекте. На портале о Microsoft Office Word вы узнаете про: выставить поля в ворде. Да мало ли…
Умудренный вы пользователь или чайник, но всегда что-то новое интересно узнать, а может и поделиться своими наработками с народом. Наш сайт о Microsoft Office Word даст ответ про: 25-значный ключ продукта microsoft office 2007. На форуме сайта Ворд Эксперт вы сможете легко сделать как первое, так и второе.
Очень удобный форум, всего с несколькими главными, строго по теме разделами. Наш сайт о Microsoft Office Word даст ответ про: как посмотреть количество знаков в word 2007. Минимум флуда (для него специальный раздел, но даже там общение тематическое), ответы на вопросы, как новичков, так и опытных пользователей. На портале о Microsoft Office Word вы узнаете про: строка состояния excel. На форуме можно научиться делать макросы, подсмотреть чужое оригинальное решение или предложить свое. На портале о Microsoft Office Word вы узнаете про: полуторный интервал в ворде. Также можно сделать заказ, озвучив свое желание в подразделе «заявки на разработку».
Вы найдете тонкости настройки и использования разных версий Ворда. Наш сайт о Microsoft Office Word даст ответ про: что делать если ворд не открывает документ. Форумчане подскажут, как лучше отформатировать текст, какие функции Ворда в каких случая наиболее оптимально использовать и многое другое. Наш сайт о Microsoft Office Word даст ответ про: как восстановить удаливший ярлык. Несомненно, работа в редакторе текста станет легче и приятнее с форумом нашего портала.