求组关于在EXCEL的VBA环境调用CAD打印问题

楚河

说个小插曲，服了钱购买了邀请码，注册时发现邮箱已注册，才知道以前注册过。算给论坛做点微薄的贡献。

程序的意义是可以通过EXCEL打开多个CAD文件，并根据图纸中的图框来循环打印PDF。

网上的代码基本运行环境都是在CAD中采用lsp或者VBA实现，但是由于工作环境以及习惯，使用EXCEL的VBA更合适一些，但是代码缺不能实现，
在执行到最后，输出的只是图纸默认的窗口范围。
具体代码如下：

'简单说明一下打印函数
'cadDoc - 打开的cad文件
'kuainame - 打印图框名称
'PrinterName -打印机名称
'Styles -样式表名称
'MediaName -纸张大小
'AutoMedia -自动纸张开关
'AutoRotate -自动旋转, 纵向 / 横向

Function PlotFunction(cadDoc As Object, kuainame As String, PrinterName As String, Styles As String, MediaName As String, AutoMedia As Boolean, AutoRotate As Boolean)

On Error Resume Next

Dim MyAcadApp As Object
Set MyAcadApp = cadDoc.Application
    MyAcadApp.ZoomAll

'打印参数设置

Dim ptMin As Variant, ptMax As Variant

Set objDoc = MyAcadApp.ActiveDocument
  

Set objLayout = objDoc.Layouts.Item("模型") '中文版本，“模型”布局
'Set objLayout = objDoc.Layouts.Item("Model")

' 设置打印机
If Not Trim(PrinterName) = "" Then
objLayout.ConfigName = PrinterName
Else
Exit Function
End If
' 设置打印样式表
If Not Trim(Styles) = "" Then
objLayout.StyleSheet = Styles

Else
objLayout.StyleSheet = "acad.ctb"
End If
' 设置图纸尺寸
If AutoMedia Then
objLayout.CanonicalMediaName = "A4"
Else
If Not Trim(MediaName) = "" Then
objLayout.CanonicalMediaName = MediaName
Else
objLayout.CanonicalMediaName = "A4"
End If
End If
' 设置图纸单位
objLayout.PaperUnits = acMillimeters
' 设置默认图纸打印方向
'objLayout.PlotRotation = ac0degrees '纵向
objLayout.PlotRotation = ac90degrees '横向
' 设置图纸打印比例
objLayout.StandardScale = acScaleToFit
objLayout.UseStandardScale = True '使用标准打印比例
'objLayout.UseStandardScale = False '使用自定义打印比例
' 设置自定义打印比例
'objLayout.SetCustomScale txtNumerator.Value, txtDenominator.Value
' 设置图纸是否居中打印
objLayout.CenterPlot = True
' 打印时使用图形文件中的线宽
objLayout.PlotWithLineweights = True
' 设置是否应用打印样式
objLayout.PlotWithPlotStyles = True
' 打印时隐藏图纸空间对象
objLayout.PlotHidden = False
' 设置图纸打印份数
objDoc.Plot.NumberOfCopies = 1
' 将打印错误报告切换为静默错误模式，以便不间断地执行打印任务
objDoc.Plot.QuietErrorMode = True
' 设置前台打印，使打印任务按打印顺序依次发送到打印机
objDoc.SetVariable "BACKGROUNDPLOT", 0
' 重新生成当前图形
objDoc.Regen acAllViewports
' 根据图块的左下角及右上角坐标设置打印窗口
   '此部分省略了一段图纸内根据图框排序的代码
   Dim a As Integer
    a = 0
   For a = 1 To i ’i是选择集获取的图框数量
      
      blockarry(a).blockObj.GetBoundingBox ptMin, ptMax 'blockarry(a)为机构体，元素分别是图框块，以及图框块插入点信息
      Debug.Print blockarry(a).blockObj.Name  ’确认能获取各图框块名称，程序按意图执行
      
      ReDim Preserve ptMin(0 To 1) ' 将三维点转化为二维点坐标
      ReDim Preserve ptMax(0 To 1)
      
      Debug.Print ptMin(0) & "--" & ptMin(1) ’确认能获取各图框块的左下角及右上角坐标，程序按意图执行
      Debug.Print ptMax(0) & "--" & ptMax(1)
      
      
