04/30/10

Code Page 03

 

A lot of good VBA building blocks...
 
Up
Code Page 01
Code Page 02
Code Page 03
Program Updates
Introducing AutoLISP

 

  

VBA: Working with Selection Set Filters

http://usa.autodesk.com/adsk/servlet/item?siteID=123112&id=2768231&linkID=9240615

 

Visual Basic Autocad
Here’s a fairly basic routine to select some lines and store the endpoints into an array. The routine will print the endpoints to a Message Box.

http://www.cadtutor.net/forum/showthread.php?t=28949

Option Explicit

Sub Lines2Points()
Dim intCode(0) As Integer
Dim varData(0) As Variant
Dim entLine As AcadLine
Dim intLineQuantity As Integer
Dim arrLineCoords() As Variant
Dim i As Integer
Dim strMsg As String

intCode(0) = 0
varData(0) = "LINE"
intLineQuantity = (SoSSS(intCode, varData) * 2) - 1
If intLineQuantity > -1 Then
   ReDim arrLineCoords(intLineQuantity)
   For Each entLine In ThisDrawing.SelectionSets.Item("TempSSet")
      arrLineCoords(i) = entLine.StartPoint
      arrLineCoords(i + 1) = entLine.EndPoint
      i = i + 2
   Next
   For i = 0 To intLineQuantity Step 2
         strMsg = strMsg & "Start: " & PointToString(arrLineCoords(i)) _
            & "  --  End: " & PointToString(arrLineCoords(i + 1)) & vbCr
   Next
   MsgBox strMsg
  
End If
End Sub


Function SoSSS(Optional grpCode As Variant, Optional dataVal As Variant) As Integer
Dim objSSs As AcadSelectionSets
Dim objTempSS As AcadSelectionSet
Set objSSs = ThisDrawing.SelectionSets
For Each objTempSS In objSSs
   If objTempSS.Name = "TempSSet" Then
      objTempSS.Delete
      Exit For
   End If
Next
   Set objTempSS = ThisDrawing.SelectionSets.Add("TempSSet")
         'pick selection set
   If IsMissing(grpCode) Then
      objTempSS.SelectOnScreen
   Else
      objTempSS.SelectOnScreen grpCode, dataVal
   End If
   SoSSS = objTempSS.Count
End Function

Public Function PointToString(varPt As Variant) As String
Dim retVal As String, i As Long
   For i = LBound(varPt) To UBound(varPt)
       varPt(i) = Round(varPt(i), 2)
       retVal = retVal & CStr(varPt(i)) & ","
   Next
   PointToString = Left(retVal, Len(retVal) - 1)
End Function
2- Identificación de los objetos,
 Dim rayObj As AcadRay
Dim basePoint(0 To 2) As Double
Dim SecondPoint(0 To 2) As Double
basePoint(0) = 3#: basePoint(1) = 3#: basePoint(2) = 0#
SecondPoint(0) = 1#: SecondPoint(1) = 3#: SecondPoint(2) = 0#
Set rayObj = ThisDrawing.ModelSpace.AddRay(basePoint, SecondPoint)

Dim plineObj As AcadLWPolyline
Dim points(0 To 5) As Double
points(0) = 3: points(1) = 7
points(2) = 9: points(3) = 2
points(4) = 3: points(5) = 5
Set plineObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(points)
plineObj.Closed = True

Dim lineObj As AcadLine
Dim startPoint(0 To 2) As Double
Dim endPoint(0 To 2) As Double
startPoint(0) = 0: startPoint(1) = 0: startPoint(2) = 0
endPoint(0) = 2: endPoint(1) = 2: endPoint(2) = 0
Set lineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint)

' Create a Circle object in model space
Dim circObj As AcadCircle
Dim centerPt(0 To 2) As Double
Dim radius As Double
centerPt(0) = 5: centerPt(1) = 3: centerPt(2) = 0
radius = 3
Set circObj = ThisDrawing.ModelSpace.AddCircle(centerPt, radius)

Dim ellObj As AcadEllipse
Dim majAxis(0 To 2) As Double
Dim center(0 To 2) As Double
Dim radRatio As Double
center(0) = 5#: center(1) = 5#: center(2) = 0#
majAxis(0) = 10: majAxis(1) = 20#: majAxis(2) = 0#
radRatio = 0.3
Set ellObj = ThisDrawing.ModelSpace.AddEllipse(center, majAxis, radRatio)

ZoomAll
 

Dim entObjectID As Long
Dim entry As AcadEntity
For Each entry In ThisDrawing.ModelSpace
entObjectID = entry.objectID
entry.Highlight (True)
MsgBox "The ObjectID of this object is " & entObjectID, vbInformation, "ObjectID Example"
entry.Highlight (False)
Next
3- Intersección de dos sólidos.
 Dim curves(0 To 1) As AcadEntity
Dim centerPoint(0 To 2) As Double
Dim radius As Double
Dim startAngle As Double
Dim endAngle As Double
centerPoint(0) = 5#: centerPoint(1) = 3#: centerPoint(2) = 0#
radius = 2#
startAngle = 0
endAngle = 3.141592
Set curves(0) = ThisDrawing.ModelSpace.AddArc(centerPoint, radius, startAngle, endAngle)

