VBA 多文档打印问题。
多文档转换出来问题。自己电脑上要加msgbox "是否继续", 才能正常多文档打印，别人电脑上可以正常打印，为啥？I write a code for CAD batch plot,the main code ofthe pass for different dwg is
below.
Public Sub dylst(strPath, Flag As Boolean, Optional Mlstr1 As String = "忽略",
Optional Mlstr2 As String = "忽略")
Dim Mnew As AcadDocument
Dim Tkdoc As AcadSelectionSet, Mstr As String
Set Mnew = ThisDrawing.Application.Documents.Open(strPath, ReadOnly) '只
读方式打开图形
' MsgBox "是否继续打印？"
BuildFilter pType, pData, 2, Mainfrm.TextBox1.Text '建立图块过滤器
For Each Tkdoc In Mnew.SelectionSets
If Tkdoc.Name = "Tkdoc" Then
Tkdoc.Delete
Exit For
End If
Next
Set Tkdoc = Mnew.SelectionSets.Add("Tkdoc")
Mnew.SetVariable "REGENMODE", 1 '防止图纸大的时候缩放出现提示
Mnew.Application.ZoomExtents
Tkdoc.Select acSelectionSetAll, , , pType, pData
If Mlstr1 = "忽略" Then
Dy Tkdoc, Flag, Mnew
Else
'Debug.Print "执行！"
Dy Tkdoc, Flag, Mnew, Mlstr1, Mlstr2
End If
Mnew.Close False
Tkdoc.Delete
End Sub I my computerI test itin CAD 2008 and CAD 2012 ,It opensalllthe
dwg in the list and nothing of the code "dy" excute.
Set Mnew = ThisDrawing.Application.Documents.Open(strPath, ReadOnly) '只读方式打
开图形
"dy"is the module i write for plot a single dwg.
But if i add the code of "MsgBox "Continue?" " i t works well !and in some
other computer it also works well without the code of "MsgBox "Continue?" " . I
was so confused about this problem. do you haverun into the samesituation?
Can you give me some advice? Thank you very very much!
more codebelow:
' lstdic is a dictionary object of the dwg pathstr.
For Each key In Lstdic
i = i + 1
Label1.Caption = "正在打印第" & i & "张图共（" & Lstdic.Count & "张)"
& vbCrLf
dylst key, True
Next
I my computerI test itin CAD 2008 and CAD 2012 ,It opensalllthe dwg in the list and nothing of the code "dy" excute.
Set Mnew = ThisDrawing.Application.Documents.Open(strPath, ReadOnly) '只读方式打开图形
"dy"is the module i write for plot a single dwg.
But if i add the code of "MsgBox "Continue?" " i t works well !and in some other computer it also works well without the code of "MsgBox "Continue?" " . I was so confused about this problem. do you haverun into the samesituation? Can you give me some advice? Thank you very very much!
' dy module
Public Sub Dy(SSt As AcadSelectionSet, Flag As Boolean, Optional Doc As
AcadDocument, Optional Mlstr1 As String = "忽略", Optional Mlstr2 As String = "忽
略")
Dim i As Integer, j As Integer
Dim Ent As AcadEntity, Mtk As AcadBlockReference
Dim GTstr As String, Plotstr As String
Dim Low As Variant, Upp As Variant
Dim Mastr As String, Mistr As String, Mip, Map
Dim ACADLayout As ACADLayout
Dim Toustr As String '显示进度条
Dim Att As AcadAttribute
Dim Mydic As Scripting.Dictionary '创建属性字典，以句柄为主键,以一个储存此Id
内属性的字典为item
Dim Filstr As String '输出的文件名
Dim Setoutlst As Variant, Setoutstr(1 To 1) As String
Dim ATTstr As String
'On Error Resume Next
'在块没有改变前，以其句柄为key建立一个有关其属性的字典（因为所删非打印层也有属性
）
'********************************************************************************
*******
Set Mydic = CreateObject("Scripting.Dictionary")
If Mlstr1 <> "忽略" Then '说明此参数没有被忽略，再进行分图或者批打到文件
For Each Mtk In SSt
ATTstr = ""
Atts = Mtk.GetAttributes
For i = 0 To UBound(Atts)
ATTstr = ATTstr & Atts(i).TagString & Chr(174) &
Atts(i).TextString & vbLf
Next
ATTstr = ATTstr & "块名" & Chr(174) & Mtk.EffectiveName &
vbLf
Mydic.Add Mtk.Handle, ATTstr
Next
End If
'********************************************************************************
*******
Doc.StartUndoMark '设置U回点
'删除块内非打印层并进行同步
'********************************************************************************
*******
For Each Ent In Doc.Blocks(Mainfrm.TextBox1.Text)
If Doc.Layers(Ent.Layer).Plottable = False Then
Ent.Delete
End If
Next
Doc.SendCommand "ATTSYNC N " & Mainfrm.TextBox1.Text & Chr(13)
Doc.Regen acActiveViewport
Doc.SetVariable "REGENMODE", 1 '防止图纸大的时候缩放出现提示
Doc.SetVariable "BACKGROUNDPLOT", 0 ' 确保AutoCAD在前台进行打印，
这样后一次打印会在前一次打印完成之后才开始,避免出现错误
Doc.Application.ZoomExtents
'********************************************************************************
*******
j = 0 '打印或者预览初始值
Doc.ActiveLayout.CopyFrom Mpig '复制打印设置
Doc.ActiveLayout.CenterPlot = True
Doc.ActiveLayout.RefreshPlotDeviceInfo
Doc.Regen acAllViewports
'传递打印设置Mylayout到DOC.layouts("Model")
'********************************************************************************
*******
'Debug.Print Doc.ActiveLayout.Name
' With Doc.ActiveLayout
' .CenterPlot = True '居中打印
' .ConfigName = Mylayout.ConfigName '打印机配置名称
' .PaperUnits = Mylayout.PaperUnits '纸张单位
' .PlotWithLineweights = Mylayout.PlotWithLineweights
' .PlotWithPlotStyles = Mylayout.PlotWithPlotStyles
' .ScaleLineweights = Mylayout.ScaleLineweights
' .StyleSheet = Mylayout.StyleSheet
' '.UseStandardScale = Mylayout.UseStandardScales
' End With
'********************************************************************************
*******
'批量打印的时候需要设置
'********************************************************************************
*******
' If Flag = True Then
' Doc.Plot.QuietErrorMode = True
' Doc.Plot.StartBatchMode SSt.Count '调出批打模式
' Setoutstr(1) = "Model"
' Setoutlst = Setoutstr
' Doc.Plot.SetLayoutsToPlot Setoutlst
' End If
'********************************************************************************
*******
Toustr = Mainfrm.Label1.Caption '记录进度标签内容
'SSt是一个图框图块的选择集，遍历此选择集，建立打印窗口
'********************************************************************************
*******
For Each Mtk In SSt
'批量打印的时候需要设置
'********************************************************************************
*******
If Flag = True Then
' Doc.Plot.QuietErrorMode = True
Doc.Plot.StartBatchMode SSt.Count '调出批打模式
Setoutstr(1) = Doc.ActiveLayout.Name
Setoutlst = Setoutstr
Doc.Plot.SetLayoutsToPlot Setoutlst
End If
'********************************************************************************
*******
'打印pdf或者分图的时候需要传递此参数进行文件名字的设置
'********************************************************************************
*******
If Mlstr1 <> "忽略" Then '说明此参数没有被忽略，再进行分图或者批打到文件
Dim Marr, Mi As Integer, Ui As Integer, Ni As Integer
Dim Mtemstr As String, Thisatt As New Scripting.Dictionary
Filstr = Mlstr1
Marr = Split(Mydic(Mtk.Handle), vbLf) '取出字符串 0开头
Ui = UBound(Marr)
For Mi = 0 To Ui - 1
Thisatt.Add Split(Marr(Mi), Chr(174))(0), Split(Marr(Mi),
Chr(174))(1)
Next
For Mi = 0 To Ui - 1
For Ni = Mi + 1 To Ui - 1
If Len(Split(Marr(Ni), Chr(174))(0)) > Len(Split(Marr
(Mi), Chr(174))(0)) Then
Mtemstr = Marr(Mi)
Marr(Mi) = Marr(Ni)
Marr(Ni) = Mtemstr
End If
Next
Next
For Mi = 0 To Ui - 1
Filstr = Replace(Filstr, Split(Marr(Mi), Chr(174))(0), Thisatt
(Split(Marr(Mi), Chr(174))(0)))
'此处会出现bug,比如前面一个Item后面一个key值一样
'则会使item变成后面一个key的item(以后再消除此bug)
Next
Thisatt.RemoveAll
Set Thisatt = Nothing '清空字典
End If
'********************************************************************************
*******
'获得处理后的块box边界，设置窗口打印范围，并设置视口使打印或者预览范围可见
'********************************************************************************
*******
Mtk.GetBoundingBox Mip, Map
'Doc.ModelSpace.AddLine Mip, Map
If Flag = False Then '是预览
Mistr = "": Mastr = ""
Mistr = Mip(0) & "," & Mip(1) & "," & Mip(2)
Mastr = Map(0) & "," & Map(1) & "," & Map(2)
Doc.SendCommand "zoom W" & Chr(13) & Mistr & Chr(13) & Mastr &
Chr(13)
Else '打印
Doc.Application.ZoomWindow Mip, Map
End If
Upp = Doc.Utility.TranslateCoordinates(Map, acWorld, acDisplayDCS,
False)
Low = Doc.Utility.TranslateCoordinates(Mip, acWorld, acDisplayDCS,
False)
ReDim Preserve Low(0 To 1)
ReDim Preserve Upp(0 To 1)
With Doc.ActiveLayout
.PlotRotation = Val(IIf(Pand(Mip, Map), 1, 0)) '设置横向竖向打印
.SetWindowToPlot Low, Upp
.PlotType = acWindow '窗口打印
End With
'********************************************************************************
*******
j = j + 1 '记录打印或者预览次数
'预览图形文件
'********************************************************************************
*******
If Flag = False Then '预览
Doc.Plot.DisplayPlotPreview acFullPreview '预览图形
If SSt.Count > j Then '说明不是最后一张
Dim kwordList As String
kwordList = "Y N"
Doc.Utility.InitializeUserInput 0, kwordList
GTstr = Doc.Utility.GetKeyword("是否预览下一张？[是(Y)/否(N)]
<Y>")
If GTstr = "" Then GTstr = "Y"
If Err.Number = "-2147352567" Then GTstr = "N"
End If
If GTstr = "N" Then Exit For
'********************************************************************************
*******
'打印图形文件
'********************************************************************************
*******
Else '打印
If Mainfrm.Frame5.Visible = True Then
Doc.Plot.PlotToDevice
ElseIf Mainfrm.Frame7.Visible = True Then
Doc.Plot.PlotToFile Mlstr2 & Filstr & ".pdf"
ShutDic Prodic
End If
Mainfrm.Label1 = Toustr & "打印进度：" & FormatPercent(Val(j /
SSt.Count), 2)
End If
DoEvents
Next
'********************************************************************************
*******
'U回图形原来的状态
'********************************************************************************
*******
Doc.EndUndoMark
Doc.SendCommand "U" & Chr(13)
'********************************************************************************
*******
End Sub
这都沉到底了，我自己来顶置一下。 楼主很强大，佩服佩服，新手看不懂，希望好好向你学习，你发的帖子我几乎都看了 254619324 发表于 2013-1-6 09:35 static/image/common/back.gif
楼主很强大，佩服佩服，新手看不懂，希望好好向你学习，你发的帖子我几乎都看了
转.net了，看自己以前写的VBA代码，除了几个好的算法，简直就是一堆垃圾。
页:
[1]