HydroWS水利供水管线设计工具

zaideng123

2015年08月26日 15:46:05

2楼

朋友，软件不能下载啊

londtsai

2015年08月28日 11:40:20

3楼

谢谢楼主分享

szg169

2015年08月28日 11:45:40

4楼

没有软件吗？感谢分享！！

平面人

2015年10月13日 08:38:22

5楼

比如，我们需要经常使用的将多段线节点坐标导入excel，弧线需要通过凸度来标识。
模块完整代码：
Sub PlineToExcel() 'CAD多段线坐标至EXCEL表(采用当前UCS坐标系)
'对AutoCAD部件的引用，方法如下（文中以'开头的语句为注释）：
Dim acadApp As Object '声明AutoCAD应用程序对象变量
'Dim circleObj As Object, textObj As Object '声明AutoCAD中的对象变量,圆,文本
Dim lineobj As Object, layerObj As Object '声明AutoCAD中的对象变量,直线,图层
On Error Resume Next
Set acadApp = GetObject(, "AutoCAD.Application") '若AutoCAD已运行则获得它的对象实例
' If Err Then '如果AutoCAD没有运行
' Err.Clear
' Set acadApp = CreateObject("AutoCAD.Application") '创建AutoCAD应用程序对象实例
' If Err Then '若没有安装AutoCAD
' MsgBox Err.Description
' Exit Sub
' End If
' End If
acadApp.Visible = True '从Excel中的“计算”表中读取各导线点的坐标，在AutoCAD中展点，方法如下： '建立新图层,层名"点",层颜色为红色,并置为当前层
'acadApp.ActiveDocument.ActiveSpace = acModelSpace
' **********

' ******************连接至 excel 应用程序
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim myrange As Range
lab2:
'
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
Set myrange = xlSheet.Application.Selection
'******************************************************

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 & "导线:"
acadApp.ActiveDocument.Utility.GetEntity PickObj, PickPnt, text
' acadApp.ActiveDocument.Utility.GetEntity returnObj, basePnt, "选择平面管线"
'以下语句获取导线的顶点
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 = acadApp.ActiveDocument.Utility.GetPoint(, text & vbCrLf) '获取坐标原点

'下一行是将原点的 WCS 坐标值转换成当前的 UCS坐标值
UCSPnt = acadApp.ActiveDocument.Utility.TranslateCoordinates(Point, acWorld, acUCS, False)
x0 = UCSPnt(0)
y0 = UCSPnt(1)

xlBook.Sheets("光栅图索引").Select
Set xlSheet = xlBook.ActiveSheet

If n = 1 Then '获取当前excel内的活动单元格信息
If myrange.Value <> "" Then m = MsgBox("您选择的单元格已有数据,是否替换相应内容?" & Chr(13) & Chr(13) & "若不替换则跳转到excel中已使用区域的左下方输出", vbYesNo, "单元格非空，是否替换")
If m = 7 Then
l = myrange.Column
j = myrange.Row + myrange.Rows.Count - 1
Else
l = myrange.Column
j = myrange.Row - 1
End If
End If

平面人

2015年10月13日 08:38:44

6楼

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 = acadApp.ActiveDocument.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)
LenthN = GetArcLength(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)
LenthN = GetArcLength(WCSPnt, endPoint, BulgeN)
Else
RadiusN = ""
LenthN = ""
End If
Err.Clear '半径计算完毕

X(i) = UCSPnt(0) - x0
Y(i) = UCSPnt(1) - y0
j = j + 1

