|
|
Sub PlineToExcel() 'CAD多段线坐标至EXCEL表(采用当前UCS坐标系)
'连接EXCEL
Dim xlApp As Excel.Application
Dim xlbook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
On Error Resume Next
Set xlApp = GetObject(, "excel.application")
If Err <> 0 Then
Err.Clear
Set xlApp = CreateObject("excel.application")
If Err <> 0 Then
MsgBox "无法启动excel"
Exit Sub
End If
End If
If ActiveWorkbook.Sheets.Count = 0 Then xlbook = xlApp.Workbooks.Add
Set xlbook = xlApp.ActiveWorkbook
Set xlSheet = xlbook.ActiveSheet
xlApp.Visible = True
If Err <> 0 Then Err.Clear
Dim PickObj As AcadEntity '保存被选择图元的对象变量
Dim PickPnt As Variant '选择图元时的拾取点变量
Dim gpnt As Variant
Dim pntcnt As Integer
Dim UCSPnt As Variant, WCSPnt(0 To 2) As Double
Dim Point As Variant
Dim x0 As Double, y0 As Double, RadiusN As Double, BulgeN As Double
Dim point_temp_x As Double, point_temp_y As Double
Dim X() As Double, Y() As Double '保存多义线的各点坐标的变量
Dim EndPoint(0 To 2) As Double
Dim Text As String
Dim i As Integer, Ii As Integer, j As Long, k As Integer, l As Integer, m As Integer, n As Integer
n = 1 'n为多段线编号
l = 1
Do
Text = "请选择第 " & n & " 导线："
ThisDrawing.Utility.GetEntity PickObj, PickPnt, Text
'以下语句获取导线的顶点
gpnt = PickObj.Coordinates
pntcnt = UBound(gpnt)
If Err <> 0 Then '引入错误处理
Exit Do
End If
If n = 1 Then
Text = "选择第 " & n & " 导线的坐标原点：<0,0>" '设置默认原点为(0,0)点
Point = PickPnt
Point(0) = 0
Point(1) = 0
Else
Text = "选择第 " & n & " 导线的坐标原点：<上一次选择的原点>" '默认原点为 <上一次选择的原点>
End If
Point = ThisDrawing.Utility.GetPoint(, Text & vbCrLf) '获取坐标原点
'下一行是 将原点的 WCS 坐标值 转换成当前的 UCS坐标值
UCSPnt = ThisDrawing.Utility.TranslateCoordinates(Point, acWorld, acUCS, False)
x0 = UCSPnt(0)
y0 = UCSPnt(1)
If n = 1 Then '获取当前excel内的活动单元格信息
If ActiveCell.Value <> "" Then m = MsgBox(" 您选择的单元格已有数据,是否替换相应内容？ " & Chr(13) & Chr(13) & "若不替换则跳转到excel中已使用区域的左下方输出", vbYesNo, "单元格非空，是否替换")
If m = 7 Then
l = ActiveCell.Column
j = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1
Else
l = ActiveCell.Column
j = ActiveCell.Row - 1
End If
End If
m = j + l * 3 - 2 '配置输出内容的字体颜色，不同钢束的颜色不一样
If m > 56 Then
Do
m = m - 56
Loop Until m < 56
End If
If m = 2 Or m = 19 Or m = 20 Or m = 36 Then m = m + 3
If gpnt(0) < gpnt(2) Then '判断多义线起始段x方向，若起始段坐标x值不递增，则读取导线点时反向读取
Ii = -2: k = 2
Else
Ii = pntcnt + 1: k = -2
End If
ReDim X(pntcnt + 1), Y(pntcnt + 1) '根据多段线端点个数定义动态数组大小
For i = 0 To pntcnt - 1 Step 2 '导线的各点循环
Ii = Ii + k
WCSPnt(0) = gpnt(Ii): WCSPnt(1) = gpnt(Ii + 1): WCSPnt(2) = 0
UCSPnt = ThisDrawing.Utility.TranslateCoordinates(WCSPnt, acWorld, acUCS, False) '将 WCS 坐标值 转换成当前的 UCS坐标值
'计算第n段的曲线半径，直线返回 0 ，圆弧返回半径
If i < pntcnt - 1 And k = 2 Then
EndPoint(0) = gpnt(Ii + 2): EndPoint(1) = gpnt(Ii + 3): EndPoint(2) = 0
BulgeN = PickObj.GetBulge(Ii / 2)
RadiusN = GetArcRadius(WCSPnt, EndPoint, BulgeN)
ElseIf i < pntcnt - 1 And k = -2 Then
EndPoint(0) = gpnt(Ii - 2): EndPoint(1) = gpnt(Ii - 1): EndPoint(2) = 0
BulgeN = PickObj.GetBulge(Ii / 2 - 1)
RadiusN = GetArcRadius(WCSPnt, EndPoint, BulgeN)
Else
RadiusN = ""
End If
Err.Clear '半径计算完毕
X(i) = UCSPnt(0) - x0
Y(i) = UCSPnt(1) - y0
j = j + 1
If i = 0 Then
If n > 1 Then j = j + 1
xlSheet.Cells(j, l) = n & "#多段线"
xlSheet.Cells(j, l + 1) = "X坐标"
xlSheet.Cells(j, l + 2) = "Y坐标"
xlSheet.Cells(j, l + 3) = "i 子段" & vbCrLf & "曲线半径"
xlSheet.Cells(j + 1, l) = i / 2 + 1
xlSheet.Cells(j + 1, l + 1) = Format(X(i), "0.0000000000")
xlSheet.Cells(j + 1, l + 2) = Format(Y(i), "0.0000000000")
xlSheet.Cells(j + 1, l + 3) = Format(RadiusN, "0.0000000000")
xlSheet.Cells(j, l).Font.ColorIndex = m
xlSheet.Cells(j, l + 1).Font.ColorIndex = m
xlSheet.Cells(j, l + 2).Font.ColorIndex = m
xlSheet.Cells(j, l + 3).Font.ColorIndex = m
xlSheet.Cells(j, l).HorizontalAlignment = xlCenter
xlSheet.Cells(j, l + 1).HorizontalAlignment = xlCenter
xlSheet.Cells(j, l + 2).HorizontalAlignment = xlCenter
xlSheet.Cells(j, l + 3).HorizontalAlignment = xlCenter
ElseIf i > 0 Then
xlSheet.Cells(j + 1, l) = i / 2 + 1
xlSheet.Cells(j + 1, l + 1) = Format(X(i), "0.0000000000")
xlSheet.Cells(j + 1, l + 2) = Format(Y(i), "0.0000000000")
xlSheet.Cells(j + 1, l + 3) = Format(RadiusN, "0.0000000000")
End If
xlSheet.Cells(j + 1, l).Font.ColorIndex = m
xlSheet.Cells(j + 1, l + 1).Font.ColorIndex = m '设置excel内数据颜色
xlSheet.Cells(j + 1, l + 2).Font.ColorIndex = m
xlSheet.Cells(j + 1, l + 3).Font.ColorIndex = m
xlSheet.Cells(j + 1, l + 1).NumberFormat = "#0.000" '设置excel内数据显示精度
xlSheet.Cells(j + 1, l + 2).NumberFormat = "#0.000"
xlSheet.Cells(j + 1, l + 3).NumberFormat = "#0.000"
Next i
xlSheet.Cells(j + 1, l + 3).Delete
xlSheet.Cells(j + 2, l).Select '选中导出的数据区域下方单元格，便于找到excel中的数据
n = n + 1
Loop Until pntcnt = 0
Set xlSheet = xlbook.ActiveSheet
xlApp.Visible = True
End Sub
Public Function GetArcRadius(PointS As Variant, PointE As Variant, Bulge As Double) As Double
Dim Angle As Double
Dim Length As Double
Dim Dist As Double
Dim i As Integer
' 计算起点到终点的长度
For i = LBound(PointS) To UBound(PointS)
Dist = Dist + ((PointS(i) - PointE(i)) ^ 2)
Next
Length = Sqr(Dist)
If Bulge = 0 Then ' 如果凸度为0，则为直线段，所以起点到终点的长度就是需要的长度
GetArcRadius = 0
Else
Angle = 4 * Atn(Abs(Bulge)) ' 如果凸度不为零，则计算弧段的长度。按照凸度的定义，凸度为包角的1/4的正切值。
GetArcRadius = (Length / 2) / Sin(Angle / 2) ' 计算弧段的半径
End If
End Function
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2015-9-1 12:17