直接贴程序，没套路

Sub FindAllFile()Dim filename  As VariantDim index As Integerfpath = "D:\Users\Desktop\"filename = Dir(fpath)Do While filename <> ""If Right(filename, 3) = "dwg" ThenBlockUpdate fpath + filename, filenameDebug.Print (filename + " Changed OK")index = index + 1End Iffilename = DirLoopMsgBox ("已经完成修改" & index & "份")
End Sub
Sub BlockUpdate(fpath As String, filename As Variant)Dim ModelSpace As ZcadModelSpaceDim Blocks As ZcadBlocksDim blkref As VariantDim index, i, attindex As IntegerDim varAttributes  As VariantDim frame As StringThisDrawing.Application.Documents.Open (fpath)Set ModelSpace = ThisDrawing.ModelSpaceSet Blocks = ThisDrawing.BlocksFor index = 0 To Blocks.Count - 1If Blocks.Item(index).Name = "BTL1" ThenFor i = 0 To Blocks.Item(index).Count - 1If TypeOf Blocks.Item(index).Item(i) Is ZcadText ThenIf Blocks.Item(index).Item(i).TextString = "用户代号" ThenBlocks.Item(index).Item(i).TextString = "用户编码"ElseIf Blocks.Item(index).Item(i).TextString = "CLIENT DRAWING NO." ThenBlocks.Item(index).Item(i).TextString = "USER CODE NO."End IfEnd IfNextElseIf Blocks.Item(index).Name = "SBWL_A4V" Thenframe = "SBWL_A4V"ElseIf Blocks.Item(index).Name = "SBWL_A3H" Thenframe = "SBWL_A3H"ElseIf Blocks.Item(index).Name = "SBWL_A2H" Thenframe = "SBWL_A2H"ElseIf Blocks.Item(index).Name = "SBWL_A1H" Thenframe = "SBWL_A1H"ElseIf Blocks.Item(index).Name = "SBWL_A0H" Thenframe = "SBWL_A0H"End IfNextFor index = 0 To ModelSpace.Count - 1If TypeOf ModelSpace.Item(index) Is ZcadBlockReference ThenIf ModelSpace.Item(index).EffectiveName = "BTL1" ThenSet blkref = ModelSpace.Item(index)varAttributes = blkref.GetAttributesFor i = LBound(varAttributes) To UBound(varAttributes)If varAttributes(i).TagString = "CLIENT_DWG{8}" ThenvarAttributes(i).TextString = "XP-2-PRXJ-44-AA000001-DG-0001"ElseIf varAttributes(i).TagString = "DWG_STATUS{7}" ThenvarAttributes(i).TextString = "PRE"End IfNextEnd IfEnd IfNextThisDrawing.SavePrintPDF filename, frameThisDrawing.SaveThisDrawing.Application.Documents.Close
End SubSub PrintPDF(file As Variant, frame As String)Dim currentplot As ZcadPlotSet currentplot = ThisDrawing.Plotfile = Replace(file, ".dwg", ".PDF")file = GetIndex(file)ThisDrawing.ModelSpace.Layout.ConfigName = "DWG TO PDF.pc5"ThisDrawing.ModelSpace.Layout.PlotRotation = zc180degreesIf frame = "SBWL_A4V" ThenThisDrawing.ModelSpace.Layout.CanonicalMediaName = "ISO_A4_(210.00_x_297.00_MM)"ElseIf frame = "SBWL_A3H" ThenThisDrawing.ModelSpace.Layout.CanonicalMediaName = "ISO_A3_(420.00_x_297.00_MM)"ElseIf frame = "SBWL_A2H" ThenThisDrawing.ModelSpace.Layout.CanonicalMediaName = "ISO_A2_(594.00_x_420.00_MM)"ElseThisDrawing.ModelSpace.Layout.CanonicalMediaName = "ISO_A1_(841.00_x_594.00_MM)"End IfThisDrawing.ModelSpace.Layout.CenterPlot = TrueThisDrawing.ModelSpace.Layout.PlotType = zcExtentsThisDrawing.ModelSpace.Layout.StyleSheet = "PCCAD.ctb"ThisDrawing.Application.ZoomExtentscurrentplot.PlotToFile ("D:\Users\Desktop\" & file)
End SubFunction GetIndex(str As Variant) As StringDim i, cnt, S, L As Integercnt = 0For i = 1 To Len(str)If Mid(str, i, 1) = "-" Thencnt = cnt + 1If cnt = 4 ThenS = iExit ForEnd IfEnd IfNextIf cnt = 4 ThenL = InStr(str, ".")GetIndex = Mid(str, 1, S - 1) + Mid(str, L)ElseGetIndex = strEnd If
End Function

【利用VBA批量处理中望CAD的修改打印出PDF】相关推荐

如何利用VBA批量更改Excel文件的内容
心得(5):利用VBA批量更改Excel文件的内容问题:因为接受的所有Excel文件都是相同格式的,但是有个单元格的内容就是需要,主办方来更改,如下所示: 获奖级别,得由主办方来更改,但是如果一个一 ...
Excel 2010 VBA 入门 103 利用VBA批量插入图片
目录示例代码: Shapes.Shape和 ShapeRange Shapes对象插入图形的方法 Excel的坐标图形大小的调整获取图片的原始大小将图片按比例缩放至单元格图片批量插入的步骤 ...
利用VBA批量删除Excel中的中文/英文/数字或者替换中英文符号
↓↓↓欢迎关注我的公众号,在这里有数据相关技术经验的优质原创文章↓↓↓ 在Excel中经常会遇到去除所有的中文,英文或者数字等情况.但是由于Excel并不支持一次替换所有的中文,英文,数字等,所以有些 ...
Excel 2010 VBA 入门 102 利用VBA批量发送邮件
目录示例代码 CDO组件 CDO. Message. Configuration对象前期绑定与后期绑定 New关键字创建对象添加邮件的附件示例如图所示,该表为某公司员工工资单.现需要将该表 ...
利用VBA批量替换多个Word内容(带窗体界面/支持备份、大小写、通配符等功能)
背景:朋友工作中有多个Word文件,每次做更新时都要更新文档内的日期,每次手工更改都比较耗费时间,加上公司电脑不能装未授权的软件,且只支持英文,于是就根据这个需求,参考一些网上的代码,并做了一些升级, ...
利用VBA批量新建工作表以及重命名，删除除指定以外的工作表
以下是代码: Sub 批量新增工作表并命名()Dim n, i, x, y, rng As Rangen = Application.WorksheetFunction.CountA(Columns( ...
vb microsoft.xmlhttp 获取所有超链接_利用VBA批量自动生成表格超链接
Excel如何自动生成有超链接的Sheet目录? 如下图中所示的工作簿中,有很多个Sheet.目的是把所有的Sheet在目录表中制作成超链接的形式,点击跳转. 解决方案:录制宏+循环下面的东西可能很 ...
利用VBA批量发送Excel中工资单邮件
代码如下 Sub send() On Error Resume NextDim rowCount, endRowNo, endColumnNo, sFile$, sFile1$, A&, B& ...
利用VBA批量删除EXCEL中的空白工作表SHEET
Sub delSheet()Dim x As WorksheetApplication.DisplayAlerts = FalseFor Each x In SheetsIf IsEmpty(x.Us ...
利用VBA 批量创建工作表
以创建1月份每天的sheet表为例子. 每一个数据单元格最前面都加上一个单引号打开开发工具中的visual basic 点这个图标选择模块在模块中键入以下代码 Sub NewSht()Dim sh ...

【利用VBA批量处理中望CAD的修改打印出PDF】

利用VBA批量处理中望CAD的修改打印出PDF

直接贴程序，没套路

【利用VBA批量处理中望CAD的修改打印出PDF】相关推荐

最新文章

热门文章