Declare Function mdlDialog_fileOpen Lib "stdmdlbltin.dll" (ByVal _ fileName As String, ByVal rFileH As Long, ByVal _ resourceId As Long, ByVal suggestedFileName As String, _ ByVal filterString As String, ByVal defaultDirectory As String, _ ByVal titleString As String) As Long ' 定义常量 Const WIDTH_RATE = 0.8 Const TEXT_SPACING_RATE = 0.5 Const TABLE_TITLE_HEIGHT = 3.5 Const TABLE_TITLE_COLOR = 4 Const TABLE_TITLE_STYLE = "Arial" Const TABLE_TITLE_WIDTH = 0 Const TABLE_HEAD_HEIGHT = 2.5 Const TABLE_HEAD_COLOR = 2 Const TABLE_HEAD_STYLE = "Arial" Const TABLE_HEAD_WIDTH = 0 Const TABLE_CONTENT_HEIGHT = 2.5 Const TABLE_CONTENT_COLOR = 2 Const TABLE_CONTENT_STYLE = "Arial" Const TABLE_CONTENT_WIDTH = 0 Const TABLE_OUTLINE_COLOR = 3 Const TABLE_OUTLINE_WIDTH = 3 Const TABLE_OUTLINE_STYLE = 0 Const TABLE_INLINE_COLOR = 3 Const TABLE_INLINE_WIDTH = 3 Const TABLE_INLINE_STYLE = 0 '--------------------------------------------------------------- ' ' OpenFile - 打开txt文件 ' -- 打开成功,返回文件路径 ' -- 打开失败,返回空值 ' '--------------------------------------------------------------- Function OpenFile() As String Dim strFileName As String Dim lngFhandle As Long Dim lngRid As Long Dim retVal As Long strFileName = Space(255) retVal = mdlDialog_fileOpen(strFileName, lngFhandle, lngRid, _ "", "*.txt", "C:/", "请选择平曲线参数文件") If retVal = 0 Then OpenFile = Left(strFileName, InStr(1, strFileName, Chr(0)) - 1) ElseIf retVal = 1 Then OpenFile = "" End If End Function Sub Main() Dim strFName As String strFName = OpenFile() If strFName <> "" Then Dim strTmp As String ' 字符串临时变量 Dim i As Integer ' 循环变量 Dim j As Integer ' 循环变量 Dim strSourceArray() As String ' 原始文本 Dim strResultArray() As String ' 处理结果 Dim strHAName As String ' 平曲线名称 ' 将文本按行存储在数组中 Open Trim(strFName) For Input As #1 strTmp = StrConv(InputB(LOF(1), #1), vbUnicode) Close #1 strSourceArray = Split(strTmp, vbCrLf) ReDim strResultArray(UBound(strSourceArray)) ' 取得Horizontal Alignment Name,并保存在变量strHAName中 For i = 0 To UBound(strSourceArray) If InStr(strSourceArray(i), "Horizontal Alignment Name:") <> 0 Then strHAName = Trim(Replace(strSourceArray(i), "Horizontal Alignment Name:", "")) Exit For End If Next For i = 0 To UBound(strSourceArray) ' ' 处理Non-collinear标签 ' If InStr(strSourceArray(i), "Non-collinear") <> 0 Then ' ' 如果标签为Non-collinear,则输出警告信息 ' strResultArray(i) = Space(1) & "Warning!In " & i & " Line Appear " & Chr(34) & "Non-collinear" & Chr(34) ' End If ' 处理POB转START以及POE转END问题 If InStr(strSourceArray(i), "POB") <> 0 Then strResultArray(i) = Space(1) & Trim(Replace(strSourceArray(i), "POB ( ) ", "START")) End If If InStr(strSourceArray(i), "POE") <> 0 Then strResultArray(i) = Space(3) & Trim(Replace(strSourceArray(i), "POE ( ) ", "END")) End If ' 处理Element: Linear标签 If InStr(strSourceArray(i), "Element: Linear") <> 0 Then ' 如果标签为Element: Linear,则只取标签后两行 strResultArray(i + 1) = Space(3) & Trim(Replace(strSourceArray(i + 1), "( ) ", "")) strResultArray(i + 2) = Space(3) & Trim(Replace(strSourceArray(i + 2), "( ) ", "")) End If ' 处理Element: Clothoid标签 If InStr(strSourceArray(i), "Element: Clothoid") <> 0 Then ' 如果标签为Element: Clothoid,则只取标签后三行 strResultArray(i + 1) = Space(3) & Trim(Replace(strSourceArray(i + 1), "( ) ", "")) strResultArray(i + 3) = Space(3) & Trim(Replace(strSourceArray(i + 3), "( ) ", "")) strResultArray(i + 6) = Trim(Replace(strSourceArray(i + 6), "Length: ", "")) strResultArray(i + 6) = Space(20) & "LS=" & strResultArray(i + 6) End If ' 处理Element: Circular标签 If InStr(strSourceArray(i), "Element: Circular") <> 0 Then ' 如果标签为Element: Circular,则只取标签后四行 strResultArray(i + 1) = Space(3) & Trim(Replace(strSourceArray(i + 1), "( ) ", "")) strResultArray(i + 3) = Space(3) & Trim(Replace(strSourceArray(i + 3), "( ) ", "")) ' 取得Circular半径的大小 strResultArray(i + 4) = Trim(Replace(strSourceArray(i + 5), "Radius: ", "")) ' 取得Circular半径的符号 If InStr(strSourceArray(i + 6), "Left") <> 0 Then ' 左角为"-" strResultArray(i + 4) = Space(20) & "R=-" & strResultArray(i + 4) ElseIf InStr(strSourceArray(i + 6), "Right") <> 0 Then ' 右角为"+" strResultArray(i + 4) = Space(20) & "R=+" & strResultArray(i + 4) Else ' 若不含"Left" 或者 "Right",提示用户数据出错. strResultArray(i + 4) = Space(3) & "Err! THE THE DATA IS WRONG,PLEASE CHECK IT." End If strResultArray(i + 5) = Space(3) & Trim(Replace(strSourceArray(i + 4), "( ) ", "")) End If Next ' 将相同的两行数据删去最后一行 Dim intLonggest As Integer ' 计算出最长行的字符数以及剔除相等行中的最后一行 intLonggest = 0 For i = 0 To UBound(strResultArray) - 1 ' 选出最长行的字符数 If intLonggest < Len(strResultArray(i)) Then intLonggest = Len(strResultArray(i)) End If ' 剔除相等行中的最后一行 For j = 1 To UBound(strResultArray) - i ' 除了LS=..以外,所有前后行相同的数据只取最后一行 If strResultArray(i) = strResultArray(j + i) And _ InStr(strResultArray(i), "LS") = 0 Then strResultArray(i) = "" End If Next Next ' 构造处理结果扩展文件名,格式如:FlieName_sv1.txt Dim strFullPath As String Dim strShortPath As String Dim strFileName As String strFullPath = Trim(strFName) strShortPath = Left(strFullPath, InStrRev(strFullPath, "/") - 1) strFileName = Mid(strFullPath, InStrRev(strFullPath, "/") + 1, _ InStrRev(strFullPath, ".") - InStrRev(strFullPath, "/") - 1) Open strShortPath & "/" & strFileName & "_sv1.txt" For Output As #1 Print #1, "SETTING OUT DATA FOR S.O.L. " & strHAName & ":" & Chr(13) Print #1, Space(1) & "POINT" & Space(3) & "STATION" & Space(5) & "EASTING" & Space(7) & "NORTHING" _ & Chr(13) For i = 0 To UBound(strResultArray) If strResultArray(i) <> "" Then Print #1, Space(intLonggest - Len(strResultArray(i))) & strResultArray(i) & Chr(13) End If Next Close #1 ' 向DGN文件写入处理后的文本 Dim myCIQ As CadInputQueue Dim myCIM As CadInputMessage Dim pt3Set As Point3d Dim recPnt(0 To 3) As Point3d Dim linPnt(0 To 1) As Point3d Set myCIQ = CadInputQueue myCIQ.SendKeyin "NULL" ShowCommand "Please Select a Point:" ShowPrompt "请选择插入表格的位置" Set myCIM = myCIQ.GetInput(msdCadInputTypeDataPoint, _ msdCadInputTypeReset) Select Case myCIM.InputType Case msdCadInputTypeReset ShowPrompt "" ShowCommand "" Exit Sub Case msdCadInputTypeDataPoint pt3Set = myCIM.point End Select Dim txtTemp As TextElement Dim pt3Temp As Point3d Dim rotMatrix As Matrix3d Dim reTemp As ShapeElement Dim eleTemp As Element ' 输出表标题 pt3Temp.X = pt3Set.X pt3Temp.Y = pt3Set.Y pt3Temp.Z = pt3Set.Z Set txtTemp = CreateTextElement1(Nothing, "SETTING OUT DATA FOR S.O.L. " & strHAName & ":", _ pt3Temp, rotMatrix) txtTemp.TextStyle.Height = TABLE_TITLE_HEIGHT txtTemp.TextStyle.Width = TABLE_TITLE_HEIGHT * WIDTH_RATE txtTemp.Color = TABLE_TITLE_COLOR txtTemp.LineWeight = 4 txtTemp.TextStyle.Justification = msdTextJustificationLeftTop ActiveModelReference.AddElement txtTemp txtTemp.Redraw ' 输出表头" POINT STATION EASTING NORTHING" pt3Temp.Y = pt3Temp.Y - 2 * TABLE_TITLE_HEIGHT Set txtTemp = CreateTextElement1(Nothing, _ Space(1) & "POINT" & Space(3) & "STATION" & Space(5) & "EASTING" & Space(7) & "NORTHING", _ pt3Temp, rotMatrix) txtTemp.TextStyle.Height = TABLE_HEAD_HEIGHT txtTemp.TextStyle.Width = TABLE_HEAD_HEIGHT * WIDTH_RATE txtTemp.Color = TABLE_HEAD_COLOR txtTemp.LineWeight = 2 txtTemp.TextStyle.Justification = msdTextJustificationLeftTop ActiveModelReference.AddElement txtTemp txtTemp.Redraw ' 输出表内容 pt3Temp.Y = pt3Temp.Y - 0.5 * TABLE_HEAD_HEIGHT pt3Temp.Z = pt3Temp.Z For i = 0 To UBound(strResultArray) - 1 If strResultArray(i) <> "" Then ' 如果相邻两行的元素分别为ST及TS , 则将用空行将他们分隔开来 ' pt3Temp.Y = pt3Temp.Y - (1 + TEXT_SPACING_RATE) * TABLE_CONTENT_HEIGHT pt3Temp.Y = pt3Temp.Y - (1 + TEXT_SPACING_RATE) * TABLE_CONTENT_HEIGHT Set txtTemp = CreateTextElement1(Nothing, strResultArray(i), pt3Temp, rotMatrix) txtTemp.TextStyle.Height = TABLE_CONTENT_HEIGHT txtTemp.TextStyle.Width = TABLE_CONTENT_HEIGHT * WIDTH_RATE txtTemp.Color = TABLE_CONTENT_COLOR txtTemp.LineWeight = 2 txtTemp.TextStyle.Justification = msdTextJustificationLeftTop ActiveModelReference.AddElement txtTemp txtTemp.Redraw End If Next i ' 画出表格框架 ' 画出矩形框 recPnt(0).X = pt3Temp.X recPnt(0).Y = pt3Temp.Y - 2 * TABLE_CONTENT_HEIGHT recPnt(0).Z = pt3Temp.Z recPnt(1).X = pt3Set.X recPnt(1).Y = pt3Set.Y - 2 * TABLE_TITLE_HEIGHT + 0.5 * TABLE_HEAD_HEIGHT recPnt(1).Z = pt3Set.Z recPnt(2).X = pt3Set.X + 91 recPnt(2).Y = recPnt(1).Y recPnt(2).Z = pt3Set.Z recPnt(3).X = recPnt(2).X recPnt(3).Y = recPnt(0).Y recPnt(3).Z = pt3Temp.Z Set eleTemp = CreateShapeElement1(Nothing, recPnt) eleTemp.Color = 3 eleTemp.LineWeight = 3 ActiveModelReference.AddElement eleTemp eleTemp.Redraw ' 画出表头横向直线 linPnt(0).X = recPnt(1).X linPnt(0).Y = recPnt(1).Y - 1.5 * TABLE_HEAD_HEIGHT - 0.5 * TABLE_CONTENT_HEIGHT linPnt(0).Z = recPnt(1).Z linPnt(1).X = recPnt(1).X + 91 linPnt(1).Y = linPnt(0).Y linPnt(1).Z = recPnt(0).Z Set eleTemp = CreateLineElement1(Nothing, linPnt) eleTemp.Color = 2 eleTemp.LineWeight = 2 ActiveModelReference.AddElement eleTemp eleTemp.Redraw ' 画出竖向分隔线1 linPnt(0).X = recPnt(1).X + 14 linPnt(0).Y = recPnt(1).Y linPnt(0).Z = recPnt(1).Z linPnt(1).X = recPnt(1).X + 14 linPnt(1).Y = recPnt(0).Y linPnt(1).Z = recPnt(0).Z Set eleTemp = CreateLineElement1(Nothing, linPnt) eleTemp.Color = 2 eleTemp.LineWeight = 2 ActiveModelReference.AddElement eleTemp eleTemp.Redraw ' 画出竖向直线2 linPnt(0).X = recPnt(1).X + 35 linPnt(0).Y = recPnt(1).Y linPnt(0).Z = recPnt(1).Z linPnt(1).X = recPnt(1).X + 35 linPnt(1).Y = recPnt(0).Y linPnt(1).Z = recPnt(0).Z Set eleTemp = CreateLineElement1(Nothing, linPnt) eleTemp.Color = 2 eleTemp.LineWeight = 2 ActiveModelReference.AddElement eleTemp eleTemp.Redraw ' 画出竖向直线3 linPnt(0).X = recPnt(1).X + 64 linPnt(0).Y = recPnt(1).Y linPnt(0).Z = recPnt(1).Z linPnt(1).X = recPnt(1).X + 64 linPnt(1).Y = recPnt(0).Y linPnt(1).Z = recPnt(0).Z Set eleTemp = CreateLineElement1(Nothing, linPnt) eleTemp.Color = 2 eleTemp.LineWeight = 2 ActiveModelReference.AddElement eleTemp eleTemp.Redraw myCIQ.SendKeyin "CHOOSE ELEMENT" Else Exit Sub End If End Sub