' Define the line
ZoomExtents
Set curves(1) = ThisDrawing.ModelSpace.AddLine(curves(0).startPoint, curves(0).endPoint)

' Create the region
Dim regionObj As Variant
regionObj = ThisDrawing.ModelSpace.AddRegion(curves)
ZoomAll
ZoomExtents
MsgBox "Revolve the region to create the solid.", , "AddRevolvedSolid Example"

' Define the rotation axis
Dim axisPt(0 To 2) As Double
Dim axisDir(0 To 2) As Double
Dim angle As Double
axisPt(0) = 7: axisPt(1) = 2.5: axisPt(2) = 0
axisDir(0) = 11: axisDir(1) = 1: axisDir(2) = 3
angle = 6.28

' Create the solid
Dim solidObj As Acad3DSolid
Set solidObj = ThisDrawing.ModelSpace.AddRevolvedSolid(regionObj(0), axisPt, axisDir, angle)
ZoomAll

' Change the viewing direction of the viewport
Dim NewDirection(0 To 2) As Double
NewDirection(0) = -1: NewDirection(1) = -1: NewDirection(2) = 1
ThisDrawing.ActiveViewport.Direction = NewDirection
ThisDrawing.ActiveViewport = ThisDrawing.ActiveViewport
ZoomAll
MsgBox "Solid created.", , "AddRevolvedSolid Example"
4-Extrusión de un sólido.
 Dim boxObj As Acad3DSolid
Dim boxLength As Double, boxWidth As Double, boxHeight As Double
Dim boxCenter(0 To 2) As Double
boxCenter(0) = 5#: boxCenter(1) = 5#: boxCenter(2) = 0
boxLength = 10#: boxWidth = 7: boxHeight = 10#

' Create the box (3DSolid) object in model space
Set boxObj = ThisDrawing.ModelSpace.AddBox(boxCenter, boxLength, boxWidth, boxHeight)

' Define the cylinder
Dim cylinderObj As Acad3DSolid
Dim cylinderCenter(0 To 2) As Double
Dim cylinderRadius As Double
Dim cylinderHeight As Double
ZoomExtents
cylinderCenter(0) = 0#: cylinderCenter(1) = 0#: cylinderCenter(2) = 0#
cylinderRadius = 5#
cylinderHeight = 20#

' Create the Cylinder (3DSolid) object in model space
Set cylinderObj = ThisDrawing.ModelSpace.AddCylinder(cylinderCenter, cylinderRadius, cylinderHeight)

' Change the viewing direction of the viewport
Dim NewDirection(0 To 2) As Double
NewDirection(0) = -1: NewDirection(1) = -1: NewDirection(2) = 1
ThisDrawing.ActiveViewport.Direction = NewDirection
ThisDrawing.ActiveViewport = ThisDrawing.ActiveViewport
ZoomAll

' Perform an intersection on the two solids
MsgBox "Perform an intersection on the two solids.", vbOKOnly, "Boolean Example"
boxObj.Boolean acSubtraction, cylinderObj
ThisDrawing.Regen True

MsgBox "Intersection complete.", , "Boolean Example"
5- Sólido por revolución.
 Dim curves(0 To 1) As AcadEntity

' Define the arc
Dim centerPoint(0 To 2) As Double
Dim radius As Double
Dim startAngle As Double
Dim endAngle As Double
centerPoint(0) = 5#: centerPoint(1) = 3#: centerPoint(2) = 0#
radius = 2#
startAngle = 0
endAngle = 3.141592
Set curves(0) = ThisDrawing.ModelSpace.AddArc(centerPoint, radius, startAngle, endAngle)

' Define the line
ZoomExtents
Set curves(1) = ThisDrawing.ModelSpace.AddLine(curves(0).startPoint, curves(0).endPoint)

' Create the region
Dim regionObj As Variant
regionObj = ThisDrawing.ModelSpace.AddRegion(curves)
ZoomAll
ZoomExtents
MsgBox "Revolve the region to create the solid.", , "AddRevolvedSolid Example"

' Define the rotation axis
Dim axisPt(0 To 2) As Double
Dim axisDir(0 To 2) As Double
Dim angle As Double
axisPt(0) = 7: axisPt(1) = 2.5: axisPt(2) = 0
axisDir(0) = 11: axisDir(1) = 1: axisDir(2) = 3
angle = 6.28

' Create the solid
Dim solidObj As Acad3DSolid
Set solidObj = ThisDrawing.ModelSpace.AddRevolvedSolid(regionObj(0), axisPt, axisDir, angle)
ZoomAll

' Change the viewing direction of the viewport
Dim NewDirection(0 To 2) As Double
NewDirection(0) = -1: NewDirection(1) = -1: NewDirection(2) = 1
ThisDrawing.ActiveViewport.Direction = NewDirection
ThisDrawing.ActiveViewport = ThisDrawing.ActiveViewport
ZoomAll
MsgBox "Solid created.", , "AddRevolvedSolid Example"
6-Solido  a través de un camino.
 
Dim curves(0 To 1) As AcadEntity

