Dim a, b, c, d As Double
Dim P0x, P0y, P1x, P1y, P2x, P2y, P3x, P3y As DoublePrivate
Sub cmd_3_Click() ActiveDocument.Unit = cdrMillimeter '设定文件单位为毫米
a = txt_a.Value
b = txt_b.Value
If a < b Then
b = txt_a.Value
a = txt_b.Value
End If ' 取值（a>b）
c = txt_c.Value '
Set s0 = ActiveLayer.CreateEllipse2(0, 0, a, b) '画个圆
Set s1 = ActiveLayer.CreateEllipse2(0, 0, a, b, 180#, 270#) '画个半圆
Set s2 = ActiveLayer.CreateLineSegment(0, 0, -b, b)
ActiveDocument.AddToSelection s1, s2
Set ss1 = ActiveSelectionRange
Set ss1 = ss1.ConvertOutlineToObject
Set ss1 = ss1(1).Intersect(ss1(2), True, True)
s1.Delete
s2.Delete
P0x = ss1.CenterX
P0y = ss1.CenterY
ss1.Delete
Rem 找到第初始点（P0x, P0y）redofist:
Set sone = ActiveLayer.CreateLineSegment(-a, 0, P0x, P0y) ' 第一根测试线
Set s1 = ActiveLayer.CreateEllipse2(0, 0, a, b, 180#, 270#) '画个半圆
Set s2 = sone.Duplicate
s2.Rotate 90#
ActiveDocument.AddToSelection s1, s2
Set ss1 = ActiveSelectionRange
Set ss1 = ss1.ConvertOutlineToObject
Set ss1 = ss1(1).Intersect(ss1(2), True, True)
s1.Delete
s2.Delete
P1x = ss1.CenterX
P1y = ss1.CenterY
ss1.Delete
Rem 找到第一个点（P1x, P1y）
Set stwo = ActiveLayer.CreateLineSegment(0, b, P1x, P1y) ' 第2根测试线
Set s1 = ActiveLayer.CreateEllipse2(0, 0, a, b, 180#, 270#) '画个半圆
Set s2 = stwo.Duplicate s2.Rotate 90#
ActiveDocument.AddToSelection s1, s2
Set ss1 = ActiveSelectionRange
Set ss1 = ss1.ConvertOutlineToObject
Set ss1 = ss1(1).Intersect(ss1(2), True, True)
s1.Delete
s2.Delete
P2x = ss1.CenterX
P2y = ss1.CenterY
ss1.Delete
Rem 找到第2个点（P2x, P2y）
If Abs(P2x - P0x) > c Or Abs(P2y - P0y) > c Then
sone.Delete
stwo.Delete
P0x = P2x
P0y = P2y
GoTo redofist '转上去，重画第一根线
Else
sone.Delete
stwo.Delete
Set line1 = ActiveLayer.CreateLineSegment(0, b, P2x, P2y)
Set line2 = ActiveLayer.CreateLineSegment(P2x, P2y, P1x, P1y)
Set line3 = ActiveLayer.CreateLineSegment(P1x, P1y, -a, 0)
End If
End Sub
Function drawline1(sone As Shape) As Double
Set sone = ActiveLayer.CreateLineSegment(-a, 0, P0x, P0y) ' 第一根测试线
Set s1 = ActiveLayer.CreateEllipse2(0, 0, a, b, 180#, 270#) '画个半圆
Set s2 = sone.Duplicate s2.Rotate 90#
ActiveDocument.AddToSelection s1, s2
Set ss1 = ActiveSelectionRange
Set ss1 = ss1.ConvertOutlineToObject
Set ss1 = ss1(1).Intersect(ss1(2), True, True)
s1.Delete
s2.Delete
P1x = ss1.CenterX
P1y = ss1.CenterY
ss1.DeleteEnd Function
