CADForums.net

cmedinag · Guest

hi, i've been trying to make a subroutine that from a selection of adyacent lines makes a single polilyne so that i can use sendcommand to make a fillet... i found some code for joining lines and i've been trying to call it but i just dont know how... this is the functions i found and the code im using to call

Public Function MeJoinPline(FstPol As AcadLWPolyline, NxtPol As AcadLWPolyline, FuzVal As Double) As Boolean

Dim FstArr() As Double
Dim NxtArr() As Double
Dim TmpPnt(0 To 1) As Double
Dim FstLen As Long
Dim NxtLen As Long
Dim VtxCnt As Long
Dim FstCnt As Long
Dim NxtCnt As Long
Dim RevFlg As Boolean
Dim RetVal As Boolean

With FstPol
FstArr = .Coordinates
NxtArr = NxtPol.Coordinates
FstLen = UBound(FstArr)
NxtLen = UBound(NxtArr)
'<-Fst<-Nxt
If MePointsEqual(FstArr, 1, NxtArr, NxtLen, FuzVal) Then
MeReversePline FstPol
FstArr = .Coordinates
MeReversePline NxtPol
NxtArr = NxtPol.Coordinates
RevFlg = True
RetVal = True
'<-FstNxt->
ElseIf MePointsEqual(FstArr, 1, NxtArr, 1, FuzVal) Then
MeReversePline FstPol
FstArr = .Coordinates
RevFlg = True
RetVal = True
'Fst-><-Nxt
ElseIf MePointsEqual(FstArr, FstLen, NxtArr, NxtLen, FuzVal) Then
MeReversePline NxtPol
NxtArr = NxtPol.Coordinates
RevFlg = False
RetVal = True
'Fst->Nxt->
ElseIf MePointsEqual(FstArr, FstLen, NxtArr, 1, FuzVal) Then
RevFlg = False
RetVal = True
Else
RetVal = False
End If

If RetVal Then
FstCnt = (FstLen - 1) / 2
NxtCnt = 0
.SetBulge FstCnt, NxtPol.GetBulge(NxtCnt)
For VtxCnt = 2 To NxtLen Step 2
FstCnt = FstCnt + 1
NxtCnt = NxtCnt + 1
TmpPnt(0) = NxtArr(VtxCnt)
TmpPnt(1) = NxtArr(VtxCnt + 1)
.AddVertex FstCnt, TmpPnt
.SetBulge FstCnt, NxtPol.GetBulge(NxtCnt)
Next VtxCnt
.Update
NxtPol.Delete
If RevFlg Then
MeReversePline FstPol
End If
End With

MeJoinPline = RetVal

End Function

' -----

Public Function MeReversePline(PolObj As AcadLWPolyline)

Dim NewArr() As Double
Dim BlgArr() As Double
Dim OldArr() As Double
Dim SegCnt As Long
Dim ArrCnt As Long
Dim ArrLen As Long

With PolObj
OldArr = .Coordinates
ArrLen = UBound(OldArr)
SegCnt = (ArrLen - 1) / 2
ReDim NewArr(0 To ArrLen)
ReDim BlgArr(0 To SegCnt + 1)

For ArrCnt = SegCnt To 0 Step -1
BlgArr(ArrCnt) = .GetBulge(SegCnt - ArrCnt) * -1
Next ArrCnt
For ArrCnt = ArrLen To 0 Step -2
NewArr(ArrLen - ArrCnt + 1) = OldArr(ArrCnt)
NewArr(ArrLen - ArrCnt) = OldArr(ArrCnt - 1)
Next ArrCnt

.Coordinates = NewArr

For ArrCnt = 0 To SegCnt
.SetBulge ArrCnt, BlgArr(ArrCnt + 1)
Next ArrCnt
.Update

End With

End Function

' -----

Public Function MePointsEqual(FstArr, FstPos As Long, NxtArr, NxtPos As Long, FuzVal As Double) As Boolean

Dim XcoDst As Double
Dim YcoDst As Double

XcoDst = FstArr(FstPos - 1) - NxtArr(NxtPos - 1)
YcoDst = FstArr(FstPos) - NxtArr(NxtPos)

MePointsEqual = (Sqr(XcoDst ^ 2 + YcoDst ^ 2) < FuzVal)

End Function

--THIS IS WHERE I WANT TO CALL THE FUNCTION ABOVE

Public Sub FilletPolyline()

Dim entity As AcadEntity
Dim filletRadius As Double
Dim pickedPoint As Variant
Dim polyline As AcadLWPolyline

ThisDrawing.Utility.GetEntity entity, pickedPoint, "Select a polyline..."
filletRadius = ThisDrawing.Utility.GetReal("Enter the fillet radius...")

If TypeOf entity Is AcadLWPolyline Then
Set polyline = entity
ThisDrawing.SendCommand "FILLET Radius" & Str(filletRadius) & " Polyline Last "
Else
Call MeJoinPline
End If

End Sub

thanks for your help!

Oberer · Guest

public and private SUB's can be run via VBARUN.
public and private FUNCTIONS can't be called via vbarun.

to set up a command in autocad:

(defun c:CBA ()
(vl-vbarun "G:/WARE/vb/utilities.dvb!COPY_BLOCK_ATTS")
)

-c:CBA is the command name to type
-"G:/WARE/vb/utilities.dvb" is the fully qualified path to your project
-COPY_BLOCK_ATTS is the name of the public SUB

cmedinag · Guest

but can i call the functions above inside the sub so when the sub is called via vbarun it can be also executed?

Oberer · Guest

sure. here's an old function that uppercases text.

notice how the function "gettexttomodify" is called from within the sub?

in this particular case the function getTextToModify returns a selection. functions may or may not return a value. if they don't return a value you can simply "call" them using Call FunctionName .

	CADForums.net Forum Index -> VBA	All times are GMT
Page 1 of 1