' Define the arc
Dim centerPoint(0 To 2) As Double
Dim radius As Double
Dim startAngle As Double
Dim endAngle As Double
centerPoint(0) = 5#: centerPoint(1) = 3#: centerPoint(2) = 0#
radius = 2#
startAngle = 0
endAngle = 3.141592
Set curves(0) = ThisDrawing.ModelSpace.AddArc(centerPoint, radius, startAngle, endAngle)

' Define the line
Set curves(1) = ThisDrawing.ModelSpace.AddLine(curves(0).startPoint, curves(0).endPoint)

' Create the region
Dim regionObj As Variant
regionObj = ThisDrawing.ModelSpace.AddRegion(curves)

' Define the extrusion path (spline object)
Dim splineObj As AcadSpline
Dim startTan(0 To 2) As Double
Dim endTan(0 To 2) As Double
Dim fitPoints(0 To 8) As Double

' Define the Spline Object
startTan(0) = 10: startTan(1) = 10: startTan(2) = 10
endTan(0) = 10: endTan(1) = 10: endTan(2) = 10
fitPoints(0) = 0: fitPoints(1) = 10: fitPoints(2) = 10
fitPoints(0) = 10: fitPoints(1) = 10: fitPoints(2) = 10
fitPoints(0) = 15: fitPoints(1) = 10: fitPoints(2) = 10
Set splineObj = ThisDrawing.ModelSpace.AddSpline(fitPoints, startTan, endTan)

' Create the solid
Dim solidObj As Acad3DSolid
ZoomExtents
Set solidObj = ThisDrawing.ModelSpace.AddExtrudedSolidAlongPath(regionObj(0), splineObj)
ZoomAll
7-TRASLACIÓN DE UN SOLIDO
 Dim circleObj(0) As AcadCircle
Dim center(0 To 2) As Double
Dim radius As Double
center(0) = 2#: center(1) = 2#: center(2) = 0#
radius = 0.5
Set circleObj(0) = ThisDrawing.ModelSpace.AddCircle(center, radius)
ZoomAll

' Define the points that make up the move vector
Dim point1(0 To 2) As Double
Dim point2(0 To 2) As Double
point1(0) = 0: point1(1) = 0: point1(2) = 0
point2(0) = 2: point2(1) = 0: point2(2) = 0
Dim regionObj As Variant
ZoomExtents
regionObj = ThisDrawing.ModelSpace.AddRegion(circleObj)

' Define the extrusion
Dim height As Double
Dim taperAngle As Double
height = 20
taperAngle = 0

' Create the solid
Dim solidObj As Acad3DSolid
Set solidObj = ThisDrawing.ModelSpace.AddExtrudedSolid(regionObj(0), height, taperAngle)

'MsgBox "Move the circle 2 units in the X direction.", , "Move Example"

' Move the circle
ZoomExtents
solidObj.Move point1, point2

ZoomAll
8-ROTACIÓN DE UN SÓLIDO
 
Dim boxObj As Acad3DSolid
Dim length As Double, width As Double, height As Double
Dim center(0 To 2) As Double

' Define the box
center(0) = 5#: center(1) = 5#: center(2) = 0
length = 5#: width = 7: height = 10#

' Create the box (3DSolid) object in model space
Set boxObj = ThisDrawing.ModelSpace.AddBox(center, length, width, height)

' Change the viewing direction of the viewport
Dim NewDirection(0 To 2) As Double
NewDirection(0) = -1: NewDirection(1) = -1: NewDirection(2) = 1
ThisDrawing.ActiveViewport.Direction = NewDirection
ThisDrawing.ActiveViewport = ThisDrawing.ActiveViewport
ThisDrawing.Regen True

Dim rotatePt1(0 To 2) As Double
Dim rotatePt2(0 To 2) As Double
Dim rotateAngle As Double

rotatePt1(0) = -3: rotatePt1(1) = 4: rotatePt1(2) = 0
rotatePt2(0) = -3: rotatePt2(1) = -4: rotatePt2(2) = 0
rotateAngle = 30
rotateAngle = rotateAngle * 3.141592 / 180#

' Draw a line between the two axis points so that it is visible.
' This is optional. It is not required for the rotation.
Dim axisLine As AcadLine
Set axisLine = ThisDrawing.ModelSpace.AddLine(rotatePt1, rotatePt2)
axisLine.Update
MsgBox "Rotate the box 30 degrees about the axis shown.", , "Rotate3D Example"

' Rotate the box
boxObj.Rotate3D rotatePt1, rotatePt2, rotateAngle
ThisDrawing.Regen True
 

9- Creación de una nueva hoja

 Dim templateFileName As String
templateFileName = "c:\AutoCAD\template\ansi-a.dwt"
ThisDrawing.New templateFileName


10- Creación de atributos

Dim insPoint(0 To 2) As Double

Dim Blockref As AcadBlockReference
insPoint(0) = 0: insPoint(2) = 0: insPoint(1) = 0
InsItem = "C:\drawing2.dwg"
Set Blockref = ThisDrawing.ModelSpace.InsertBlock _
(insPoint, InsItem, 1, -1, 1, 0)
ThisDrawing.Application.Update

