PDA

View Full Version : Help with VBA & AutoCAD- placing an arc through existing lines



RMS
07-27-2007, 07:53 AM
Hello, I am new to this forum but I was pleased to see all the AutoCAD experts here!! I need some help with somthing I can not do on my own.

I have parts with small line segments that form an arc, I need to offset these inwards .12" then erase the old line segments. I have a ton of these to do and I need a fast way to do it so its a perfect project for VBA.

What I presently do now is to put a 3 point arc through the line segments, then offset this arc to .12" then I erase all the line segments. There is more to it but this is where I would like to start. The parts are like half donuts and I offset both sides on each part, then I trim the new arc at the ends.

Thanks for any help with this.

Rob

fixo
07-27-2007, 01:07 PM
Hi,
welcome on board

This code will draw an arc inside your
lines chain at distance 0.12 from these lines
Is there what you want?
Let me know how it will works

~'J'~



Option Explicit

Public Function Get_Distance(fPoint As Variant, sPoint As Variant) As Double
Dim x1 As Double, x2 As Double
Dim y1 As Double, y2 As Double
Dim z1 As Double, z2 As Double
Dim cDist As Double
x1 = fPoint(0): y1 = fPoint(1): z1 = fPoint(2)
x2 = sPoint(0): y2 = sPoint(1): z2 = sPoint(2)
cDist = Sqr(((x2 - x1) ^ 2) + ((y2 - y1) ^ 2) + ((z2 - z1) ^ 2))
Get_Distance = cDist
End Function


Public Function Get_MidPoint(fPoint As Variant, sPoint As Variant) As Variant
Dim mpoint(2) As Double
mpoint(0) = (CDbl(sPoint(0)) + CDbl(fPoint(0))) / 2
mpoint(1) = (CDbl(sPoint(1)) + CDbl(fPoint(1))) / 2
mpoint(2) = (CDbl(sPoint(2)) + CDbl(fPoint(2))) / 2
Get_MidPoint = mpoint
End Function