' 设置打印窗口

      objLayout.SetWindowToPlot ptMin, ptMax
     objLayout.GetWindowToPlot ptMin, ptMax
'      Debug.Print ptMin(0) & "--" & ptMin(1) ’确认窗口赋值成功，程序按意图执行
'      Debug.Print ptMax(0) & "--" & ptMax(1)
      
      objLayout.PlotType = acWindow
'      objLayout.PlotType = acExtents

      If Abs(ptMax(0) - ptMin(0)) < Abs(ptMax(1) - ptMin(1)) And AutoRotate Then
'      If AutoMedia Then objLayout.CanonicalMediaName = "A4"
          objLayout.PlotRotation = ac90degrees
      Else
          objLayout.PlotRotation = ac0degrees
      End If
      
'      objDoc.Plot.DisplayPlotPreview acFullPreview ' 完全预览并提示打印
'      objDoc.Plot.SetLayoutsToPlot = objLayout
      
      objDoc.Plot.PlotToDevice    ’不能正确执行，循环打印的都是模型布局中默认的窗口范围，没有变为前面赋值的范围
'      objPlot.PlotToDevice 'objLayout.ConfigName

    Next a
     If Err <> 0 Then
        Err.Clear
    End If
On Error GoTo 0
'Application.ScreenUpdating = True
  
End Function

楚河

修改后的程序
''Public Const acWindow As Integer = 4
'Public Const acMillimeter  As Integer = 1
'Public Const ac0degrees  As Integer = 0
'Public Const ac90degrees  As Integer = 1
'Public Const acScaleToFi  As Integer = 0
'Public Const acAllViewports  As Integer = 1
'Public Const acModelSpace   As Integer = 1


'简单说明一下打印函数
'cadDoc - 打开的cad文件
'kuainame - 打印图框名称
'PrinterName -打印机名称
'Styles -样式表名称
'MediaName -纸张大小
'AutoMedia -自动纸张开关
'AutoRotate -自动旋转, 纵向 / 横向

Function PlotFunction(cadDoc As Object, kuainame As String, PrinterName As String, Styles As String, MediaName As String, AutoMedia As Boolean, AutoRotate As Boolean)

On Error Resume Next

cadDoc.Application.ZoomAll
   

Rem 根据图框位置排序后进行打印
   
    Dim sel_block As Object
    Set sel_block = add_ss(cadDoc, "sel_block") '调用函数，创建选择集
   '根据图块名称多少，调用BuildFilter，构建图元表过滤表达式，指定不同的图元过滤表达式
    Dim tknum
    If InStr(1, kuainame, ";") Then
       matches = Split(kuainame, ";")
       tknum = UBound(matches)
       Select Case tknum
       Case 1
       BuildFilter pType1, pData1, -4, "<OR", 2, matches(0), 2, matches(1), -4, "OR>"
       Case 2
       BuildFilter pType1, pData1, -4, "<OR", 2, matches(0), 2, matches(1), 2, matches(2), -4, "OR>"
       Case 3
       BuildFilter pType1, pData1, -4, "<OR", 2, matches(0), 2, matches(1), 2, matches(2), 2, matches(3) - 4, "OR>"
       End Select
    Else

       BuildFilter pType1, pData1, 2, kuainame

    End If

   
    sel_block.Select acSelectionSetAll, , , pType1, pData1

    On Error Resume Next
    Dim blockarry() As BlockArray
    Dim blocknow As BlockArray
    Dim inPt As Variant  '获取块的插入位置坐标
    Dim i  As Integer
    i = 0
   
     
    For Each t In sel_block
        
        inPt = t.InsertionPoint
        With blocknow
         Set .blockObj = t
             .blockX = inPt(0)
             .blockY = inPt(1)
        End With
        i = i + 1
        
      
        ReDim Preserve blockarry(1 To i)
        
         With blockarry(i)
            Set .blockObj = blocknow.blockObj
                .blockX = blocknow.blockX
                .blockY = blocknow.blockY
             'Debug.Print blockarry(1).blockObj.Name
         End With
         
         Call MaopaoBlockArry(blockarry())

    Next t
   
'Dim Ent As Object
'Dim PlotCount As Integer

'Application.ScreenUpdating = False

