VBA 多文档打印问题。

huaxiamengqing · 发表于 2012-6-5 12:58:00

多文档转换出来问题。自己电脑上要加msgbox "是否继续", 才能正常多文档打印，别人电脑上可以正常打印，为啥？
I write a code for CAD batch plot,the main code of the pass for different dwg is
below.

copy


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 computer  I test it  in CAD 2008 and CAD 2012 ,It opens  alll  the 
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 have  run into the same  situation? 
Can you give me some advice? Thank you very very much!
more code  below:
    ' 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 computer  I test it  in CAD 2008 and CAD 2012 ,It opens  alll  the 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 have  run into the same  situation? Can you give me some advice? Thank you very very much!
' dy module

copy


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 ' 确保在前台进行打印，
这样后一次打印会在前一次打印完成之后才开始,避免出现错误
                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)] 
")
                    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