Re: Print Selection

Написал vavalexus в 23/06/2010 11:06:38

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

Запускаем, получаем ошибку в строке
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