'打印参数设置
''环境参数设置
'    Dim Osmode As Integer
'    Osmode = cadDoc.GetVariable("osmode")
'    cadDoc.SetVariable "osmode", 0
'
'    Dim Blipmode As Integer
'    Blipmode = cadDoc.GetVariable("blipmode")
'    cadDoc.SetVariable "blipmode", 0
'
'    Dim Cmdecho As Integer
'    Cmdecho = cadDoc.GetVariable("cmdecho")
'    cadDoc.SetVariable "cmdecho", 0


Dim ptMin As Variant, ptMax As Variant


' 检查当时空间是否为模型空间
'If objDoc.ActiveSpace = acPaperSpace Then
'   objDoc.MSpace = True
'   objDoc.ActiveSpace = acModelSpace
'End If
   

'Set objLayout = cadDoc.Layouts.Item("模型")
Set objLayout = cadDoc.Layouts.Item("Model") '打印空白的内容
'Set ActiveLayout = cadDoc.Layouts.Item("Model") 'ActiveLayout对应的旋转命令有效
'Set ActiveLayout = objDoc.ModelSpace.Layout
'Set ActiveLayout = cadDoc.Layouts.Item("模型") '使用图纸默认的模型布局，而且后面的选择无效
Set objPlot = cadDoc.Plot
cadDoc.Application.ZoomExtents
'
'
' 设置打印机

If Not Trim(PrinterName) = "" Then
objLayout.ConfigName = PrinterName
'ActiveLayout.ConfigName = PrinterName
Else
Exit Function
End If
' 设置打印样式表
If Not Trim(Styles) = "" Then
objLayout.StyleSheet = Styles
'ActiveLayout.StyleSheet = Styles
Else
objLayout.StyleSheet = "acad.ctb"
'ActiveLayout.StyleSheet = "acad.ctb"
End If
' 设置图纸尺寸
If AutoMedia Then
objLayout.CanonicalMediaName = "A4"
'ActiveLayout.CanonicalMediaName = "A4"
Else
If Not Trim(MediaName) = "" Then
objLayout.CanonicalMediaName = MediaName
'ActiveLayout.CanonicalMediaName = MediaName
Else
objLayout.CanonicalMediaName = "A4"
'ActiveLayout.CanonicalMediaName = "A4"
End If
End If
' 设置图纸单位
objLayout.PaperUnits = acMillimeters
'ActiveLayout.PaperUnits = acMillimeters

' 设置默认图纸打印方向
'objLayout.PlotRotation = ac0degrees '纵向
objLayout.PlotRotation = ac90degrees '横向
'ActiveLayout.PlotRotation = ac90degrees

' 设置图纸打印比例
objLayout.StandardScale = acScaleToFit
'ActiveLayout.StandardScale = acScaleToFit

objLayout.UseStandardScale = True '使用标准打印比例
'ActiveLayout.UseStandardScale = True

'objLayout.UseStandardScale = False '使用自定义打印比例
' 设置自定义打印比例
'objLayout.SetCustomScale txtNumerator.Value, txtDenominator.Value

' 设置图纸是否居中打印
objLayout.CenterPlot = True
'ActiveLayout.CenterPlot = True

' 打印时使用图形文件中的线宽
objLayout.PlotWithLineweights = True
'ActiveLayout.PlotWithLineweights = True
' 设置是否应用打印样式
objLayout.PlotWithPlotStyles = True
'ActiveLayout.PlotWithPlotStyles = True

' 打印时隐藏图纸空间对象
objLayout.PlotHidden = False
'ActiveLayout.PlotHidden = False

' 设置图纸打印份数
objPlot.NumberOfCopies = 1
' 将打印错误报告切换为静默错误模式，以便不间断地执行打印任务
objPlot.QuietErrorMode = True

' 设置前台打印，使打印任务按打印顺序依次发送到打印机
cadDoc.SetVariable "BACKGROUNDPLOT", 0

' 重新生成当前图形
cadDoc.Regen acAllViewports


' 根据图块的左下角及右上角坐标设置打印窗口
   
   Dim a, b, c As Integer
    a = 0
'    b = 0
'    c = 1
   For a = 1 To i
      
      blockarry(a).blockObj.GetBoundingBox ptMin, ptMax

      Debug.Print blockarry(a).blockObj.Name

