1

Тема: (Решено) Открытие по очереди несколиких файлов rtf

Необходимо в определенном каталоге найти все сегодняшние файлы с расширением rtf. Имена файлов - цифры от 1.rtf до 99.rtf. Текст на полстраницы, необходимо скопировать второй раз, установить поля по 1 см, распечатать и удалить файл

2

Re: (Решено) Открытие по очереди несколиких файлов rtf

Так по какому критерию искать? По дате или по имени?

Лучше день потерять — потом за пять минут долететь!

3

Re: (Решено) Открытие по очереди несколиких файлов rtf

Нужны все файлы rtf, созданные сегодня и имена которых - цифры.

4

Re: (Решено) Открытие по очереди несколиких файлов rtf

Необходимо 2 критерия. Если такой возможности нет, то лучше по имени

5

Re: (Решено) Открытие по очереди несколиких файлов rtf

Ну, два, так два

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

Файлы не обязательно будут печататься по порядку номеров. Печать будет производиться на принтер по умолчанию или на последний использовавшийся принтер.

Лучше день потерять — потом за пять минут долететь!

6

Re: (Решено) Открытие по очереди несколиких файлов rtf

Две просьбы
1). Указать конкретную папку для файлов (например, D:\Print\.

2). Как сделать параметры страницы (поля слева 1,5, остальные - по 1 см)?

И у меня не печатается - Постановка в очередь. Только при выходе из Word происходит печать

Отредактировано alex (20.04.2010 16:01:59)

7

Re: (Решено) Открытие по очереди несколиких файлов rtf

Совсем забыл про поля roll

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
Лучше день потерять — потом за пять минут долететь!

8

Re: (Решено) Открытие по очереди несколиких файлов rtf

'Ожидаем завершения печати
              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)

9

Re: (Решено) Открытие по очереди несколиких файлов rtf

Странно, у меня тоже сетевой принтер, и всё печатается. Для установки параметров страницы, совсем не обязательно переписывать всё, что записал макрорекордер, тем более, что практически все параметры стоят по умолчанию.
Перед печатью документа вставить:

              'Границы страницы
              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

А может у Вас наоборот, установлена печать не в фоне?

Лучше день потерять — потом за пять минут долететь!

10

Re: (Решено) Открытие по очереди несколиких файлов rtf

'Междустрочный интервал
              .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, пишет нет такого параметра

Без него печать происходит только при закрытии Ворда. И файлы не удаляются. В остальном все просто замечательно.
А как узнать в фоне происходит печать или нет?

11

Re: (Решено) Открытие по очереди несколиких файлов rtf

alex пишет:

Не работает с Options.PringBackground, пишет нет такого параметра

Опечатка. Должно быть Options.PrintBackground. В предыдущем коде исправил.

alex пишет:

А как узнать в фоне происходит печать или нет?

Если Вы можете работать с документом во время его печати, то печать выполняется в фоне.

Лучше день потерять — потом за пять минут долететь!

12

Re: (Решено) Открытие по очереди несколиких файлов rtf

Спасибо, все работает!!  smile

13

Re: (Решено) Открытие по очереди несколиких файлов rtf

Т.е. помогла отмена печати в фоне?

Лучше день потерять — потом за пять минут долететь!

14

Re: (Решено) Открытие по очереди несколиких файлов rtf

Получается, что так.

15

Re: (Решено) Открытие по очереди несколиких файлов rtf

Вот и хорошо. Буду знать.

Лучше день потерять — потом за пять минут долететь!