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

zzllyp · 发表于 2011-3-7 06:55:40

真的很不错谢谢分享

HZY130072 · 发表于 2011-3-24 10:19:06

谢谢楼主，程序很不错

669423907 · 发表于 2011-3-24 21:02:35

谢谢楼主的好程序！

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

(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 · 发表于 2011-4-15 20:19:39

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

kingzgh · 发表于 2011-4-20 11:35:47

相当赞啊

shi · 发表于 2011-5-12 21:43:47

谢谢楼主的无私分享！

shi · 发表于 2011-5-17 21:16:19

看了楼主代码刚好用上，用了几天时间修改了以下几点：
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 · 发表于 2011-8-16 17:25:36

准备好好研读一下！

wwswwswws · 发表于 2011-9-19 16:20:10

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

xinght99 · 发表于 2011-9-26 12:51:25

相当赞啊

账号		自动登录	找回密码
密码			注册