'      ReDim Preserve ptMin(0 To 1) ' 将三维点转化为二维点坐标
'      ReDim Preserve ptMax(0 To 1)

      Debug.Print ptMin(0) & "--" & ptMin(1)
      Debug.Print ptMax(0) & "--" & ptMax(1)
      
      
' 设置打印窗口

'      objLayout.SetWindowToPlot ptMin, ptMax
'      ActiveLayout.SetWindowToPlot ptMin, ptMax
'      cadDoc.acModelSpace.SetWindowToPlot ptMin, ptMax


      objLayout.SetWindowToPlot ptMin, ptMax
'      ActiveLayout.SetWindowToPlot ptMin, ptMax
      Dim pptMin As Variant, pptMax As Variant
      objLayout.GetWindowToPlot pptMin, pptMax
      Debug.Print pptMin(0) & "--" & pptMin(1)
      Debug.Print pptMax(0) & "--" & pptMax(1)
      
      objLayout.PlotType = acWindow
'      ActiveLayout.PlotType = acWindow'起作用会导致选区为空
'      objLayout.PlotType = acExtents

      If Abs(ptMax(0) - ptMin(0)) < Abs(ptMax(1) - ptMin(1)) And AutoRotate Then '纵图不旋转
          objLayout.PlotRotation = ac0degrees
'         ActiveLayout.PlotRotation = ac90degrees
      Else
          objLayout.PlotRotation = ac90degrees '旋转命令无效
'         ActiveLayout.PlotRotation = ac0degrees '旋转命令有效
      End If
      
'      objDoc.Plot.DisplayPlotPreview acFullPreview ' 完全预览并提示打印
'      objDoc.Plot.SetLayoutsToPlot = objLayout
      
      objPlot.PlotToDevice
'      objPlot.PlotToDevice 'objLayout.ConfigName
      

    Next a
   
    If Err <> 0 Then
        Err.Clear
    End If
On Error GoTo 0
'Application.ScreenUpdating = True
  
End Function

楚河

