Народ, привет!

В просторах инета нашел макрос, позволяющий указать рамкой что будем печатать - очень удобно. В макросе есть анализ слоев на printable - так вот, почему то этот анализ работает только для основной страницы, а для страницы шаблона, все слоя, даже если они не printable, все равно печатаются.
Если все слои с мастер-страницы перенести в основную страницу, то видимость обрабатывается корректно. Как побороть, чтобы не переносить?
Заранее большое спасибо!

Ниже код.

Sub PrintView()
'
'
Dim x1 As Double, x2 As Double, y1 As Double, y2 As Double
Dim dx As Double, dy As Double
Dim doc As Document
Dim Shift As Long
Dim b As Boolean
Dim l1 As Layer
Dim s1 As Shape, s2 As Shape
Dim DesPrnSettings As PrintSettings
Dim DefPage As Page, p2 As Page, p1 As Page
Dim DefView As View


Set doc = ActiveDocument
Set p1 = doc.ActivePage
'Set M1 = doc.MasterPage

doc.BeginCommandGroup "Print View"

'Select highest layer
Set l1 = p1.CreateLayer("***Print_View_TEMP***"
l1.MoveAbove p1.Layers(1)
p1.Layers(1).Activate

' Esc to cancel...
b = False
While Not b
' Rectangular frame...
b = doc.GetUserArea(x1, y1, x2, y2, Shift, 10, False, cdrCursorWinCross)
If Not b Then
Set s1 = ActiveLayer.CreateRectangle(x1, y1, x2, y2)

'no outline
s1.Outline.Type = cdrNoOutline
s1.Name = "DruckLinse"

'Application.Optimization = True

Set p2 = doc.InsertPagesEx(1, False, ActivePage.Index, 8.267717, 11.692913)



For i = 1 To p1.Layers.Count
If p1.Layers(i).Printable = True Then
p1.Layers(i).Shapes.All.Copy
p2.Layers(i).Paste
End If
Next i


s1.Delete
ActiveLayer.Master = False
p2.Layers(1).Activate
Set s1 = p2.FindShape("DruckLinse"
With s1.CreateLens(cdrLensMagnify, 1#).Lens
.RemoveFace = False
.Freeze
End With

' selected top level group object that contains the lens
Set s2 = s1.ParentGroup
' cut object from page
s2.Cut

' store page and view for returning to original view afterwards
Set DefPage = doc.ActivePage
Set DefView = doc.Views.AddActiveView("VB_PrintView"
' add new page at the end of document
doc.InsertPages 1, False, ActiveDocument.Pages.Count
'insert cut object (lens) to new page
ActivePage.ActiveLayer.Paste

'center object(s) on page
x1 = ActivePage.CenterX
y1 = ActivePage.CenterY
doc.ReferencePoint = cdrCenter
dx = x1 - ActiveSelection.PositionX
dy = y1 - ActiveSelection.PositionY

ActiveSelection.Move dx, dy

' Resize page to fit selected view box
ActivePage.SetSize ActiveSelection.SizeWidth, ActiveSelection.SizeHeight

' Print out the selected page on default printer
Set DesPrnSettings = doc.PrintSettings
With DesPrnSettings
.PrintRange = prnCurrentPage
End With

'MsgBox DesPrnSettings.Printer.Type

'Print file
runPrint = doc.PrintSettings.ShowDialog

If runPrint = True Then
doc.PrintOut
End If
'Debug: MsgBox "Druck wьrde jetzt erfolgen", vbInformation, "Ansicht drucken"
' Delete Page
ActivePage.Delete
DefPage.Activate
DefView.Activate
doc.Views.Item("VB_PrintView".Delete
p2.Delete
l1.Delete
p1.Activate

Application.Optimization = False
Application.Refresh
doc.EndCommandGroup
End
End If

Wend
End Sub

Не получается.

Запускаем, получаем ошибку в строке
MPlayers(j) = False: Subscript out of range
Убираем эту строку, получаем ошибку в строке
MPlayers(j) = True: Subscript out of range
Убираем эту строку, получаем ошибку в строке
p2.Layers(j).Paste: method 'Paste' of object 'iDrawLayer' faild.

Убираем весь цикл - работает как раньше, анализируя принтабл на странице, но вставляя все с мастер-страницы, в независимости от значения принтабл.


Вот код:
Sub PrintView()
'
'
Dim x1 As Double, x2 As Double, y1 As Double, y2 As Double
Dim dx As Double, dy As Double
Dim doc As Document
Dim Shift As Long
Dim b As Boolean
Dim l1 As Layer
Dim s1 As Shape, s2 As Shape
Dim DesPrnSettings As PrintSettings
Dim DefPage As Page, p2 As Page, p1 As Page, m1 As Page
Dim MPlayers() As Boolean
Dim DefView As View


Set doc = ActiveDocument
Set p1 = doc.ActivePage
Set m1 = doc.Pages(0)


doc.BeginCommandGroup "Print View"

'Select highest layer
Set l1 = p1.CreateLayer("***Print_View_TEMP***")
l1.MoveAbove p1.Layers(1)
p1.Layers(1).Activate

' Esc to cancel...
b = False
While Not b
' Rectangular frame...
b = doc.GetUserArea(x1, y1, x2, y2, Shift, 10, False, cdrCursorWinCross)
If Not b Then
Set s1 = ActiveLayer.CreateRectangle(x1, y1, x2, y2)
'Set s1 = ActiveLayer.CreateRectangle(-2.188031, 7.822047, 4.103465, 3.962047)

'no outline
s1.Outline.Type = cdrNoOutline
s1.Name = "DruckLinse"

'Application.Optimization = True

Set p2 = doc.InsertPagesEx(1, False, ActivePage.Index, 8.267717, 11.692913)


For i = 1 To p1.Layers.Count
If p1.Layers(i).Printable = True Then
p1.Layers(i).Shapes.All.Copy
p2.Layers(i).Paste
End If
Next i

For j = 1 To m1.Layers.Count
If m1.Layers(j).Printable = True Then
m1.Layers(j).Shapes.All.Copy
p2.Layers(j).Paste
m1.Layers(j).Printable = False
MPlayers(j) = True
Else
MPlayers(j) = False
End If

Next j


s1.Delete
ActiveLayer.Master = False
p2.Layers(1).Activate
Set s1 = p2.FindShape("DruckLinse")
With s1.CreateLens(cdrLensMagnify, 1#).Lens
.RemoveFace = False
.Freeze
End With

' selected top level group object that contains the lens
Set s2 = s1.ParentGroup
' cut object from page
s2.Cut

' store page and view for returning to original view afterwards
Set DefPage = doc.ActivePage
Set DefView = doc.Views.AddActiveView("VB_PrintView")
' add new page at the end of document
doc.InsertPages 1, False, ActiveDocument.Pages.Count
'insert cut object (lens) to new page
ActivePage.ActiveLayer.Paste

'center object(s) on page
x1 = ActivePage.CenterX
y1 = ActivePage.CenterY
doc.ReferencePoint = cdrCenter
dx = x1 - ActiveSelection.PositionX
dy = y1 - ActiveSelection.PositionY

ActiveSelection.Move dx, dy

' Resize page to fit selected view box
ActivePage.SetSize ActiveSelection.SizeWidth, ActiveSelection.SizeHeight

' Print out the selected page on default printer
Set DesPrnSettings = doc.PrintSettings
With DesPrnSettings
.PrintRange = prnCurrentPage
End With

'MsgBox DesPrnSettings.Printer.Type

'Print file
runPrint = doc.PrintSettings.ShowDialog

If runPrint = True Then
doc.PrintOut
End If
'Debug: MsgBox "Druck wьrde jetzt erfolgen", vbInformation, "Ansicht drucken"
' Delete Page
ActivePage.Delete
DefPage.Activate
DefView.Activate
doc.Views.Item("VB_PrintView").Delete
p2.Delete
l1.Delete
p1.Activate

Application.Optimization = False
Application.Refresh
doc.EndCommandGroup
End
End If
For j = 1 To m1.Layers.Count
m1.Layers(j).Printable = MPlayers(j)
Next j
Wend
End Sub

Поробуй так:
Цитата:

p2.Layers(j).Paste - слой вне диапазона

Есть еще одна проблемка))) Номера слоев будут совпадать и все перемешается. Можно попробовать В цикле j = 1 to x в номера слоев добавлять последнее значение i.

m1.Layers(j).Shapes.All.Copy
p2.Layers(j+i).Paste
m1.Layers(j).Printable = False

то же самое, слой вне диапазона.

m1.Layers(j).Shapes.All.Copy
p2.Layers(p2.Layers.Count).Paste
m1.Layers(j).Printable = False

Так все вставляется в верхний слой. Иначе необходимо перед вставкой создавать дополнительные слои))) К сожалению не могу проверить - у меня функции Copy/Paste отвалились в кореле))) Но ошибки больше не выдает программа.

А у вас работает?
У меня пишет method 'Paste' of object 'iDrawLayer' faild.

есть .CopyToLayer спецом для копирования между слоями

m1.Layers(j).Shapes.All.CopyToLayer p2.Layers.Top
m1.Layers(j).Printable = False

Аналогично.
Проще вcего было бы снять галку MASTER с нужных слоев (их строго фиксированное кол-во), напечатать, потом поставить MASTER назад. Тогда не нужен был бы этот цикл.

Как я уже писал:
Если написать ActiveDocument.Pages(0).Layers("Test").Master = False - ПУСТОЙ слой убирается из шаблонов, а ActiveDocument.Pages(0).Layers("Test".Master = True - добавляется. Но стоит в этом слое что-то нарисовать, при выполнении команды ActiveDocument.Pages(0).Layers("Test").Master = False происходит подвисание корела. В 12 EN кореле отлично работает ActivePage.Layers("Test").Master = False/True.

vavalexus Нашел комп с рабочим корелом. Работает. Собирает страницу из исходной и МастерПейдж.

Тока вот так даже лучше:

m1.Layers(j).Shapes.All.Copy
p2.Layers(1).Paste
m1.Layers(j).Printable = False

Что печатает не могу проверить - принтера нет.