Вы не вошли. Пожалуйста, войдите или зарегистрируйтесь.
Страницы 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
Чтобы отправить ответ, вы должны войти или зарегистрироваться