我提供一下我参考的源程序，这个源程序应该是在CAD的VBA环境运行，我取其中一部分并做了修改
'快速打印/批量打印
Public Sub PlotFunction(PrinterName As String, Styles As String, MediaName As String, Copies As Integer, AutoMedia As Boolean, AutoRotate As Boolean, AutoClose As Boolean, AutoFrame As Boolean)
On Error Resume Next
Dim ptMin As Variant, ptMax As Variant
Dim Ent As AcadEntity
Dim PlotCount As Integer
Set objDoc = ThisDrawing.Application.ActiveDocument
Set objLayout = objDoc.Layouts.Item("Model")
Set objPlot = objDoc.Plot
ThisDrawing.Application.ZoomExtents
' 设置打印机
If Not Trim(PrinterName) = "" Then
objLayout.ConfigName = PrinterName
Else
Exit Sub
End If
' 设置打印样式表
If Not Trim(Styles) = "" Then
objLayout.StyleSheet = Styles
Else
objLayout.StyleSheet = "acad.ctb"
End If
' 设置图纸尺寸
If AutoMedia Then
objLayout.CanonicalMediaName = "A3"
Else
If Not Trim(MediaName) = "" Then
objLayout.CanonicalMediaName = MediaName
Else
objLayout.CanonicalMediaName = "A3"
End If
End If
' 设置图纸单位
objLayout.PaperUnits = acMillimeters
'objLayout.PaperUnits = acInches
' 设置默认图纸打印方向
'objLayout.PlotRotation = ac0degrees '纵向
'objLayout.PlotRotation = ac180degrees
objLayout.PlotRotation = ac90degrees '横向
'objLayout.PlotRotation = ac270degrees
' 设置图纸打印比例
objLayout.StandardScale = acScaleToFit
objLayout.UseStandardScale = True '使用标准打印比例
'objLayout.UseStandardScale = False '使用自定义打印比例
' 设置自定义打印比例
'objLayout.SetCustomScale txtNumerator.Value, txtDenominator.Value
' 设置图纸是否居中打印
objLayout.CenterPlot = True
' 打印时使用图形文件中的线宽
objLayout.PlotWithLineweights = True
' 设置是否应用打印样式
objLayout.PlotWithPlotStyles = True
' 打印时隐藏图纸空间对象
objLayout.PlotHidden = False
' 设置图纸打印份数
If Copies >= 1 Then
objPlot.NumberOfCopies = CInt(Copies)
Else
objPlot.NumberOfCopies = 1
End If
' 将打印错误报告切换为静默错误模式，以便不间断地执行打印任务
objPlot.QuietErrorMode = True
' 重新生成当前图形
objDoc.Regen acAllViewports
' 设置前台打印，使打印任务按打印顺序依次发送到打印机
objDoc.SetVariable "BACKGROUNDPLOT", 0
PlotCount = 0 '打印计数
For Each Ent In objDoc.ModelSpace
If TypeOf Ent Is AcadBlockReference Then
If IsFrame(Ent, AutoFrame) = True And objDoc.Blocks(Ent.Name).count > 0 Then Ent.GetBoundingBox ptMin, ptMax
Debug.Print Ent.Name & "--" & objDoc.Blocks(Ent.Name).count
' 将三维点转化为二维点坐标
ReDim Preserve ptMin(0 To 1)
ReDim Preserve ptMax(0 To 1)
' 设置打印窗口
ThisDrawing.ActiveLayout.SetWindowToPlot ptMin, ptMax
objLayout.PlotType = acWindow
If Abs(ptMax(0) - ptMin(0)) < Abs(ptMax(1) - ptMin(1)) Then
If AutoMedia Then objLayout.CanonicalMediaName = "A4"
If AutoRotate Then objLayout.PlotRotation = ac0degrees
End If
' 完全预览并提示打印
objPlot.DisplayPlotPreview acFullPreview
UserSel = MsgBox("是否打印预览？" & Chr(13) & Chr(13) & "打印到：" & objLayout.ConfigName & " 大小：" & objLayout.CanonicalMediaName & " 方式：acWindow(" & objLayout.PlotType & ") " & Chr(13) & Chr(13) & "选择[取消]退出程序！", vbYesNoCancel, "打印选项")
If UserSel = vbYes Then
objPlot.PlotToDevice objLayout.ConfigName
PlotCount = PlotCount + 1
ElseIf UserSel = vbCancel Then
Exit For
End If
End If
End If
Next Ent
' 图框为编组(Group)对象时
Dim FrmGrp As AcadGroup
Dim TptMin, TptMax As Variant
' 按编组名称查找图框编组对象
For Each FrmGrp In ThisDrawing.Groups
If IsFrame(FrmGrp, False) And FrmGrp.count > 0 Then
Debug.Print FrmGrp.Name & " [Items]:" & FrmGrp.count & "----group"
' 得到图框边界点坐标
FrmGrp.Item(0).GetBoundingBox ptMin, ptMax
For i = 1 To FrmGrp.count - 1
FrmGrp.Item(i).GetBoundingBox TptMin, TptMax
ReDim Preserve TptMin(0 To 1)
ReDim Preserve TptMax(0 To 1)
For j = 0 To 1
If TptMin(j) < ptMin(j) Then
ptMin(j) = TptMin(j)
End If
If TptMax(j) > ptMax(j) Then
ptMax(j) = TptMax(j)
End If
Next j
i = i + 1
Next
' 将三维点转化为二维点坐标
ReDim Preserve ptMin(0 To 1)
ReDim Preserve ptMax(0 To 1)
' 设置打印窗口
ThisDrawing.ActiveLayout.SetWindowToPlot ptMin, ptMax
objLayout.PlotType = acWindow
If Abs(ptMax(0) - ptMin(0)) < Abs(ptMax(1) - ptMin(1)) Then
If AutoMedia Then objLayout.CanonicalMediaName = "A4"
If AutoRotate Then objLayout.PlotRotation = ac0degrees
End If
' 完全预览并提示打印
objPlot.DisplayPlotPreview acFullPreview
UserSel = MsgBox("是否打印预览？" & Chr(13) & Chr(13) & "打印到：" & objLayout.ConfigName & " 大小：" & objLayout.CanonicalMediaName & " 方式：acWindow(" & objLayout.PlotType & ") " & Chr(13) & Chr(13) & "选择[取消]退出程序！", vbYesNoCancel, "打印选项")
If UserSel = vbYes Then
PlotCount = PlotCount + 1
objPlot.PlotToDevice objLayout.ConfigName
ElseIf UserSel = vbCancel Then
Exit For
End If
End If
Next FrmGrp
' 没有找到图框时按范围打印
If PlotCount = 0 And objDoc.ModelSpace.count > 0 Then
ptMax = ThisDrawing.GetVariable("EXTMAX")
ptMin = ThisDrawing.GetVariable("EXTMIN")
' 图形范围内无实体则退出
If ptMax(0) = ptMin(0) Or ptMax(1) = ptMin(1) Then
Exit Sub
End If
' 设置范围打印
objLayout.PlotType = acExtents
' 对纵向的图纸设置
If Abs(ptMax(0) - ptMin(0)) < Abs(ptMax(1) - ptMin(1)) Then
If AutoMedia Then objLayout.CanonicalMediaName = "A4"
If AutoRotate Then objLayout.PlotRotation = ac0degrees
End If
' 完全预览并提示打印
objPlot.DisplayPlotPreview acFullPreview
UserSel = MsgBox("是否打印预览？" & Chr(13) & Chr(13) & "打印到：" & objLayout.ConfigName & " 大小：" & objLayout.CanonicalMediaName & " 方式：acExtents(" & objLayout.PlotType & ") " & Chr(13) & Chr(13) & "选择[取消]退出程序！", vbYesNoCancel, "打印选项")
If UserSel = vbYes Then
objPlot.PlotToDevice objLayout.ConfigName
ElseIf UserSel = vbCancel Then
Exit Sub
End If
End If
' 关闭文档False 为不保存修改
If AutoClose Then objDoc.Close False, ThisDrawing.Name
End Sub
Public Function IsFrame(entobj As Object, AutoMode As Boolean) As Boolean '判断是否为图框
On Error Resume Next
IsFrame = False
Dim i As Integer
Dim FrmNameList As Variant
FrmNameList = "blkFrame,A1,A2,A3,A4,PC_PAPER_DIC" '图框块、编组名列表FrmNameList = Split(FrmNameList, ",")
For i = 0 To UBound(FrmNameList)
If entobj.Name = FrmNameList(i) Then
IsFrame = True
Exit For
End If
Next
'块名不符时由大小比例判断是否为图框(可能会误判,不过几率不高)
If IsFrame = False And AutoMode And entobj.ObjectName = "AcDbBlockReference" Then entobj.GetBoundingBox ptMin, ptMax
Debug.Print ptMin(0) & "--" & ptMax(0)
If Abs((ptMax(1) - ptMin(1)) / (ptMax(0) - ptMin(0)) - 1.414) < 0.01 Or Abs((ptMax(1) - ptMin(1)) / (ptMax(0) - ptMin(0)) - 0.707) < 0.01 Then
IsFrame = True
End If
End If
End Function

