自己用VBA编的批量打印程序（原创）

zzllyp

真的很不错谢谢分享

HZY130072

谢谢楼主，程序很不错

669423907

谢谢楼主的好程序！


我下载了一个标公差程序:

(DEFUN C:eed()
(setvar "cmdecho" 0)
(if (= xx nil) (setq xx 0 yy 0))
(prompt "\n+(")(princ xx )(princ ")")(setq n (getreal""))
(prompt "\n-(")(princ yy )(princ ")")(setq m (getreal""))
(if (= m nil) (setq n xx))
(if (= m nil) (setq m yy))
(setq k 0)
(while (<= k 5)
(setq a (fix (* (EXPT 10 (- 5 K)) n)))
(setq b (* 10 (fix (* (expt 10 (- 4 k)) n))))
(setq k1 (- 5 k))
(IF (= a b) (SETQ K (+ K 1)) (setq K 6)))
(setq k 0)
(while (<= k 5)
(setq a (fix (* (EXPT 10 (- 5 K)) M)))
(setq b (* 10 (fix (* (expt 10 (- 4 K )) M))))
(SETQ K2 (- 5 k))
(IF (= a b) (SETQ K (+ K 1)) (setq K 6)))
(setQ d2 (max K1 K2))
(if (= n m) (setq c 1) (setq c 0.6))
(if (and (= n 0) (= m 0)) (COMMAND "_DIMOVERRIDE" "dimtol" "off" "")
(COMMAND "_DIMOVERRIDE" "DIMTP" n "DIMTM" M "DIMTOL" "ON" "DIMTFAC" c "DIMTDEC" D2 ""))
(SETQ xx n yy m)
(PRINC ))

不知楼主是否便帮忙改一下；
1.去掉记忆功能
2.不输入时默认为0
谢谢啦。

guangyaola

我看不懂代码啊，楼主能否留下联系方式！

kingzgh

相当赞啊

shi

谢谢楼主的无私分享！

shi

看了楼主代码刚好用上，用了几天时间修改了以下几点：
1、改用数据集方法排序坐标数组，打印速度大大提高，需要引用ado
2、修改了图纸自动判断方向
3、增加一个从图纸中选择打印范围的按钮
4、图块或图层的相关代码合并

相关代码如下：红色部分为主要变化代码
''按图块或图层名称批量打印
Private Sub BatchPlot(strReferenceName As String)
    Dim pointRest As ADODB.Recordset
    Dim ptMin As Variant, ptMax As Variant
    Dim ent As AcadEntity
    Dim i As Integer, j As Integer, n As Integer
    Dim min As Variant, max As Variant, util As AcadUtility
    Dim points() As Variant
    Dim PtMax_UCS(1) As Double, PtMin_UCS(1) As Double
    Dim PaperWidth As Double, PaperHeight As Double
    Dim wd As Double, gd As Double
    Dim dxs As Integer, r As Integer
    Dim SSet As AcadSelectionSet
        
'        On Error Resume Next
    '如果列表框中未存在任何元素
    If lstPlotFiles.ListCount = 0 Then
        MsgBox "请先向列表框中添加文件！", vbCritical
        Exit Sub
    End If
     
    '将控制权交给AutoCAD
    frmBatchPlot.Hide
    ' 对第i个图形的每一个打印区域进行打印
    For i = 0 To lstPlotFiles.ListCount - 1
        n = 1
        '检查文件是否存在
        If Len(Dir(lstPlotFiles.List(i))) = 0 Then
            MsgBox "文件" & lstPlotFiles.List(i) & "不存在！"
        End If
        '打开或激活第i个图形文件
        Call OpenFile(lstPlotFiles.List(i))
        Set objDoc = ThisDrawing.Application.ActiveDocument
        '实现范围缩放
        ThisDrawing.Application.ZoomExtents
        ' 确保当前布局是模型空间
        Set objLayout = objDoc.Layouts.Item("Model")
        Set objPlot = objDoc.Plot
        ' 设置打印选项
        Call SetPlotConfiguration
        ' 将打印设置应用到当前图形
        objLayout.CopyFrom objPlotConfiguration
        '重新生成当前图形
'        objDoc.Regen acAllViewports
        ' 确保AutoCAD在前台进行打印，这样后一次打印会在前一次打印完成之后才开始,避免出现错误
        objDoc.SetVariable "BACKGROUNDPLOT", 0
        
        '对当前图形模型空间中的所有打印区域进行打印
        '使用选择集获得对象集合
        Call SelectBy(strReferenceName, SSet)
               
         dxs = SSet.count - 1
         ReDim points(dxs, 3) '定义2维数组
          Set util = ThisDrawing.Utility
         For r = 0 To dxs
              '获得每个对象最小包围框的两个角点
              SSet.Item(r).GetBoundingBox min, max
              '将世界坐标(WCS)转换为显示坐标(DCS)
              ptMin = util.TranslateCoordinates(min, acWorld, acDisplayDCS, False)
              ptMax = util.TranslateCoordinates(max, acWorld, acDisplayDCS, False)
              points(r, 0) = ptMin(0): points(r, 1) = ptMin(1): 'points(r, 2) = ptMin(2)
              points(r, 2) = ptMax(0): points(r, 3) = ptMax(1): 'points(r, 5) = ptMax(2)
          Next
        ' 删除选择集
        SSet.Delete
        
        ' 获取排序过的图块坐标点数据集
       Set pointRest = objpoint(points())
        
       '取得图纸尺寸信息
        objPlotConfiguration.GetPaperSize PaperWidth, PaperHeight
   
        '对选择集中每个对象进行打印或预览
        For j = 0 To dxs
            Erase PtMin_UCS '            '清除二维点坐标数组
            Erase PtMax_UCS
            
            PtMin_UCS(0) = pointRest.Fields(0): PtMin_UCS(1) = pointRest.Fields(1)
            PtMax_UCS(0) = pointRest.Fields(2): PtMax_UCS(1) = pointRest.Fields(3)
            pointRest.MoveNext
            
            ' 设置打印窗口(为显示坐标DCS)
            objLayout.SetWindowToPlot PtMin_UCS, PtMax_UCS
            
             wd = PtMax_UCS(0) - PtMin_UCS(0)
             gd = PtMax_UCS(1) - PtMin_UCS(1)
            