' Define the attribute definition
height = 1#
mode = acAttributeModeVerify
prompt = "New Prompt"
tag = "New Tag"
value = "New Value"
ZoomExtents
' Create the attribute definition object in model space
'Set attributeObj = ThisDrawing.Blockref.AddAttribute(height, mode, prompt, insertionPoint, tag, value)

ZoomAll

10- Creación de atributos y edición de atributos

' This example creates a block. It then adds attributes to that
' block. The block is then inserted into the drawing to create
' a block reference.

' Create the block
Dim blockObj As AcadBlock
Dim insertionPnt(0 To 2) As Double
insertionPnt(0) = 0#: insertionPnt(1) = 0#: insertionPnt(2) = 0#
Set blockObj = ThisDrawing.Blocks.Add(insertionPnt, "TESTBLOCK")

' Define the attribute definition
Dim attributeObj As AcadAttribute
Dim height As Double
Dim mode As Long
Dim prompt As String
Dim insertionPoint(0 To 2) As Double
Dim tag As String
Dim value As String
height = 1#
mode = acAttributeModeVerify
prompt = "Attribute Prompt"
insertionPoint(0) = 5#: insertionPoint(1) = 5#: insertionPoint(2) = 0
tag = "Attribute Tag"
value = "Attribute Value"

' Create the attribute definition object in model space
Set attributeObj = blockObj.AddAttribute(height, mode, prompt, insertionPoint, tag, value)