Sub OffsetLinesToArc()
Dim pt1 As Variant
Dim pt2 As Variant
Dim pt3 As Variant
Dim pt4 As Variant
Dim pt5 As Variant
Dim pt6 As Variant
Dim pt7 As Variant
Dim pt8 As Variant
Dim ang1 As Double
Dim ang2 As Double
Dim stAng As Double
Dim endAng As Double
Dim oEnt As AcadEntity
Dim oLine As AcadLine
Dim osm As Integer, varpt As Variant
Dim Pi As Double
Pi = Atn(1#) * 4
osm = ThisDrawing.GetVariable("OSMODE")
ThisDrawing.SetVariable "OSMODE", 1
MsgBox "First select line then" & vbCr & _
"Pick points in" & vbCr & _
"clockwise order only!"

On Error GoTo Err_Control
With ThisDrawing.Utility

.GetEntity oEnt, varpt, vbCr & "Select any of lines from the chain"
If TypeOf oEnt Is AcadLine Then
Set oLine = oEnt
Else
Exit Sub
End If

pt1 = .GetPoint(, vbCr & "Specify the starting point of an arc in clockwise order")
pt2 = .GetPoint(pt1, vbCr & "Specify the point near to middle of the chain of lines")
pt3 = .GetPoint(pt2, vbCr & "Specify the ending point")
ang1 = .AngleFromXAxis(pt1, pt2) + (Pi / 2)
ang2 = .AngleFromXAxis(pt2, pt3) + (Pi / 2)
pt4 = Get_MidPoint(pt1, pt2)
pt5 = Get_MidPoint(pt2, pt3)
pt6 = .PolarPoint(pt4, ang1, 1#)
pt7 = .PolarPoint(pt5, ang2, 1#)
End With
ThisDrawing.SetVariable "OSMODE", 0
Dim oXline1 As AcadXline, oXline2 As AcadXline
Set oXline1 = ThisDrawing.ModelSpace.AddXline(pt4, pt6)
Set oXline2 = ThisDrawing.ModelSpace.AddXline(pt5, pt7)
Dim intPt As Variant
intPt = oXline1.IntersectWith(oXline2, acExtendNone)
Dim oArc As AcadArc
Dim dblRad As Double
dblRad = Get_Distance(intPt, pt1) - 0.12
With ThisDrawing.Utility
stAng = .AngleFromXAxis(intPt, pt3)
endAng = .AngleFromXAxis(intPt, pt1)
End With
Set oArc = ThisDrawing.ModelSpace.AddArc(intPt, dblRad, stAng, endAng)
oArc.Layer = oLine.Layer
oArc.Linetype = oLine.Linetype
oArc.LinetypeScale = oLine.LinetypeScale
oArc.Lineweight = oLine.Lineweight
oArc.TrueColor = oLine.TrueColor
oArc.Update
Exit_Here:
oXline1.Delete
oXline2.Delete
ThisDrawing.SetVariable "OSMODE", osm
Exit Sub
Err_Control:
MsgBox Err.Description
Resume Exit_Here
End Sub

fixo
07-27-2007, 01:59 PM
This one will offset just lines
Tested on 2007 only



Option Explicit
Public Sub OffsetLines()
Dim oSset As AcadSelectionSet
Dim oEnt
Dim oLine As AcadLine
Dim fcode(0) As Integer
Dim fData(0) As Variant
Dim dxfcode, dxfdata
Dim i As Integer
Dim setName As String
' build filter
fcode(0) = 0 ' entity code
fData(0) = "LINE" ' entity data type
dxfcode = fcode
dxfdata = fData
setName = "$Lines$" ' selection set name
On Error GoTo Err_Control
'Make sure named selection set does not exist
' if this does exist then delete it
For i = 0 To ThisDrawing.SelectionSets.Count - 1
If ThisDrawing.SelectionSets.Item(i).Name = setName Then
ThisDrawing.SelectionSets.Item(i).Delete
Exit For
End If
Next i
' create new selection set
Set oSset = ThisDrawing.SelectionSets.Add(setName)
' select all lines on screen by window or by picking one by one
oSset.SelectOnScreen dxfcode, dxfdata
'//MsgBox "Selected " & oSset.Count & " lines" ' debug only
Dim offdist As String
offdist = CStr(InputBox(vbCr & "Enter offset distance" & _
"Press Enter to default", "Offset Distance", "0.12"))
Dim offPt As Variant
offPt = ThisDrawing.Utility.GetPoint(, vbCr & "Pick point on side to offset")
Dim strPt As String
strPt = Replace(CStr(offPt(0)), ",", ".") & "," & Replace(CStr(offPt(1)), ",", ".")
'Process each line
Dim lnstPt As String
For Each oEnt In oSset
Set oLine = oEnt
lnstPt = Replace(CStr(oLine.StartPoint(0)), ",", ".") & "," & Replace(CStr(oLine.StartPoint(1)), ",", ".")
ThisDrawing.SendCommand "offset" & Chr(10) & offdist & Chr(10) & lnstPt & Chr(10) & strPt & Chr(10)
Next oEnt
' end all commands
SendKeys "{ENTER}"
DoEvents
Exit_Here:
' delete all parent lines
oSset.Delete
' clean up (optional)
Set oSset = Nothing
Exit Sub
Err_Control:
MsgBox Err.Description
Resume Exit_Here
End Sub


~'J'~

RMS
07-27-2007, 05:38 PM
Hi,
welcome on board

This code will draw an arc inside your
lines chain at distance 0.12 from these lines
Is there what you want?
Let me know how it will works

~'J'~



Thanks for the welcome!

Fatty....:dunno....where in the world did you learn to write code like that!? Very nice indeed.

I can use it, and it worked in 2000 for me, the second one got an error but on Moday I will test it again at work on 2005.

:thumb

fixo
07-28-2007, 03:13 AM
Hi
another good source for Acad users is here:
http://discussion.autodesk.com/forum.jspa?forumID=33
What about my programmer level in fact it's
very weak, trust me
I am just hacked some codes from many places
and gathered in once, nothing else
The same as with my english level as you guess :)
About second code it's used 'SendCommand' method, that is
working often instabilly, I have to use it rarely by this reason

~'J~

RMS
07-28-2007, 06:57 PM
Nice link too bad that forum isn't PHP though, its hard on the eyes. Well I will be arround here more hoping to get better with VBA programing for AutoCAD. Its hard to get help with this stuff lots of people don't like to share code.

Thanks again, Rob

fixo
07-29-2007, 02:24 AM
Hi Rob

Here are a lot of peoples who
can help too, don't forget about :)

Happy computing

~'J'~

MOEED
09-21-2007, 12:35 AM
dears
i hope to fined some vba code about intersectwith of any object to 3dface.

can u help me about that?

Zrob
08-02-2008, 04:54 PM
Hi J:

I was re-visiting this code and I would like to tweak it just a tad and add a variable to the arc offset called myoffset. I would also like to see this asked at the command line.

How can I do that?

Dim myoffset As Double
'myoffset = vbCr & "Specify the offset" <-- on the command line
'dblRad = Get_Distance(intPt, pt1) - 0.12
dblRad = Get_Distance(intPt, pt1) - myoffset

P.S. Was your screen name Fatty before??

Zrob
08-02-2008, 07:11 PM
Wait, I did it through a example here from Lucas (see code) but now I think what I would like to do is specify if I wan't the offset inside or outside, and the new offset line to be on layer 78 any idea on this?

Edit/Update: I Just figured out how to change the layer to 78 and the offset!


Thanks!
Rob


'Zrob Added:
Dim myoffset As Double
'dblRad = Get_Distance(intPt, pt1) - 0.12
Prompt1 = vbCrLf & "offset (Inches)<" & Format(myoffsets, "0.0000") & ">: "
'store the prompt
myoffset = ThisDrawing.Utility.GetReal(Prompt1)
'get the Slot Length in inches
'get the length if it is 0 then set it to the saved last length
If myoffset = 0 Then
'saved length entered
myoffset = myoffsets
Else
'save the number entered
myoffsets = myoffset
End If

dblRad = Get_Distance(intPt, pt1) - myoffset