读取cad钢束生成midas文件
本帖最后由 dogingate 于 2019-12-19 15:03 编辑在cad中加载这个dvb小东东，可以直接读取钢束生成mct文件，方便钢束建模
在cad中要输什么命令 楼主说的dvd是附件里的那个压缩包？ gu888min 发表于 2019-12-19 19:00
在cad中要输什么命令
这个，要vbaload那个dvb文件，然后vbaide打开编辑器，从里面按f5运行
Sub TendonsCadTransformsToMidas()
On Error Resume Next
Dim oZdPlinesXYZ As Object: Set oZdPlinesXYZ = CreateObject("scripting.dictionary")
Dim zdkey As String
Dim zditem As Variant
Dim strFullFileName As String
'''=============================读取坐标原点坐标=======================================
Dim dblXBase As Double, dblYBase As Double, dblZBase As Double
Dim dblScaleFactor As Double, strTendonName As String, strTendonBelong As String
Dim oSset As AcadSelectionSet
Dim keyWord As String
Dim objAcadEntity As AcadEntity
Dim varPickedPoint As Variant
Dim arrCoordinates As Variant
keyWord = "C"
intPlineNum = 0
intPlinesCount = 0
Do While keyWord = "C"
'''比例尺
dblScaleFactor = 1
'''钢束特性值
strTendonName = ThisDrawing.Utility.GetString(False, "请输入Midas钢束名称,默认=auto : ")
If Err Then
If StrComp(Err.Description, "User input is a keyword", 1) Then
Err.Clear
strTendonName = "auto"
End If
End If
If strTendonName = "" Then
strTendonName = "auto"
End If
'''钢束所属单元
strTendonBelong = ThisDrawing.Utility.GetString(False, "请输入Midas钢束分配单元，默认为1to100 : ")
If Err Then
If StrComp(Err.Description, "User input is a keyword", 1) Then
Err.Clear
strTendonBelong = "1to100"
End If
End If
If strTendonBelong = "" Then
strTendonBelong = "1to100"
End If
ptBase = ThisDrawing.Utility.GetPoint(, "请指定坐标原点,默认为（0,0）点 : ")
' If StrComp(Err.Description, "User input is a keyword", 1) Then
' Err.Clear
' ptBase(0) = 0: ptBase(1) = 0: ptBase(2) = 0
' End If
Set oSset = ThisDrawing.SelectionSets.Add("TEST_SSET") '增加选择集
If Err Then
Err.Clear
ThisDrawing.SelectionSets.Item("TEST_SSET").Delete '删除选择集
Set oSset = ThisDrawing.SelectionSets.Add("TEST_SSET")
End If
oSset.SelectOnScreen '''在屏幕上进行选择
'================================读取多段线坐标============================================
For k = 0 To oSset.Count - 1
If TypeOf oSset.Item(k) Is AcadLWPolyline Then '''判断选择集是否为多段线
Set oLWPolyline = oSset.Item(k): arrCoordinates = oLWPolyline.Coordinates
'''读取数据存入oPlines
zdkey = oLWPolyline.ObjectID
If Not oZdPlinesXYZ.exists(zdkey) Then
intPlinePointsCount = (UBound(arrCoordinates) + 1) / 2 '''控制点个数
ReDim zditem(0 To intPlinePointsCount - 1, 0 To 7) '''0)x;1)y;2)z;3)radius;4)bulge(凸度);5)缩放因子;6)钢束名称;7)钢束所属单元
For n = 0 To intPlinePointsCount - 1 '''下标从0开始,并将y坐标与z坐标进行转换
zditem(n, 0) = arrCoordinates((n) * 2) - ptBase(0) '''x坐标
zditem(n, 1) = 0 '''y坐标
zditem(n, 2) = arrCoordinates((n) * 2 + 1) - ptBase(1) '''z坐标
zditem(n, 3) = 0 '''radius
zditem(n, 4) = oLWPolyline.GetBulge(n) '''bulge
zditem(n, 5) = dblScaleFactor
zditem(n, 6) = strTendonName
zditem(n, 7) = strTendonBelong
Next
Call sortPlineByX(zditem)
oZdPlinesXYZ(zdkey) = zditem
End If
End If
Next k
ThisDrawing.SelectionSets.Item("TEST_SSET").Delete '''删除选择集
ThisDrawing.Utility.InitializeUserInput 0, "C E"
keyWord = ThisDrawing.Utility.GetKeyword("是否继续选择,继续选择<C>，结束选择并输出数据<E>，默认为C >]: ")
If Err Or keyWord = "" Then
keyWord = "C"
Err.Clear
End If
Loop
Dim arrZdkeys As Variant: arrZdkeys = oZdPlinesXYZ.keys
Dim strOut As String: strOut = ""
For k = 0 To oZdPlinesXYZ.Count - 1
zdkey = arrZdkeys(k)
arrPlines = oZdPlinesXYZ(zdkey)
strOut = strOut & dPlinesXYCal(arrPlines) & vbCrLf
Next k
''====================================================================
''输出数据
strFullFileName = "c:" & "\TendonsToMidas.txt"
Open strFullFileName For Output As #1
Print #1, strOut
Close #1
''====================================================================
ThisDrawing.Utility.Prompt "输出Civil Midas的钢束数据文件成功！"
End Sub
Sub sortPlineByX(arr)
Dim i&, j&, vSwap, min&
For i = LBound(arr, 1) To UBound(arr, 1)
min = i
For j = i + 1 To UBound(arr, 1)
If arr(min, 0) > arr(j, 0) Then min = j
Next
If min <> i Then
For k = 0 To 7
vSwap = arr(min, k): arr(min, k) = arr(i, k): arr(i, k) = vSwap
Next k
End If
Next i
End Sub
Function dPlinesXYCal(ByVal arrPlines As Variant)
Dim intPlinesCount As Integer: intPlinesCount = 1
'半径赋值
Dim dTheta As Double, dblLength As Double, dblRadius As Double
Dim a0 As Double, b0 As Double, c0 As Double
Dim a1 As Double, b1 As Double, c1 As Double
Dim dblDimensionUnit As Double: dblDimensionUnit = 100
For k = 1 To intPlinesCount'''逐钢束
Dim intPlinePointsCount As Integer: intPlinePointsCount = UBound(arrPlines, 1) - LBound(arrPlines, 1) + 1
Dim arrPlinesNew As Variant
'如果是导线点，半径按输入的计入，如果是圆弧，推算转点及半径
j = 0
For n = 0 To intPlinePointsCount - 1 '''逐钢束上的控制点
If arrPlines(n, 4) <> 0 Then '''凸度不为零 bulge=tan(theta/4)=2*L/H
dTheta = 4 * Atn(Abs(arrPlines(n, 4))) '''圆心角
dblLength = Sqr((arrPlines(n + 1, 0) - arrPlines(n, 0)) ^ 2 + (arrPlines(n + 1, 2) - arrPlines(n, 2)) ^ 2) '''割线长度=sqrt((x2-x2)^2+(y2-y1)^2)
dblRadius = 0.5 * dblLength / Sin(dTheta / 2) '''半径
'''上一个直线和下一个直线的交点即为实际的转点
'''获取上一条直线ax+by+c=0方程的系数
Call getLinePara(arrPlines(n - 1, 0), arrPlines(n - 1, 2), arrPlines(n, 0), arrPlines(n, 2), a0, b0, c0)
'''获取下一条直线ax+by+c=0方程的系数
Call getLinePara(arrPlines(n + 1, 0), arrPlines(n + 1, 2), arrPlines(n + 2, 0), arrPlines(n + 2, 2), a1, b1, c1)
'''获取两条直线的交点
arrpoint = getCrossPoint(a0, b0, c0, a1, b1, c1)
ReDim Preserve arrPlinesNew(UBound(arrPlinesNew, 1), UBound(arrPlinesNew, 2) + 1)
arrPlinesNew(0, j) = arrpoint(0) / dblDimensionUnit
arrPlinesNew(1, j) = 0
arrPlinesNew(2, j) = arrpoint(1) / dblDimensionUnit
arrPlinesNew(3, j) = dblRadius / dblDimensionUnit 'radius
n = n + 1
j = j + 1
Else '''凸度为零
If j <> 0 Then
ReDim Preserve arrPlinesNew(UBound(arrPlinesNew, 1), UBound(arrPlinesNew, 2) + 1)
Else
ReDim arrPlinesNew(0 To 3, 0 To 0)
End If
arrPlinesNew(0, j) = arrPlines(n, 0) / dblDimensionUnit 'x
arrPlinesNew(1, j) = arrPlines(n, 1) / dblDimensionUnit 'y
arrPlinesNew(2, j) = arrPlines(n, 2) / dblDimensionUnit 'z
arrPlinesNew(3, j) = 0 'radius
j = j + 1
End If
Next n
Next k
Call sortPlineByX(arrPlinesNew)
dblScaleFactor = arrPlines(0, 5)
strTendonName = arrPlines(0, 6)
strTendonBelong = arrPlines(0, 7)
strTendonProperty = "auto"
strTendonGroup = "auto"
dPlinesXYCal = TendonsTransformToMidas(arrPlinesNew, dblScaleFactor, strTendonName, strTendonProperty, strTendonBelong, strTendonGroup)
End Function
Sub getInput(dblScaleFactor, strTendonName, strTendonBelong, ptBase)
'''================================读取参数(默认值)================================================
''''比例因子
'dblScaleFactor = ThisDrawing.Utility.GetReal("请输入钢束线长度至m单位需放大的比例,默认=1 :")
'If Err Then
' If StrComp(Err.Description, "User input is a keyword", 1) Then
' Err.Clear
' dblScaleFactor = 1
' End If
'End If
'If dblScaleFactor = "" Then
' dblScaleFactor = 1
'End If
End Sub
Private Function TendonsTransformToMidas(arrPlinesNew, dblScaleFactor, strTendonName, strTendonProperty, strTendonBelong, strTendonGroup)
''====================================================================
'*TDN-PROFILE ; Tendon Profile
'; NAME=NAME, TDN-PROPERTY, ELEM_LIST, BEGIN, END, CURVE, INPUT; line 1
'; GROUP, LENGOPT, BLEN, ELEN, bTP, rNUM ; line 2
'; SHAPE, IP_X, IP_Y, IP_Z, AXIS, VX, VY ; line 3(Straight)
'; SHAPE, IP_X, IP_Y, IP_Z, RC_X, RC_Y, OFFSET, DIR ; line 3(Curve)
'; SHAPE, INS_PT, REF_ELEM, AXIS ; line 3(Element)
'; XAR_ANGLE, bPROJECTION, GR_AXIX, GR_ANGLE ; line 4(Straight/Curve)
'; XAR_ANGLE, bPROJECTION, OFFSET_Y, OFFSET_Z ; line 4(Element)
'; X1, Y1, Z1, bFIX1, RY1, RZ1, RADIUS1 ; from line 5(3D)
'*TDN-PROPERTY ; Tendon Property
'; NAME, TYPE, MATL, AREA, DIA, RM, RC, FF, WF, US, YS, LT, ASB, ASE, bBONDED, ALPHA, \
'; bOSRF, FT, FPK, ACHANGE, bRELAX, TDMFK, WobbleType, AngleDisp
' 15, INTERNAL, 2, 0.0021, 0.09, 2, 0, 0.3, 0.0066, 1.86326e+006, 1.56906e+006, POST, 0.006, 0.006, YES, 0, NO, 0.3, 1860000, 0, YES, 0, 0, 0
' 12, INTERNAL, 2, 0.00168, 0.08, 2, 0, 0.3, 0.0066, 1.86326e+006, 1.56906e+006, POST, 0.006, 0.006, YES, 0, NO, 0.3, 1860000, 0, YES, 0, 0, 0
Dim dX As Double, dY As Double, dZ As Double, dR As Double
Dim strOut As String: strOut = ""
'''钢束特性
strOut = strOut & "*TDN-PROPERTY ; Tendon Property" & vbCrLf
strOut = strOut & strTendonProperty & ", INTERNAL, 2, 0.0021, 0.09, 2, 0, 0.3, 0.0066, 1.86326e+006, 1.56906e+006, POST, 0.006, 0.006, YES, 0, NO, 0.3, 1860000, 0, YES, 0, 0, 0" & vbCrLf
'''钢束组
strOut = strOut & "*TENDON-GROUP ; Tendon Group" & vbCrLf
strOut = strOut & strTendonGroup & vbCrLf
'''钢束形状
strOut = strOut & "*TDN-PROFILE ; Tendon Profile" & vbCrLf
strOut = strOut & "NAME=" & strTendonName & "," & strTendonProperty & "," & strTendonBelong & ",0,0,ROUND,3D" & vbCrLf
strOut = strOut & strTendonGroup & ",USER,0,0,NO," & vbCrLf
strOut = strOut & "STRAIGHT,0,0,0,X,0,0" & vbCrLf
strOut = strOut & "0,YES,Y,0" & vbCrLf
For i = 0 To UBound(arrPlinesNew, 2)
dX = Round(arrPlinesNew(0, i), 3)
dY = Round(arrPlinesNew(1, i), 3)
dZ = Round(arrPlinesNew(2, i), 3)
dR = Round(arrPlinesNew(3, i), 3)
strOut = strOut & dX & "," & dY & "," & dZ & ",NO,0,0," & dR & vbCrLf
Next i
TendonsTransformToMidas = strOut
End Function
Private Sub getLinePara(x0, y0, X1, Y1, A, B, C)
'''两点求直线方程ax+by+c=0
A = y0 - Y1
B = X1 - x0
C = x0 * Y1 - y0 * X1
End Sub
Private Function getCrossPoint(a0 As Double, b0 As Double, c0 As Double, a1 As Double, b1 As Double, c1 As Double)
'''计算两直线交点
Dim arrxy As Variant: ReDim arrxy(1)
D = a0 * b1 - a1 * b0
If D <> 0 Then
arrxy(0) = (b0 * c1 - b1 * c0) / D
arrxy(1) = (a1 * c0 - a0 * c1) / D
End If
getCrossPoint = arrxy
End Function
楼主 这个生成的MCT文件在哪里呀？
能说得更清楚明白些吗？
就是2条直线求交点啊
给4个点的坐标，分别用前面两个点和后面两个点各确定一条直线，然后求交点坐标
页:
[1]