真的很不错谢谢分享
谢谢楼主，程序很不错
谢谢楼主的好程序！
我下载了一个标公差程序:
(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
谢谢啦。
我看不懂代码啊，楼主能否留下联系方式！
相当赞啊
谢谢楼主的无私分享！
看了楼主代码刚好用上，用了几天时间修改了以下几点：
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
准备好好研读一下！
太好了，下载研究，感谢楼主无私献。
相当赞啊