TheSwamp
Code Red => VB(A) => Topic started by: ChuckHardin on December 03, 2008, 01:52:20 PM
-
Ok I know I should remember this one and NO i don't
have the CADencoding archive (wish I did) but...
How do you select all the entities that are visible in
the mspace viewport? This selects every block with
the REC_NUM attribute in the dwg. What do I need
to do?
Public Sub TestThis()
Dim intcnt As Integer
Dim objSelSet As AcadSelectionSet
Dim varData(0 To 1) As Variant
Dim intType(0 To 1) As Integer
Dim objEnt As AcadEntity
Dim strRecNumbers As String
Dim varRecNum As Variant
Dim objBlkRef As AcadBlockReference
Dim varPnt As Variant
ThisDrawing.MSpace = True
intType(0) = 0: varData(0) = "INSERT"
intType(1) = 2: varData(1) = BlockAttributeFilter("REC_NUM")
Set objSelSet = ThisDrawing.PickfirstSelectionSet
objSelSet.Select Mode:=acSelectionSetAll, FilterType:=intType, FilterData:=varData
''Try this if all else fails
' dblLL(0) = varLowerLeft(0) - 100
' dblLL(1) = varLowerLeft(1) - 100
'
' dblUR(0) = varUpperRight(0) + 100
' dblUR(1) = varUpperRight(1) + 100
'
' objSelSet.Select acSelectionSetWindow, dblLL, dblUR, intType, varData
For Each objEnt In objSelSet
If TypeOf objEnt Is AcadBlockReference Then
Set objBlkRef = objEnt
strRecNumbers = IIf(strRecNumbers = "", AttString(objBlkRef, "REC_NUM"), strRecNumbers & "|" & AttString(objBlkRef, "REC_NUM"))
End If
Next
varRecNum = Split(strRecNumbers, "|")
ThisDrawing.MSpace = False
'Now create the pole list with framing and locations
'Do a SQL for each Rec_Num|Pri_Unit|Location
For intcnt = LBound(varRecNum) To UBound(varRecNum)
Debug.Print varRecNum(intcnt)
Next
End Sub
Public Function BlockAttributeFilter(strAttTag As String) As String
Dim objBlk As AcadBlock
Dim strFilter As String
Dim objBlkEnt As AcadEntity
Dim objAtt As AcadAttribute
For Each objBlk In ThisDrawing.Blocks
If Left(objBlk.Name, 1) <> "*" Then
For Each objBlkEnt In objBlk
If TypeOf objBlkEnt Is AcadAttribute Then
Set objAtt = objBlkEnt
If objAtt.TagString = strAttTag Then
strFilter = IIf(strFilter = "", objBlk.Name, strFilter & "," & objBlk.Name)
End If
End If
Next objBlkEnt
End If
Next objBlk
BlockAttributeFilter = strFilter
End Function
-
I found a solution.
The code was found on the Autodesk forum.
Public Sub TestThis()
Dim intcnt As Integer
Dim objSelSet As AcadSelectionSet
Dim varData(0 To 1) As Variant
Dim intType(0 To 1) As Integer
Dim objEnt As AcadEntity
Dim strRecNumbers As String
Dim varRecNum As Variant
Dim objBlkRef As AcadBlockReference
Dim varPnt As Variant
Dim dblLL(0 To 2) As Double
Dim dblUR(0 To 2) As Double
Dim varLowerLeft As Variant
Dim varUpperRight As Variant
ThisDrawing.MSpace = True
intType(0) = 0: varData(0) = "INSERT"
intType(1) = 2: varData(1) = BlockAttributeFilter("REC_NUM")
If MSpaceWindow(varLowerLeft, varUpperRight) = True Then
dblLL(0) = varLowerLeft(0)
dblLL(1) = varLowerLeft(1)
dblUR(0) = varUpperRight(0)
dblUR(1) = varUpperRight(1)
'Select the blocks
Set objSelSet = ThisDrawing.PickfirstSelectionSet
objSelSet.Select acSelectionSetWindow, dblLL, dblUR, intType, varData
'Loop through them for the Rec_Num
For Each objEnt In objSelSet
If TypeOf objEnt Is AcadBlockReference Then
Set objBlkRef = objEnt
strRecNumbers = IIf(strRecNumbers = "", AttString(objBlkRef, "REC_NUM"), strRecNumbers & "|" & AttString(objBlkRef, "REC_NUM"))
End If
Next
'Split for easy stepping
varRecNum = Split(strRecNumbers, "|")
'Now create the pole list with framing and locations
'Do a SQL for each Rec_Num|Pri_Unit|Location
For intcnt = LBound(varRecNum) To UBound(varRecNum)
Debug.Print varRecNum(intcnt)
Next
End If
ThisDrawing.MSpace = False
End Sub
'//*****************************//'
'//****Code from Autodesk Forum*****//'
'//*****************************//'
Public Function MSpaceWindow(varLowerLeft As Variant, varUpperRight As Variant) As Boolean
Dim varCenter As Variant
Dim dblHeight As Double
Dim dblWidth As Double
Dim varMinp As Variant
Dim varMaxp As Variant
Dim dblVPHeight As Double
Dim dblVPWidth As Double
On Error GoTo Err_Control
ThisDrawing.MSpace = True
ThisDrawing.SetVariable "CVPORT", 2
'view center in WCS
varCenter = ThisDrawing.GetVariable("VIEWCTR")
'convert in to DCS
varCenter = ThisDrawing.Utility.TranslateCoordinates(varCenter, acWorld, acDisplayDCS, 0)
'height of the viewport in DCS
dblHeight = ThisDrawing.GetVariable("VIEWSIZE")
varMinp = varCenter: varMaxp = varCenter
'calculate the width of the viewport in DCS
dblVPHeight = ThisDrawing.ActivePViewport.Height
dblVPWidth = ThisDrawing.ActivePViewport.Width
dblWidth = dblVPWidth * dblHeight / dblVPHeight
'calculate bounding view boundary in DCS
varMinp(0) = varCenter(0) - dblWidth / 2
varMinp(1) = varCenter(1) - dblHeight / 2
varMaxp(0) = varCenter(0) + dblWidth / 2
varMaxp(1) = varCenter(1) + dblHeight / 2
varMinp = ThisDrawing.Utility.TranslateCoordinates(varMinp, acDisplayDCS, acWorld, 0)
varMaxp = ThisDrawing.Utility.TranslateCoordinates(varMaxp, acDisplayDCS, acWorld, 0)
'Set the Returns
varLowerLeft = varMinp
varUpperRight = varMaxp
MSpaceWindow = True
Exit_Here:
Exit Function
Err_Control:
Select Case Err.Number
Case Else
MsgBox Err.Description
MSpaceWindow = False
Resume Exit_Here
End Select
End Function