在Sset中捕获命名视图

Dim NView As AcadView
Dim Sset As AcadSelectionSet
Dim Ent As AcadEntity
Dim Pnt1 As Variant
Dim Pnt2 As Variant
Pnt1 = ThisDrawing.Utility.GetPoint(, "Pick First Point")
Pnt2 = ThisDrawing.Utility.GetPoint(, "Pick Second Point")
Set Sset = ThisDrawing.SelectionSets.Add("Sset")
Sset.Select acSelectionSetWindow, Pnt1, Pnt2
ZoomWindow Pnt1, Pnt2
For Each Ent In Sset
 If TypeOf Ent Is AcadView Then
  strName = NView.Name
  ThisDrawing.SendCommand "-view" & vbCr & "r" & vbCr & strName & vbCr
  End If
Next Ent

Sub CreateSlides()
  On Error Resume Next
  ThisDrawing.SelectionSets.Item("Sset").Delete
  
  Dim Sset As AcadSelectionSet
  Dim Ent As AcadEntity
  Dim BlkRef As AcadBlockReference
  Dim NView As AcadView
    
  Dim strName As String
  Dim VName As String
  Dim sysFileDia As Integer
      
  Dim Pnt1 As Variant
  Dim Pnt2 As Variant
   
  Pnt1 = ThisDrawing.Utility.GetPoint(, "Pick First Point")
  Pnt2 = ThisDrawing.Utility.GetPoint(, "Pick Second Point")
      
  Set Sset = ThisDrawing.SelectionSets.Add("Sset")
  Sset.Select acSelectionSetWindow, Pnt1, Pnt2
  ZoomWindow Pnt1, Pnt2
  
  sysFileDia = ThisDrawing.GetVariable("FILEDIA")
  ThisDrawing.SetVariable "FILEDIA", 0
    
  For Each Ent In Sset
   If TypeOf Ent Is AcadView Then
    VName = NView.Name
    GoTo Continue
   End If
  Next Ent
 
Continue:
  For Each Ent In Sset
   If TypeOf Ent Is AcadBlockReference Then
    Set BlkRef = Ent
    strName = BlkRef.Name
    ThisDrawing.SendCommand "-view" & vbCr & "r" & vbCr & VName & vbCr
    ThisDrawing.SendCommand "MSLIDE c:\tempslide" & strName & vbCr
   '*****MAKE SURE THE ABOVE FOLDER EXISTS*****
    End If
  Next Ent
  ThisDrawing.SetVariable "FILEDIA", sysFileDia
End Sub

Option Explicit
Sub MLides()
Dim objView As AcadView
Dim objViews As AcadViews
Dim varViewCen As Variant
Dim dblHgt As Double
Dim dblWdt As Double
Dim dblLLPt(0 To 2) As Double
Dim dblURPt(0 To 2) As Double
Dim objEnt As AcadEntity
Dim objBlkRef As AcadBlockReference
Dim objSelSet As AcadSelectionSet
Dim objSelSets As AcadSelectionSets
Dim strSldName As String
Set objViews = ThisDrawing.Views
For Each objView In objViews
  varViewCen = objView.Center
  dblHgt = objView.Height
  dblWdt = objView.Width
  dblLLPt(0) = varViewCen(0) - (dblWdt / 2)
  dblLLPt(1) = varViewCen(1) - (dblHgt / 2)
  dblLLPt(2) = 0
  dblURPt(0) = varViewCen(0) + (dblWdt / 2)
  dblURPt(1) = varViewCen(1) + (dblHgt / 2)
  dblURPt(2) = 0
  ZoomWindow dblLLPt, dblURPt
        
  Set objSelSet = ThisDrawing.SelectionSets
  For Each objSelSet In objSelSets
    If objSelSet.Name = "blkpick" Then
      ThisDrawing.SelectionSets.Item(strSet).Delete
    Exit For
    End If
  Next
  Set objSelSet = objSelSets.Add("blkpick")
  objSelSet.Select acSelectionSetWindow, dblllpnt, dblurpnt
  For Each objEnt In objSelSet
    If TypeOf objEnt Is AcadBlockReference Then
      Set objBlkRef = objEnt
      strSldName = objBlkRef.Name
      Exit For
    End If
  Next objEnt
  ThisDrawing.SendCommand "MSLIDE c:\tempslide" & strSldName & vbCr
Next objView
    
    
Next objView
End Sub

On Error Resume Next
ThisDrawing.SelectionSets.Item("blkpick").Delete 
Dim objView As AcadView
Dim objViews As AcadViews
Dim varViewCen As Variant
Dim dblHgt As Double
Dim dblWdt As Double
Dim dblLLPt(0 To 2) As Double
Dim dblURPt(0 To 2) As Double
Dim objEnt As AcadEntity
Dim objBlkRef As AcadBlockReference
Dim objSelSet As AcadSelectionSet
Dim objSelSets As AcadSelectionSets
Dim intFile As Integer
Dim strFileName As String
Dim strSldName As String
Dim sysFileDia As Integer
sysFileDia = ThisDrawing.GetVariable("FILEDIA")
ThisDrawing.SetVariable "FILEDIA", 0
Set objViews = ThisDrawing.Views
For Each objView In objViews
  varViewCen = objView.Center
  dblHgt = objView.Height
  dblWdt = objView.Width
  dblLLPt(0) = varViewCen(0) - (dblWdt / 2)
  dblLLPt(1) = varViewCen(1) - (dblHgt / 2)
  dblLLPt(2) = 0
  dblURPt(0) = varViewCen(0) + (dblWdt / 2)
  dblURPt(1) = varViewCen(1) + (dblHgt / 2)
  dblURPt(2) = 0
  ZoomWindow dblLLPt, dblURPt
        
  Set objSelSets = ThisDrawing.SelectionSets
  Set objSelSet = objSelSets.Add("blkpick")
  
  objSelSet.Select acSelectionSetWindow, dblLLPt, dblURPt
      
  For Each objEnt In objSelSet
    If TypeOf objEnt Is AcadBlockReference Then
      Set objBlkRef = objEnt
      strSldName = objBlkRef.Name
      Exit For
    End If
  Next objEnt
  ThisDrawing.SendCommand "MSLIDE c:\tempslide" & strSldName & vbCr
  strFileName = "C:\tempslide" & ThisDrawing.GetVariable("dwgname") & ".lst"
  '*****MAKE SURE THIS FOLDER EXISTS*****
      intFile = FreeFile
      Open strFileName For Append As #intFile
      Print #intFile, strSldName & ".sld"
      Close #intFile
 Next objView
  ThisDrawing.SetVariable "FILEDIA", sysFileDia
  ZoomPrevious