Public Sub PToG()
Dim setPoly As AcadSelectionSet
Dim filVar(0 To 0) As Integer
Dim filType(0 To 0) As Variant
Dim dataCol As Collection
Set dataCol = New Collection
On Error Resume Next
Open "c:/g-code.txt" For Output As #1
If Err.Number <> 0 Then
Close #1
Open "c:/g-code.txt" For Output As #1
End If
Set setPoly = ThisDrawing.SelectionSets.Add("TmpPoly")
If Err.Number <> 0 Then
ThisDrawing.SelectionSets.Item("TmpPoly").Delete
Set setPoly = ThisDrawing.SelectionSets.Add("TmpPoly")
End If
On Error GoTo 0
Err.Clear
filVar(0) = 0
filType(0) = "LWPolyLine"
ThisDrawing.Utility.Prompt "Select Point"
setPoly.SelectOnScreen filVar, filType
If setPoly.Count = 0 Then
MsgBox "선택된것이 없어서 종료합니다."
Exit Sub
End If
Dim PolyObj As AcadLWPolyline
Set PolyObj = setPoly(0)
Dim tmppt1(0 To 2) As Double
Dim polyVtx As Variant
Dim polyBulge() As Double
Dim polypt(0 To 2) As Double
Dim tmpRadious As Double
Dim outstring As String
polyVtx = PolyObj.Coordinates
Print #1, "X" & Format(polyVtx(0), "#.##0") & "Y" & Format(polyVtx(1), "#.##0")
For i = 0 To UBound(polyVtx) - 3 Step 2
polypt(0) = polyVtx(i)
polypt(1) = polyVtx(i + 1)
polypt(2) = 0
tmppt1(0) = polyVtx(i + 2)
tmppt1(1) = polyVtx(i + 3)
tmppt1(2) = 0
If 0 <> PolyObj.GetBulge(i / 2) Then
tmppt = GetCenPtFromBulge(polypt, tmppt1, PolyObj.GetBulge(i / 2))
tmpRadious = GetDistPt2Pt(polypt, tmppt)
If 0 < PolyObj.GetBulge(i / 2) Then
outstring = "G03X" & Format(tmppt1(0), "#.##0") & "Y" & Format(tmppt1(1), "#.##0") & "R" & Format(tmpRadious, "#.##0")
Else
outstring = "G02X" & Format(tmppt1(0), "#.##0") & "Y" & Format(tmppt1(1), "#.##0") & "R" & Format(tmpRadious, "#.##0")
End If
Else
outstring = "G01X" & Format(tmppt1(0), "#.##0") & "Y" & Format(tmppt1(1), "#.##0")
End If
Print #1, outstring
Next i
Close #1
End Sub
Private Function GetCenPtFromBulge(StartPoint As Variant, EndPoint As Variant, Bulge As Double)
Dim midpt As Variant
Dim arcmidpt As Variant
Dim fun As Variant
Dim middist As Double
Dim ptdist As Double
Dim ptang As Double
Dim addang As Variant
Dim buldist As Double
Dim Utility As AcadUtility
Set Utility = ThisDrawing.Utility
ptdist = GetDistPt2Pt(StartPoint, EndPoint)
ptang = Utility.AngleFromXAxis(StartPoint, EndPoint)
If Bulge = 0 Then
addang = Null
Else
addang = ptang - Pi / 2
End If
Dim StartArcmidMidPt As Variant
Dim StartArcmidAng As Double
Dim StartArcmidDist As Double
Dim StartArcmid90Pt As Variant
Dim Aobj As AcadLine
Dim Bobj As AcadLine
If Not IsNull(addang) Then
middist = ptdist / 2
buldist = middist * Bulge
midpt = Utility.PolarPoint(StartPoint, ptang, middist)
arcmidpt = Utility.PolarPoint(midpt, addang, buldist)
StartArcmidDist = GetDistPt2Pt(StartPoint, arcmidpt)
StartArcmidAng = Utility.AngleFromXAxis(StartPoint, arcmidpt)
StartArcmidMidPt = Utility.PolarPoint(StartPoint, StartArcmidAng, StartArcmidDist / 2)
StartArcmid90Pt = Utility.PolarPoint(StartArcmidMidPt, StartArcmidAng + Pi / 2, StartArcmidDist)
With ThisDrawing.ModelSpace
Set Aobj = .AddLine(midpt, arcmidpt)
Set Bobj = .AddLine(StartArcmidMidPt, StartArcmid90Pt)
End With
fun = Aobj.IntersectWith(Bobj, acExtendBoth)
Aobj.Delete
Bobj.Delete
Else
fun = Null
End If
GetCenPtFromBulge = fun
End Function
Private Function GetDistPt2Pt(pt1 As Variant, pt2 As Variant) As Double
'''2점간의 거리
GetDistPt2Pt = Sqr((pt2(0) - pt1(0)) ^ 2 + (pt2(1) - pt1(1)) ^ 2)
End Function
Public Function GetAnglePt2Pt(pt1 As Variant, pt2 As Variant) As Double
'''두점간의 각도
'''GetDistPt2Pt 함수 있어야 함.
GetAnglePt2Pt = ThisDrawing.Utility.AngleFromXAxis(pt1, pt2)
End Function
Public Function Pi() As Double
'
' Abstract - Calculates Pi.
'
' Parameters
' none.
'
' Return Value
' Pi.
'
' R0 31 Jul 98 MichaelHu
'
On Error GoTo ERR_HANDLER
Pi = 4 * Atn(1)
EXIT_PT:
Exit Function
ERR_HANDLER:
Err.Raise Err.Number, "CadServices:Pi", Err.Description
Resume EXIT_PT
End Function