04/30/10

Code Page 02

 

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

 

  

 
Visual Basic Autocad
Trucos, código, etc, etc....
http://asisumss.galeon.com/
Temario.
1- Transformación por una matriz.
2- identificación de los objetos
3-Intersección de dos sólidos.
4-Extrusión de un sólido
5-Sólido por revolución
6-Sólido  a través de un camino.
7- TRASLACIÓN DE UN SÓLIDO
8-ROTACIÓN DE UN SÓLIDO


1- Transformación por una matriz.
 Dim lineObj As AcadLine
Dim startPt(0 To 2) As Double
Dim endPt(0 To 2) As Double
startPt(0) = 2: startPt(1) = 1: startPt(2) = 0
endPt(0) = 5: endPt(1) = 1: endPt(2) = 0
Set lineObj = ThisDrawing.ModelSpace.AddLine(startPt, endPt)
lineObj.Update

' Initialize the transMat variable with a transformation matrix
' that will rotate an object by 90 degrees about the point(0,0,0)
' (More examples of transformation matrices are listed below)
Dim transMat(0 To 3, 0 To 3) As Double
transMat(0, 0) = 0#: transMat(0, 1) = -1#: transMat(0, 2) = 0#: transMat(0, 3) = 0#
transMat(1, 0) = 1#: transMat(1, 1) = 0#: transMat(1, 2) = 0#: transMat(1, 3) = 0#
transMat(2, 0) = 0#: transMat(2, 1) = 0#: transMat(2, 2) = 1#: transMat(2, 3) = 0#
transMat(3, 0) = 0#: transMat(3, 1) = 0#: transMat(3, 2) = 0#: transMat(3, 3) = 1#

' Transform the line using the defined transformation matrix
MsgBox "Transform the line.", , "TransformBy Example"
lineObj.TransformBy (transMat)
ZoomAll
MsgBox "The line is transformed.", , "TransformBy Example"
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"

 

http://www.afralisp.net/vbaa/vba11.htm
Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
    (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
    lParam As Any) As Long
    
Declare Function GetForegroundWindow Lib "user32" () As Long

Public Const WM_COPYDATA = &H4A

Type COPYDATASTRUCT

dwData As Long
cbData As Long
lpData As String

End Type
Public Sub SendToCommandPrompt(strMessage As String) Dim DataStruct As COPYDATASTRUCT DataStruct.dwData = 1 DataStruct.lpData = strMessage DataStruct.cbData = Len(strMessage) + 2 AppActivate ThisDrawing.Application.Caption SendMessage GetForegroundWindow, WM_COPYDATA, 0, DataStruct End Sub

Sub xplode() SendToCommandPrompt "explode" & vbCr & "last" & vbCr & vbCr End Sub

Sub DwfExport() SendToCommandPrompt "DWFOUT" & vbCr & vbCr & "A" & vbCr & "YES" & vbCr End Sub

Sub Zoome() SendToCommandPrompt "ZOOM" & vbCr & "EXTENTS" & vbCr End Sub

Sub RunLisp() SendToCommandPrompt "(Load ""ALispFile"")" & vbCr & "ALispFile" & vbCr End Sub 

If you would like a copy of this module, just click here. Enjoy.......
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

Display Entity Length

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

Sub GetLengths()
Dim SOS As AcadSelectionSet
Dim objSS As AcadSelectionSet
Dim intCode(0) As Integer
Dim varData(0) As Variant
Dim objEnt As AcadEntity
Dim entLine As AcadLine
Dim entPoly As AcadPolyline
Dim entLWPoly As AcadLWPolyline
   For Each SOS In ThisDrawing.SelectionSets
      If SOS.Name = "MySS" Then
         ThisDrawing.SelectionSets("MySS").Delete
      Exit For
      End If
   Next
   intCode(0) = 0: varData(0) = "LINE,POLYLINE,LWPOLYLINE"
   ThisDrawing.SelectionSets.Add ("MySS")
   Set objSS = ThisDrawing.SelectionSets("MySS")
   objSS.SelectOnScreen intCode, varData
   
   
   If objSS.Count < 1 Then
      MsgBox "No lines and polylines selected!"
   Exit Sub
   End If
   
   For Each objEnt In objSS
      Select Case objEnt.ObjectName
      Case "AcDbLine"
         Set entLine = objEnt
         MsgBox "Line is " & entLine.Length & " units long."
      Case "AcDb2dPolyline"
         Set entPoly = objEnt
         MsgBox "Polyline is " & entPoly.Length & " units long."
      Case "AcDbPolyline"
         Set entLWPoly = objEnt
         MsgBox "LightWeight Polyline is " & entLWPoly.Length & " units long."
      End Select
   Next

End Sub

 

http://www.vbaexpress.com/forum/showthread.php?t=15974

 

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

         ' below code works       

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

         ' for dimension 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

 

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

 

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

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