请教：VBA代码获取图框对角点，打印时发生了偏移？
本帖最后由 kuangben8 于 2021-8-28 12:53 编辑我用代码获取图框的对角点，还画了一条直线看看对不对，直线位置是对的。但是以这两个对角点来确定打印范围并打印的时候，发现实际的打印范围偏移了，如下图：
但是在有的文件里打印却是正常的！
请教各位老师：这是什么原因导致的？代码如下：
Option Explicit
Sub 点选获取打印图框() '通过鼠标选择图框，获取图框的对角点存于数组中，然后批量打印。
Dim EntObj As AcadEntity, PickPot As Variant
Dim MinPt As Variant, MaxPt As Variant
Dim arr(), m%, Temp$, NameStr$
NameStr = InputBox("请输入要打印的图框名称，多个名称请用逗号“，”隔开。", "友情提醒:", "横向图框，纵向图框，砖型图，砖型图框")
Do
X:
On Error Resume Next '鼠标单击空白处，下面选择实体的语句会出错中断。
Set EntObj = Nothing '清除EntObj前一次的值
Temp = "" '清除Temp前一次的值
With ThisDrawing
.Utility.GetEntity EntObj, PickPot, "请选择图框:"
Temp = EntObj.ObjectName
If Len(Temp) = 0 Then
If MsgBox("您未选择任何实体对象，是否退出选择？", vbYesNo + vbInformation, "友情提醒:") = vbYes Then
Err.Clear '清除错误
Exit Do
Else
GoTo X
End If
ElseIf Temp <> "AcDbBlockReference" Then
MsgBox "您选择的实体对象不是块参照对象，请选择图框块参照对象。" _
& vbCrLf & "若要退出选择，请单击空白处。"
GoTo X
Else
If InStr(NameStr, EntObj.EffectiveName) > 0 Then
m = m + 1
ReDim Preserve arr(1 To 2, 1 To m)
EntObj.GetBoundingBox MinPt, MaxPt
arr(1, m) = MinPt
arr(2, m) = MaxPt
End If
End If
End With
Loop
批量打印 (arr)
End Sub
Public Function 批量打印(arr)
Dim Layout As ACADLayout
Dim Plot As AcadPlot
Dim Pt1(1) As Double, Pt2(1) As Double '定义两个窗选的二维对角点
Dim m%, Temp
Dim LowLeft As Variant, UppRight As Variant
With ThisDrawing
.ActiveLayout = .Layouts.Item("Model") '确保当前布局是模型空间布局
Set Layout = .ModelSpace.Layout '只打印当前模型空间布局
With Layout
.RefreshPlotDeviceInfo '先刷新当前系统设置
.ConfigName = "FinePrint" '设置打印设备
.CanonicalMediaName = "A4" '设置打印图纸为A4纸
.CenterPlot = True '设置居中打印,在非模型空间布局中该设置无效而出错！
.StyleSheet = "acad.ctb" '指定为无时直接结束了！！
.PlotWithLineweights = True '打印线宽
.PlotWithPlotStyles = False '不勾选按样式打印
.PlotViewportsFirst = False '先打印图纸空间对象
.PlotHidden = False '不隐藏图纸空间对象
.ScaleLineweights = False '不缩放线宽
.PaperUnits = acMillimeters '按照毫米为单位
.UseStandardScale = True '使用标准比例
.StandardScale = acScaleToFit'勾选布满图纸
.PlotType = acWindow '设置打印范围为窗口选择范围,在非模型布局中只能=acLayout
.PlotViewportBorders = False '不打印视口线
' Temp = .PlotOrigin '获取打印偏移的X、Y值，相对于所选图纸的左下角点，正值右移上移，负值左移下移。
' ReDim brr(0 To 1) As Double
' brr(0) = 3.5: brr(1) = 3.5
.PaperUnits = acMillimeters'设定单位为毫米，该参数值还有：英寸、像素。
' .PlotOrigin = brr
.GetPaperMargins LowLeft, UppRight '获取页边距值
End With
.SetVariable "BACKGROUNDPLOT", 0 '设置系统变量，保证不进行后台打印
With .Plot
.NumberOfCopies = 1 '只打印1份
'.DisplayPlotPreview acFullPreview '先预览后打印
End With
Dim L As AcadLine
For m = LBound(arr, 2) To UBound(arr, 2) '对arr数组循环并打印
Set L = .ModelSpace.AddLine(arr(1, m), arr(2, m)) '画一条直线看看点对不对？运行到此句回去了！
Pt1(0) = arr(1, m)(0): Pt1(1) = arr(1, m)(1)
Pt2(0) = arr(2, m)(0): Pt2(1) = arr(2, m)(1) '将三维点转换为二维点
If Pt2(0) - Pt1(0) > Pt2(1) - Pt1(1) Then '通过判断图框的长宽比来确定是横向打印还是纵向打印
Layout.PlotRotation = ac90degrees '设置为横向不颠倒
Else
Layout.PlotRotation = ac0degrees '设置为纵向不颠倒
End If
Layout.SetWindowToPlot Pt1, Pt2 '给定窗口的两个二维数组点参数
L.Visible = False
.Plot.PlotToDevice 'Layout已经设置打印设备，此处不再设置,若重新设置新打印机会取代原先的打印机。
L.Visible = True
Next
End With
End Function
页:
[1]