'            Debug.Print PtMax_UCS(0)
'            Debug.Print PtMax_UCS(1)
'            Debug.Print PtMin_UCS(0)
'            Debug.Print PtMin_UCS(1)
            ' 设置图纸打印方向
            If PaperWidth < PaperHeight And wd < gd Then   '图纸宽<高
                ThisDrawing.ModelSpace.Layout.PlotRotation = ac0degrees
            Else
                ThisDrawing.ModelSpace.Layout.PlotRotation = ac90degrees
            End If
               
            '接收打印范围
            ThisDrawing.ModelSpace.Layout.GetWindowToPlot PtMin_UCS, PtMax_UCS
            '指定为窗口打印
            ThisDrawing.ModelSpace.Layout.PlotType = acWindow
   
            ' 打印当前的区域
            '若选中“打印到文件”
            If chkPlotToFile.Value Then
                objPlot.PlotToFile cboPlotPath.Text & objDoc.Name & "-" & n & ".dwf"
                n = n + 1
            Else
               objPlot.PlotToDevice objLayout.ConfigName
            End If
        Next j
        
        ' 恢复系统变量的值
        objDoc.SetVariable "BACKGROUNDPLOT", 2
        '保存当前图形
        'objDoc.Save
        '关闭但不保存当前图形
        '保证至少一个文件打开
        If ThisDrawing.Application.Documents.count > 1 Then
            objDoc.Close False
        End If
    Next i
    '显示对话框
    Set pointRest = Nothing
    frmBatchPlot.Show
End Sub

'改用数据集方法排序坐标数组，速度大大提高
Public Function objpoint(points As Variant) As ADODB.Recordset
  Dim mArray As Variant
  Dim rst As ADODB.Recordset
  
  RstFiledsName = Array("ptMin0", "ptMin1", "ptMax0", "ptMax1")
  '建立数据集字段名
  Set rst = New ADODB.Recordset
  With rst
    .Fields.Append RstFiledsName(0), adDouble ', 20, adFldIsNullable
    .Fields.Append RstFiledsName(1), adDouble
    .Fields.Append RstFiledsName(2), adDouble
    .Fields.Append RstFiledsName(3), adDouble ', , adFldMayBeNull
'    .Fields.Append RstFiledsName(4), adDouble ', , adFldMayBeNull
'    .Fields.Append RstFiledsName(5), adDouble ', , adFldMayBeNull
  End With
  
  With rst
        .Open
        '给数据集填充数据
        For jj = 0 To UBound(points)
            .AddNew
            .Fields(0) = points(jj, 0)
            .Fields(1) = points(jj, 1)
            .Fields(2) = points(jj, 2)
            .Fields(3) = points(jj, 3)
'            .Fields(4) = points(jj, 4)
'            .Fields(5) = points(jj, 5)
        Next jj
'        For ii = 0 To .RecordCount - 1
'            Debug.Print .Fields(0), .Fields(1), .Fields(2)
'            .MoveNext
'        Next ii
  End With
           ' 设置图纸打印顺序
        If frmBatchPlot.optSortZ.Value Then
            '按坐标对图框排序(左右，上下：y坐标从大到小,x坐标从小到大)
            rst.Sort = ("ptMin1 desc ,ptMin0 asc")
        Else
            '按坐标对图框排序(上下，左右：x坐标从小到大,y坐标从大到小)
             rst.Sort = ("ptMin0 Asc,ptMin1 desc ")
        End If
        
        ' 若选择倒序
        If frmBatchPlot.chkSort.Value Then
            If frmBatchPlot.optSortZ.Value Then  '左右，上下
                rst.Sort = ("ptMin1 asc ,ptMin0 desc")
            Else
                 rst.Sort = ("ptMin0 desc,ptMin1 asc ")   '上下，左右
            End If
        End If
              rst.MoveFirst
  Set objpoint = rst
  Set rst = Nothing
End Function


    '第3点，从图纸中选择打印范围的相关代码
    If Chk_fw = True Then
        SSet.SelectOnScreen fType, fData  '建立选择集并从屏幕选取
    Else
        SSet.Select acSelectionSetAll, , , fType, fData
    End If
   

yeqb4749659

准备好好研读一下！

wwswwswws

太好了，下载研究，感谢楼主无私献。

xinght99

相当赞啊