楚河

数据分析的情况：
比例是一致的，1：1，只是原点不一致，具体如下：
                X坐标        Y坐标        长（X2-X1）        高（Y2-Y1）        原点差值（XB-XP）        原点差值（YB-YP）
第一个图框块GetBoundingBox获得的坐标        左下角        803290        541273        29404        20439        149269        180006
        右上角        832694        561713                               
第一个图框块为打印窗口后GetWindowToPlot获取坐标        左下角        654021        361267        29404        20439               
        右上角        683425        381707                               
第二个图框块GetBoundingBox获得的坐标        左下角        832694        541273        29404        20439        149269        180006
        右上角        862098        561713                               
第二个图框块为打印窗口后GetWindowToPlot获取坐标        左下角        683425        361267        29485        20439               
        右上角        712910        381707                               
第三个图框块GetBoundingBox获得的坐标        左下角        862096        541273        29409        42302        149269        180005
        右上角        891504        583575                               
第三个图框块为打印窗口后GetWindowToPlot获取坐标        左下角        712827        361269        29660        42299               
        右上角        742487        403568                               
第四个图框块GetBoundingBox获得的坐标        左下角        803290        494623        29404        20439        149269        180006
        右上角        832694        515062                               
第四个图框块为打印窗口后GetWindowToPlot获取坐标        左下角        654021        314617        29406        20439               
        右上角        683428        335056                               
第五个图框块GetBoundingBox获得的坐标        左下角        832692        494623        29409        42302        149269        180005
        右上角        862100        536925                               
