请教：VBA代码获取图框对角点，打印时发生了偏移？

kuangben8

我用代码获取图框的对角点，还画了一条直线看看对不对，直线位置是对的。但是以这两个对角点来确定打印范围并打印的时候，发现实际的打印范围偏移了，如下图：



但是在有的文件里打印却是正常的！



请教各位老师：这是什么原因导致的？代码如下：

2. Option Explicit
   
3. 
   
4. Sub 点选获取打印图框()     '通过鼠标选择图框，获取图框的对角点存于数组中，然后批量打印。
   
5.     Dim EntObj As AcadEntity, PickPot As Variant
   
6.     Dim MinPt As Variant, MaxPt As Variant
   
7.     Dim arr(), m%, Temp$, NameStr$
   
8.     NameStr = InputBox("请输入要打印的图框名称，多个名称请用逗号“，”隔开。", "友情提醒:", "横向图框，纵向图框，砖型图，砖型图框")
   
9.     Do
   
10. X:
    
11.         On Error Resume Next    '鼠标单击空白处，下面选择实体的语句会出错中断。
    
12.         Set EntObj = Nothing    '清除EntObj前一次的值
    
13.         Temp = ""               '清除Temp前一次的值
    
14.         With ThisDrawing
    
15.             .Utility.GetEntity EntObj, PickPot, "请选择图框:"
    
16.             Temp = EntObj.ObjectName
    
17.             If Len(Temp) = 0 Then
    
18.                 If MsgBox("您未选择任何实体对象，是否退出选择？", vbYesNo + vbInformation, "友情提醒:") = vbYes Then
    
19.                     Err.Clear     '清除错误
    
20.                     Exit Do
    
21.                 Else
    
22.                     GoTo X
    
23.                 End If
    
24.             ElseIf Temp <> "AcDbBlockReference" Then
    
25.                 MsgBox "您选择的实体对象不是块参照对象，请选择图框块参照对象。" _
    
26.                     & vbCrLf & "若要退出选择，请单击空白处。"
    
27.                 GoTo X
    
28.             Else
    
29.                 If InStr(NameStr, EntObj.EffectiveName) > 0 Then
    
30.                     m = m + 1
    
31.                     ReDim Preserve arr(1 To 2, 1 To m)
    
32.                     EntObj.GetBoundingBox MinPt, MaxPt
    
33.                     arr(1, m) = MinPt
    
34.                     arr(2, m) = MaxPt
    
35.                 End If
    
36.             End If
    
37.         End With
    
38.     Loop
    
39.     批量打印 (arr)
    
40. End Sub
    
41. 
    
42. Public Function 批量打印(arr)
    
43.     Dim Layout As ACADLayout
    
44.     Dim Plot As AcadPlot
    
45.     Dim Pt1(1) As Double, Pt2(1) As Double   '定义两个窗选的二维对角点
    
46.     Dim m%, Temp
    
47.     Dim LowLeft As Variant, UppRight As Variant
    
48.     With ThisDrawing
    
49.         .ActiveLayout = .Layouts.Item("Model")   '确保当前布局是模型空间布局
    
50.         Set Layout = .ModelSpace.Layout    '只打印当前模型空间布局
    
51.         With Layout
    
52.             .RefreshPlotDeviceInfo         '先刷新当前系统设置
    
53.             .ConfigName = "FinePrint"      '设置打印设备
    
54.             .CanonicalMediaName = "A4"     '设置打印图纸为A4纸
    
55.             .CenterPlot = True             '设置居中打印,在非模型空间布局中该设置无效而出错！
    
56.             .StyleSheet = "acad.ctb"       '指定为无时直接结束了！！
    
57.             .PlotWithLineweights = True    '打印线宽
    
58.             .PlotWithPlotStyles = False    '不勾选按样式打印
    
59.             .PlotViewportsFirst = False    '先打印图纸空间对象
    
60.             .PlotHidden = False            '不隐藏图纸空间对象
    
61.             .ScaleLineweights = False      '不缩放线宽
    
62.             .PaperUnits = acMillimeters    '按照毫米为单位
    
63.             .UseStandardScale = True       '使用标准比例
    
64.             .StandardScale = acScaleToFit  '勾选布满图纸
    
65.             .PlotType = acWindow           '设置打印范围为窗口选择范围,在非模型布局中只能=acLayout
    
66.             .PlotViewportBorders = False   '不打印视口线
    
67.             
    
68.             '            Temp = .PlotOrigin              '获取打印偏移的X、Y值，相对于所选图纸的左下角点，正值右移上移，负值左移下移。
    
69.             '            ReDim brr(0 To 1) As Double
    
70.             '            brr(0) = 3.5: brr(1) = 3.5
    
71.             .PaperUnits = acMillimeters  '设定单位为毫米，该参数值还有：英寸、像素。
    
72.             '            .PlotOrigin = brr
    
73.             .GetPaperMargins LowLeft, UppRight    '获取页边距值
    
74.         End With
    
75.         .SetVariable "BACKGROUNDPLOT", 0     '设置系统变量，保证不进行后台打印
    
76.         With .Plot
    
77.             .NumberOfCopies = 1                 '只打印1份
    
78.             '.DisplayPlotPreview acFullPreview   '先预览后打印
    
79.         End With
    
80.         Dim L As AcadLine
    
81.         For m = LBound(arr, 2) To UBound(arr, 2)                      '对arr数组循环并打印
    
82.             Set L = .ModelSpace.AddLine(arr(1, m), arr(2, m))         '画一条直线看看点对不对？运行到此句回去了！
    
83.             Pt1(0) = arr(1, m)(0): Pt1(1) = arr(1, m)(1)
    
84.             Pt2(0) = arr(2, m)(0): Pt2(1) = arr(2, m)(1)              '将三维点转换为二维点
    
85.             If Pt2(0) - Pt1(0) > Pt2(1) - Pt1(1) Then                 '通过判断图框的长宽比来确定是横向打印还是纵向打印
    
86.                 Layout.PlotRotation = ac90degrees                     '设置为横向不颠倒
    
87.             Else
    
88.                 Layout.PlotRotation = ac0degrees                      '设置为纵向不颠倒
    
89.             End If
    
90.             Layout.SetWindowToPlot Pt1, Pt2                           '给定窗口的两个二维数组点参数
    
91.             L.Visible = False
    
92.             .Plot.PlotToDevice                'Layout已经设置打印设备，此处不再设置,若重新设置新打印机会取代原先的打印机。
    
93.             L.Visible = True
    
94.         Next
    
95.     End With
    
96. End Function
    
97. 
    

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