' Insert the block
Dim blockRefObj As AcadBlockReference
insertionPnt(0) = 2#: insertionPnt(1) = 2#: insertionPnt(2) = 0
Set blockRefObj = ThisDrawing.ModelSpace.InsertBlock(insertionPnt, "C:\Mis documentos\2004\WEB\modulo 2\BEAM_160.dwg", 1#, 1#, 1#, 0)
ZoomAll

' Get the attributes for the block reference
Dim varAttributes As Variant
varAttributes = blockRefObj.GetAttributes

' Move the attribute tags and values into a string to be displayed in a Msgbox
Dim strAttributes As String
Dim I As Integer
For I = LBound(varAttributes) To UBound(varAttributes)
strAttributes = strAttributes & " Tag: " & varAttributes(I).TagString & _
" Value: " & varAttributes(I).TextString & " "
Next
MsgBox "The attributes for blockReference " & blockRefObj.Name & " are: " & strAttributes, , "GetAttributes Example"

' Change the value of the attribute
' Note: There is no SetAttributes. Once you have the variant array, you have the objects.
' Changing them changes the objects in the drawing.
varAttributes(1).TextString = "NEW VALUE!"

Dim newvarAttributes As Variant
newvarAttributes = blockRefObj.GetAttributes

strAttributes = ""
For I = LBound(varAttributes) To UBound(varAttributes)
strAttributes = strAttributes & " Tag: " & varAttributes(I).TagString & _
" Value: " & varAttributes(I).TextString & " "
Next
MsgBox "The attributes for blockReference " & blockRefObj.Name & " are: " & strAttributes, , "GetAttributes Example"

  ...and about a zillion more. Email me if you have an immediate need.

 http://discussion.autodesk.com/forums/thread.jspa?threadID=332719

Public Sub MyCheckStandards()
' Check standards of DWG files only
If Not ThisDrawing.Name Like "*.dwg" Then Exit Sub

' Clear any previous errors
Err.Clear

' Declare variables
Dim oDict As AcadDictionary
Dim oXRec As AcadXRecord
Dim FileName As Variant

Dim oLayer As AcadLayer
Dim oDimStyle As AcadDimStyle
Dim oLinetype As AcadLineType
Dim oTextStyle As AcadTextStyle

Dim oDbxDoc As New AxDbDocument
Dim oDbxLayer As AcadLayer
Dim oDbxDimStyle As AcadDimStyle
Dim oDbxLinetype As AcadLineType
Dim oDbxTextStyle As AcadTextStyle

Dim oEntity As AcadEntity
Dim oLayout As AcadLayout

' Attempt to retrieve the CAD Standards dictionary
On Error GoTo NO_DICTIONARY
Set oDict = ThisDrawing.Dictionaries.Item("AcStStandard")
If oDict.Count < 1 Then GoTo NO_DICTIONARY

' Iterate through the dictionary
On Error GoTo UNKNOWN_ERROR
For Each oXRec In oDict
' Get the name of each .dws file in the dictionary
oXRec.GetXRecordData 1, FileName
' Attempt to open the .dws file
oDbxDoc.Open FileName(0)

' Iterate through the Text Styles collection in the DBX document
For Each oDbxTextStyle In oDbxDoc.TextStyles
' Get a current reference to each TextStyle
On Error Resume Next
Set oTextStyle = ThisDrawing.TextStyles.Item(oDbxTextStyle.Name)
' If the TextStyle does not exist in the current drawing
If Err.Description = "Key not found" Then
Dim oTextStyles(0) As AcadTextStyle
Set oTextStyles(0) = oDbxTextStyle
' Copy the TextStyle from the DBX document
oDbxDoc.CopyObjects oTextStyles, ThisDrawing.TextStyles
' If the TextStyle does exist in the current drawing
Else
' Copy all of the properties from the DBX TextStyle
' to the same TextStyle in the current drawing
oTextStyle.BigFontFile = oDbxTextStyle.BigFontFile
oTextStyle.fontFile = oDbxTextStyle.fontFile
oTextStyle.Height = oDbxTextStyle.Height
oTextStyle.ObliqueAngle = oDbxTextStyle.ObliqueAngle
oTextStyle.TextGenerationFlag = oDbxTextStyle.TextGenerationFlag
oTextStyle.Width = oDbxTextStyle.Width
End If
Next oDbxTextStyle

' Iterate through the LineTypes collection in the DBX document
For Each oDbxLinetype In oDbxDoc.Linetypes
' Get a current reference to each LineType
On Error Resume Next
Set oLinetype = ThisDrawing.Linetypes.Item(oDbxLinetype.Name)
' If the LineType does not exist in the current drawing
If Err.Description = "Key not found" Then
Dim oLineTypes(0) As AcadLineType
Set oLineTypes(0) = oDbxLinetype
' Copy the LineType from the DBX document
oDbxDoc.CopyObjects oLineTypes, ThisDrawing.Linetypes
End If
' Linetypes have no properties that can be copied from
' a DBX document. There is no processing that can be done
' if the linetype already exists.

' If the user redefines a 'standard' linetype, a standards
' violation will pop up
Next oDbxLinetype

' Iterate through the Layers collection in the DBX document
For Each oDbxLayer In oDbxDoc.Layers
' Get a current reference to each layer
On Error Resume Next
Set oLayer = ThisDrawing.Layers.Item(oDbxLayer.Name)
' If the layer does not exist in the current drawing
If Err.Description = "Key not found" Then
Dim oLayers(0) As AcadLayer
Set oLayers(0) = oDbxLayer
' Copy the layer from the DBX document
oDbxDoc.CopyObjects oLayers, ThisDrawing.Layers
' If the layer does exist in the current drawing
Else
' Copy all of the properties from the DBX layer
' to the same layer in the current drawing
oLayer.Freeze = oDbxLayer.Freeze
oLayer.LayerOn = oDbxLayer.LayerOn
oLayer.Linetype = oDbxLayer.Linetype
oLayer.Lineweight = oDbxLayer.Lineweight
oLayer.Lock = oDbxLayer.Lock
oLayer.PlotStyleName = oDbxLayer.PlotStyleName
oLayer.Plottable = oDbxLayer.Plottable
oLayer.TrueColor = oDbxLayer.TrueColor
oLayer.ViewportDefault = oDbxLayer.ViewportDefault
End If
Next oDbxLayer

' Iterate through the DimStyles collection in the DBX document
For Each oDbxDimStyle In oDbxDoc.DimStyles
' Get a current reference to each DimStyle
On Error Resume Next
Set oDimStyle = ThisDrawing.DimStyles.Item(oDbxDimStyle.Name)
' If the DimStyle does not exist in the current drawing
If Err.Description = "Key not found" Then
Dim oDimStyles(0) As AcadDimStyle
Set oDimStyles(0) = oDbxDimStyle
' Copy the DimStyle from the DBX document
oDbxDoc.CopyObjects oDimStyles, ThisDrawing.DimStyles
' If the DimStyle does exist in the current drawing
End If
' As is the case with Linetypes, DimStyles have no properties
' that can be copied from a DBX document. There is no
' processing that can be done if the dimstyle already exists.

' If the user redefines a 'standard' dimstyle, a standards
' violation will pop up
Next oDbxDimStyle
Next oXRec

' Iterate through all objects in model space
For Each oEntity In ThisDrawing.ModelSpace
' Set all entities to ByLayer color, linetype and lineweight
With oEntity
.color = acByLayer
.Linetype = "ByLayer"
.Lineweight = acLnWtByLayer
.Update
End With
Next oEntity

' Iterate through all layouts in the drawing
For Each oLayout In ThisDrawing.Layouts
' Iterate through all objects in each layout
For Each oEntity In oLayout.Block
' Set all entities to ByLayer color, linetype and lineweight
With oEntity
.color = acByLayer
.Linetype = "ByLayer"
.Lineweight = acLnWtByLayer
.Update
End With
Next oEntity
Next oLayout

Exit Sub

UNKNOWN_ERROR:
MsgBox Err.Description, vbCritical, "CAD Standards Control"
Exit Sub

NO_DICTIONARY:
ThisDrawing.SendCommand "._Standards "
CheckStandards
Exit Sub

End Sub
http://www.cadtutor.net/forum/showthread.php?t=19953

Sub SaveLayers()
Dim sset As AcadSelectionSet
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant
Dim groupCode As Variant
Dim dataCode As Variant
Dim blockObj As AcadBlock
Dim insertionPnt(0 To 2) As Double

On Error GoTo gestErr

'Create the selectionset "JeuSel1"
Set sset = ThisDrawing.SelectionSets.Add("JeuSel")

'Sélection of marking layer and then boundary layer
gpCode(0) = 8 'layer
groupCode = gpCode
dataValue(0) = "M_01" 'layer name
dataCode = dataValue
sset.Select acSelectionSetAll, , , groupCode, dataCode

gpCode(0) = 8 'layer
groupCode = gpCode
dataValue(0) = "01" 'layer name
dataCode = dataValue
sset.Select acSelectionSetAll, , , groupCode, dataCode
sset.Highlight (True)

'Create block
insertionPnt(0) = 0#: insertionPnt(1) = 0#: insertionPnt(2) = 0#
Set blockObj = ThisDrawing.Blocks.Add(insertionPnt, "Part_01")

'Copy each object selected in the block
For Each acadObj In sset
'----->Here is my problem ! How to add the selected object in the block "Part_01" ?
Next acadObj

Exit Sub

gestErr:
If Err.Number = -2145320851 Then
    ThisDrawing.SelectionSets.Item("JeuSel").Delete
    Set sset = ThisDrawing.SelectionSets.Add("JeuSel")
    Resume Next
Else
    Debug.Print Err.Number
    Debug.Print Err.Description
    Exit Sub
End If
End Sub

 

 

gpCode(0) = 8 'layer
groupCode = gpCode
dataValue(0) = "01,M_01" 'layer name
dataCode = dataValue
sset.Select acSelectionSetAll, , , groupCode, dataCode

sset.Highlight (True)

'Create block
insertionPnt(0) = 0#: insertionPnt(1) = 0#: insertionPnt(2) = 0#
Set blockObj = ThisDrawing.Blocks.Add(insertionPnt, "Part_01")

ReDim Obj(sset.count - 1) As AcadObject
Dim i As Integer
'Copy each object selected in the block
For i = 0 To sset.count - 1
Set Obj(i) = sset(i)
Next i

ThisDrawing.CopyObjects Obj, blockObj
Exit Sub
http://www.cadtutor.net/forum/showthread.php?t=8846

This will return the handle for the last entity of type block ref

Function lastenthandle() As String
    Dim entity As AcadObject
    Dim count As Variant
    ' set count to all items in modelspace collection
    count = ThisDrawing.ModelSpace.count
    Set entity = ThisDrawing.ModelSpace.Item(count - 1)
    ' check if entity is a block if not count down until it is
    While count > 0
    If StrComp(entity.EntityName, "AcDbBlockReference", 1) = 0 Then
        If entity.HasAttributes Then
            lastenthandle = entity.handle
            Exit Function
        End If
    End If
        count = count - 1
        Set entity = ThisDrawing.ModelSpace.Item(count)
    Wend
End Function

 

 

Sub FixMyDXF()

    Dim mPath As String, mFileName As String, mNewLyr As AcadLayer

    Dim mDoc As AcadDocument, sset As AcadSelectionSet, mFxdNm As String

    mPath = "D:\VBATEST\" ' dxf files here

    mFileName = "*.dxf"

    mFileName = Dir(mPath & mFileName)

    While mFileName <> ""

        Set mDoc = Application.Documents.Open(mPath & mFileName)

        DeleteLayouts mDoc

         ' bellow code works

        

        

         ' I added New Text Style and then sets a new style

         ' for dimention text

        

        Dim newTextStyle As AcadTextStyle

        

        Set newTextStyle = ThisDrawing.TextStyles.Add("ARIAL")

        ThisDrawing.ActiveTextStyle = newTextStyle

        

         ' End add text

        

         ' I added Set Font Type

        

        Dim textStyle1 As AcadTextStyle

         'Dim currFontFile As String

        Dim newFontFile As String

        

        Set textStyle1 = ThisDrawing.ActiveTextStyle

        

         ' Change the value for FontFile

        newFontFile = "C:\Program Files\AutoCAD 2005\Fonts\arial.ttf"

        textStyle1.fontFile = newFontFile

        

         ' End Set Font

        

         'Set mNewLyr = mDoc.Layers.Add("LayerName")

         'set layer attributes

         'mNewLyr.color = acRed

         'mNewLyr.Linetype = "CONTINUOUS"

         ' added dim style change

         ' ad_AddDimStyle

         ' This routine demonstrates how to add a new dimension style and define

         ' its various properties.

         ' It was developed for AutoCAD 2000 and above.

         ' Demand load: -vbarun;ad_AddDimStyle.dvb!ad_AddDimStyle;

         ' version 1.00

         '

         ' Copyright?2000-2006 ActiveDwg.com

         '

         ' This routine is provided for demonstration purposes only and must

         ' not be used for critical applications without your verification

         ' that this routine will perform as you intended.

         ' This routine may be freely utilized for your own personal use so long

         ' as the entire contents of this header remain intact.

         ' This routine is provided "as-is" and no declaration, written or implied,

         ' is made as to its reliability for any particular task. Any use of this

         ' routine is solely at your own risk.

         '

        Dim adDimStyle As AcadDimStyle

         ' Start Med

         'Set adDimStyle = ThisDrawing.DimStyles.Add("adDimStyle")

        Set adDimStyle = ThisDrawing.DimStyles.Add("Med 20-48 Inch")

        ThisDrawing.ActiveDimStyle = adDimStyle

        With ThisDrawing

             'The first group defines overall and linear scale factors

            .SetVariable "DimScale", 1 'Overall Scale Factor. Determined by 12/Scale Factor.

             ' 96 is for 1/8"=1'-0" so that 12/.125=96.

            .SetVariable "DimLFac", 1 'Linear Scale Factor. '1'=1:1, '2'=2:1,'.5'=1:2, etc

             'This group defines the typical dimension properties

            .SetVariable "DimADec", 2 'Precision places for angular dimensions. May be 0-8.

            .SetVariable "DimAso", 1 'Dimensional associativity. 0=off, 1=on. 0 'explodes' dimensions.

             ' DimAso is stored by drawing, not by style.

            .SetVariable "DimASz", 1.25 'Arrowhead size for dimensions and leaders.

            .SetVariable "DimAtFit", 3 'Defines placement of arrowheads and text if insufficient space for both.

             ' 0=both outside, 1=force arrows outside, 2=force text outside, 3=best fit.

            .SetVariable "DimAUnit", 0 'Units for angular dimensions.

             ' 0=decimal degrees, 1=degrees/minutes/seconds, 2=gradians, 3=radians

            .SetVariable "DimAZin", 3 'Zero suppression for angular dimensions.

             ' 0=display all leading and trailing zeros, 1=suppress leading zeros,

             ' 2=suppress trailing zeros, 3=suppress leading and trailing zeros

            .SetVariable "DimBlk", "" 'Defines typical arrow type. ' "" '=Closed-Filled, '.'=none.

             ' Others are: '_ArchTick', '_BoxBlank', '_BoxFilled', '_Closed', '_ClosedBlank',

             ' '_DatumBlank', '_DatumFilled', '_Dot', '_DotSmall', '_DotBlank', '_Integral',

             ' '_None', '_Oblique', '_Origin', '_Origin2', '_Open', '_Open90', '_Open30', '_Small'.

            .SetVariable "DimBlk1", "" 'Defines 1st arrow type if 'DimSAH is '1'. See 'DimBlk' for type list.

            .SetVariable "DimBlk2", "" 'Defines 1st arrow type if 'DimSAH is '2'. See 'DimBlk' for type list.

            .SetVariable "DimCen", 0.5 'Defines circle and arc center marks and lines. Show as mark size.

             ' 0=No marks, <0=centerlines are drawn, >0=centermarks are drawn.

            .SetVariable "DimClrD", 160 'Color for dimlines, arrows, and leaders. 0=ByBlock, 256 = ByLayer, 1-255=color.

            .SetVariable "DimClrE", 1 'Color for dimension extension lines. 0=ByBlock, 256 = ByLayer, 1-255=color.

            .SetVariable "DimClrT", 7 'Color for dimension text. 0=ByBlock, 256 = ByLayer, 1-255=color.

            .SetVariable "DimDec", 2 'Decimal precision for normal dimensions.

            .SetVariable "DimDLE", 0 'For oblique marks in place of arrows: Distance dimlines extend beyond extension lines.

            .SetVariable "DimDLI", 0.1 'Offset distance between dimension line rows.

            .SetVariable "DimDSep", "." 'Decimal separator for decimal format dimensions.

            .SetVariable "DimExe", 1.25 'Extension distance of extension lines beyond dimension lines.

            .SetVariable "DimExO", 1.25 'Offset distance from dimension origin to extension line.

            .SetVariable "DimFrac", 0 'Fraction format in fractional dimensions. 0=Horizontal, 1=diagonal, 2=not stacked.

            .SetVariable "DimGap", 1.25 'Gap between dimlines and dimension text.

            .SetVariable "DimJust", 0 'Dimension text horizontal position. 0=Centered between extension lines,

             ' 1=at 1st extension line, 2=at 2nd extension line, 3=above and at 1st extension line,

             ' 4=above and at 2nd extension line.

            .SetVariable "DimLdrBlk", "" 'Defines leader arrow type. See DimBlk for type list.

            .SetVariable "DimLim", 0 'Defines whether dimension limits are generated. 1=On, 0=Off.

            .SetVariable "DimLUnit", 3 'Defines dimension unit types(except angular). 1=Scientific, 2=Decimal, 3=Engineering,

             ' 4=Architectural, 5=Fractional, 6=Windows default

            .SetVariable "DimLwd", acLnWtByLayer 'Defines dimension line lineweight. 'ByBlock'=acLnWtByBlock, 'ByLayer'=acLnWtByLayer,

             ' also may be specified as millimeters WAS -2.

            .SetVariable "DimLwe", acLnWtByLayer 'Defines extension line lineweight. 'ByBlock'=acLnWtByBlock, 'ByLayer'=acLnWtByLayer,

             ' also may be specified as millimeters WAS -2.

            .SetVariable "DimPost", "" 'Defines dimension text prefix or suffix. Use brackets to specify prefix or suffix.

             ' '<>ft' will create a suffix of 'ft', while 'ft<>' will create a prefix of 'ft'.

            .SetVariable "DimRnd", 0 'Defines precision for rounding dimensions. '.5' will round to nearest half.

            .SetVariable "DimSAh", 0 'Defines arrowhead block display. 0=set per 'DIMBLK'(see 'DimLdrBlk' for list'),

             ' 1=sets arrowhead 1('DIMBLK1') independently of arrowhead 2('DIMBLK2')(see 'DimLdrBlk' for list').

            .SetVariable "DimSD1", 0 'Defines display of 1st dimline and arrowhead. 0=Display, 1=Do not display.

            .SetVariable "DimSD2", 0 'Defines display of 2nd dimline and arrowhead. 0=Display, 1=Do not display.

            .SetVariable "DimSE1", 0 'Defines display of 1st extension line. 0=Display, 1=Do not display.

            .SetVariable "DimSE2", 0 'Defines display of 2nd extension line. 0=Display, 1=Do not display.

            .SetVariable "DimSho", 1 'Defines dynamic update of dimtext as defining points are dragged. 0=Update, 1=Do not update.

             ' DimSho is stored by drawing, not by style.

            .SetVariable "DimSOXD", 0 'Defines whether dimlines are drawn outside of extension lines.

             ' 0=Drawn outside, 1=Not drawn outside.

            .SetVariable "DimTAD", 0 'Dimension text vertical position. 0=Centered between extension lines,

             ' 1=above the dimension line, 2=dimensions placed on side of dimline away from defining points,

             ' 3=placed according to Japanese Industrial Standards.

            .SetVariable "DimTIH", 1 'Defines position of dimtext between extension lines. 0=Align with dimline, 1=Always horizontal.

            .SetVariable "DimTIX", 0 'Defines how text is placed between extension lines. 0=Between if fits, 1=Always between.

            .SetVariable "DimTOFL", 0 'Defines how dimline is placed between extension lines. 0=In or out with arrowheads, 1=Always between.

            .SetVariable "DimTOH", 1 'Defines position of dimtext outside extension lines. 0=Align with dimline, 1=Always horizontal.

            .SetVariable "DimTSz", 0 'Defines size of Oblique strokes in place of arrowheads. 0=Draws arrowheads, >0=Oblique size.

            .SetVariable "DimTVP", 0

            .SetVariable "DimTxSty", "ARIAL"

            .SetVariable "DimTxt", 1.25

            .SetVariable "DimUPT", 1

            .SetVariable "DimZIn", 12

             'This group defines the Alternate dimension properties

            .SetVariable "DimAlt", 1

            .SetVariable "DimAltD", 2

            .SetVariable "DimAltF", 1

            .SetVariable "DimAltRnd", 0

            .SetVariable "DimAltTD", 2

            .SetVariable "DimAltTZ", 0

            .SetVariable "DimAltU", 2

            .SetVariable "DimAltZ", 0

            .SetVariable "DimAPost", """"

             'This group defines the Tolerance dimension properties

            .SetVariable "DimTol", 0

            .SetVariable "DimTDec", 2

            .SetVariable "DimTFac", 1

            .SetVariable "DimTM", 0

            .SetVariable "DimTolJ", 1

            .SetVariable "DimTP", 0

            .SetVariable "DimTZin", 0

        End With

        adDimStyle.CopyFrom ThisDrawing

         'End Add Med Dim Styles

        

        Set sset = mDoc.SelectionSets.Add("TEST")

         'ZoomExtents

         'ZoomAll

        mFxdNm = Replace(mPath & mFileName, ".DXF", "Rev")

        mDoc.Export mFxdNm, "DXF", sset

        mDoc.Close False

        ZoomExtents

         'copy new file over exist file

        FileCopy mFxdNm & ".DXF", mPath & mFileName

         'delete the new file

        Kill mFxdNm & ".DXF"

        Set mDoc = Nothing

        Set mNewLyr = Nothing

        mFileName = Dir

    Wend

End Sub

 

 'Below contributed by lucas :D

Sub DeleteLayouts(iDoc As AcadDocument)

    Dim adLayout As AcadLayout

    On Error Resume Next

    If iDoc.ActiveSpace = acPaperSpace Then _

    iDoc.ActiveSpace = acModelSpace

    ZoomExtents

    For Each adLayout In iDoc.Layouts

        adLayout.Delete

         'ZoomAll

    Next adLayout

    Err.Clear

    On Error Goto 0

End Sub

 '*************************************************************************

 ' should change all objects to a single layer by Tommy VBAX

 

Sub ChnageAllToLyer()

    Dim ssAll As AcadSelectionSet, mEntity As AcadEntity

    Set ssAll = ThisDrawing.SelectionSets.Add("AllEntities")

    ssAll.Select acSelectionSetAll

    For Each mEntity In ssAll

        mEntity.Layer = "0"

    Next

    ssAll.Clear

    ssAll.Delete

    Set ssAll = Nothing

    ThisDrawing.Regen acActiveViewport

End Sub

 

 '*************************************************************************

 

 
 
 
 
 
 

Home | Code Page 01 | Code Page 02 | Code Page 03 | Program Updates | Introducing AutoLISP

 

© MMIX PellaCAD, Inc. All rights reserved. all MSNBC Web Components used with permission.

Site Established: 01/01/97 by AMOS Systems Development Company Last Updated: 12/06/09