Re: Print Selection

Написал vavalexus в 22/06/2010 11:30:54

Уважаемый, Maputo
К сожалению, в VBA я только на уровне "метода тыка". Если Вас не затруднит, напишите, пожалуйста.
Пока добавил
Dim DefPage As Page, p2 As Page, p1 As Page, m1 As Page
Set m1 = doc.Pages(0)
For j = 1 To m1.Layers.Count
If m1.Layers(j).Printable = True Then
m1.Layers(j).Shapes.All.Copy
p2.Layers(j).Paste
End If
Next j
Но что-то видно не то.
Заранее спасибо!


Да m1 это моя самодеятельность была.
По поводу другого документа я был бы не против, но сам не осилю :(

Вот весь код:

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

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



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