第五个图框块为打印窗口后GetWindowToPlot获取坐标        左下角        683423        314618        29409        42299               
        右上角        712832        356917                               

chixun99

Set objLayout = objDoc.Layouts.Item("模型") '中文版本，“模型”布局
'Set objLayout = objDoc.Layouts.Item("Model")
这2句估计有点问题，图纸布局空间可以用上2句方式，模型空间不同于图纸空间的，按下边这么写试试吧。
Set objLayout = objDoc.ModelSpace.Layout

楚河

感谢建议，不过还是不行

mikewolf2k

ReDim Preserve ptMin(0 To 1)
你确定需要转换么？模型是三维的。原始程序是不是用在layout上的？

楚河

打印应该是二维的吧，可以测试一下，感谢提供解决思路

楚河

      blockarry(a).blockObj.GetBoundingBox ptMin, ptMax

      Debug.Print blockarry(a).blockObj.Name

'      ReDim Preserve ptMin(0 To 1) ' 将三维点转化为二维点坐标
'      ReDim Preserve ptMax(0 To 1)

      Debug.Print ptMin(0) & "--" & ptMin(1)
      Debug.Print ptMax(0) & "--" & ptMax(1)
      
      
' 设置打印窗口

'      objLayout.SetWindowToPlot ptMin, ptMax
'      ActiveLayout.SetWindowToPlot ptMin, ptMax
'      cadDoc.acModelSpace.SetWindowToPlot ptMin, ptMax


      objLayout.SetWindowToPlot ptMin, ptMax
'      ActiveLayout.SetWindowToPlot ptMin, ptMax
      Dim pptMin As Variant, pptMax As Variant
      objLayout.GetWindowToPlot pptMin, pptMax
      Debug.Print pptMin(0) & "--" & pptMin(1)
      Debug.Print pptMax(0) & "--" & pptMax(1)
以上部分代码的执行结果：
a4h
803289.999954268--541273.365925417
832693.999954268--561712.731753247
654021.295610093--361267.136916942
683425.295610093--381706.502744772
a4h
832693.999954268--541273.365925417
862097.999954267--561712.731753247
654021.295610093--361267.136916942
683425.295610093--381706.502744772
a4z
862095.684084867--541273.365925417
891504.315823679--583575.467145161
654021.295610093--361267.136916942
683425.295610093--381706.502744772
a4h
803289.999954268--494623.000097587
832693.999954268--515062.365925417
654021.295610093--361267.136916942
683425.295610093--381706.502744772
a4z
832691.684084867--494623.000097587
862100.315823679--536925.101317331
654021.295610093--361267.136916942
683425.295610093--381706.502744772
可以看出，objLayout.SetWindowToPlot ptMin, ptMax，并没有起到认为的作用

楚河

将上面的三维转二维注释去掉后，执行情况为：
a4h
803289.999954268--541273.365925417
832693.999954268--561712.731753247
803289.999954268--541273.365925417
832693.999954268--561712.731753247
a4h
832693.999954268--541273.365925417
862097.999954267--561712.731753247
832693.999954268--541273.365925417
862097.999954267--561712.731753247
a4z
862095.684084867--541273.365925417
891504.315823679--583575.467145161
862095.684084867--541273.365925417
891504.315823679--583575.467145161
a4h
803289.999954268--494623.000097587
832693.999954268--515062.365925417
803289.999954268--494623.000097587
832693.999954268--515062.365925417
a4z
832691.684084867--494623.000097587
862100.315823679--536925.101317331
832691.684084867--494623.000097587
862100.315823679--536925.101317331
只是打印内容为空白，但是之前打印的是图纸文件上一次模型布局中选定的窗口范围
就是说 窗口的范围设定起作用了，但是为什么打印结果确实空白，是范围有问题，还是其他原因，例如颜色，或者其他

楚河

我大概找到原因了，程序执行是正确的，错误的是块的左下角坐标和右上角坐标，不是模型空间的坐标，这是怎么回事，谁清楚啊？
这是块边界左下角坐标：
803289.999954268--541273.365925417
832693.999954268--561712.731753247
同一个块，模型空间打印窗口的数据坐标：
654021.295610093--361267.136916942
683425.295610093--381706.502744772
这是怎么回事啊