With xlSheet
If i = 0 Then
If n > 1 Then j = j + 1
.Cells(j, l) = n & "#多段线"
.Cells(j, l + 1) = "X坐标"
.Cells(j, l + 2) = "Y坐标"
.Cells(j, l + 3) = "i 子段" & vbCrLf & "曲线半径"
.Cells(j, l + 4) = "i 子段" & vbCrLf & "曲线长度"
.Cells(j, l + 5) = "i 子段" & vbCrLf & "曲线凸度"
.Cells(j + 1, l) = i / 2 + 1
.Cells(j + 1, l + 1) = Format(X(i), "0.0000000000")
.Cells(j + 1, l + 2) = Format(Y(i), "0.0000000000")
.Cells(j + 1, l + 3) = Format(RadiusN, "0.0000000000")
.Cells(j + 1, l + 4) = Format(LenthN, "0.0000000000")
.Cells(j + 1, l + 5) = Format(BulgeN, "0.0000000000")
.Cells(j, l).Font.ColorIndex = m
.Cells(j, l + 1).Font.ColorIndex = m
.Cells(j, l + 2).Font.ColorIndex = m
.Cells(j, l + 3).Font.ColorIndex = m
.Cells(j, l + 4).Font.ColorIndex = m
.Cells(j, l + 5).Font.ColorIndex = m
.Cells(j, l).HorizontalAlignment = xlCenter
.Cells(j, l + 1).HorizontalAlignment = xlCenter
.Cells(j, l + 2).HorizontalAlignment = xlCenter
.Cells(j, l + 3).HorizontalAlignment = xlCenter
.Cells(j, l + 4).HorizontalAlignment = xlCenter
.Cells(j, l + 5).HorizontalAlignment = xlCenter
ElseIf i > 0 Then
.Cells(j + 1, l) = i / 2 + 1
.Cells(j + 1, l + 1) = Format(X(i), "0.0000000000")
.Cells(j + 1, l + 2) = Format(Y(i), "0.0000000000")
.Cells(j + 1, l + 3) = Format(RadiusN, "0.0000000000")
.Cells(j + 1, l + 4) = Format(LenthN, "0.0000000000")
.Cells(j + 1, l + 5) = Format(BulgeN, "0.0000000000")
End If
.Cells(j + 1, l).Font.ColorIndex = m
.Cells(j + 1, l + 1).Font.ColorIndex = m '设置excel内数据颜色
.Cells(j + 1, l + 2).Font.ColorIndex = m
.Cells(j + 1, l + 3).Font.ColorIndex = m
.Cells(j + 1, l + 4).Font.ColorIndex = m
.Cells(j + 1, l + 5).Font.ColorIndex = m
.Cells(j + 1, l + 1).NumberFormat = "#0.000" '设置excel内数据显示精度
.Cells(j + 1, l + 2).NumberFormat = "#0.000"
.Cells(j + 1, l + 3).NumberFormat = "#0.000"
.Cells(j + 1, l + 4).NumberFormat = "#0.000"
.Cells(j + 1, l + 5).NumberFormat = "#0.000"
End With
Next i
'xlSheet.Cells(j + 1, l + 3).Delete
xlSheet.Cells(j + 2, l).Select '选中导出的数据区域下方单元格，便于找到excel中的数据
n = n + 1

Loop Until pntcnt = 0
End Sub

'Set Excel.Worksheet = Excel.Workbook.ActiveSheet
'Excel.Application.Visible = True
' Dim xlApp As Excel.Application
' Dim xlBook As Excel.Workbook
' Dim xlSheet As Excel.Worksheet

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

Public Function GetArcLength(Points As Variant, PointE As Variant, bulge As Double) As Double
Dim angle As Double
Dim Length As Double
Dim Dist As Double
Dim ArcRadius 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，则为直线段，所以起点到终点的长度就是需要的长度
GetArcLength = Length
Else
angle = 4 * Atn(Abs(bulge)) ' 如果凸度不为零，则计算弧段的长度。按照凸度的定义，凸度为包角的1/4的正切值。
ArcRadius = (Length / 2) / Sin(angle / 2) ' 计算弧段的半径
GetArcLength = ArcRadius * angle
End If

End Function

平面人

2015年10月13日 08:40:33

7楼

本帖最后由 3xxx 于 2015-12-20 22:51 编辑