求一个能对多线段及曲线自动标上桩号的程序
hfjhfj
hfjhfj Lv.2
2008年12月19日 10:52:36
来自于行业脉动
只看楼主

求一个能对多线段及曲线自动标上桩号的程序,要求能自行设定桩距、自定义字体,字体要与线段方向铅直。希望有这种程序的人给我发一下,谢谢

求一个能对多线段及曲线自动标上桩号的程序,要求能自行设定桩距、自定义字体,字体要与线段方向铅直。希望有这种程序的人给我发一下,谢谢
免费打赏
tongmingniao
2009年03月11日 00:03:10
2楼
楼主的意思桩号是不是要旋转90度,并且所有的桩号在一条水平线上,所有的桩号等间距?
按此思路编的dvb程序如下:
Option Base 1
Option Explicit

Private Sub CommandButton1_Click()
UserForm1.Hide

On Error Resume Next
Dim excelApp As Excel.Application
Set excelApp = GetObject(, "Excel.Application")
If Err Then
MsgBox Err.Description
Exit Sub
End If

ForceForegroundWindow excelApp.hWnd

Dim myRange As Range
Set myRange = excelApp.InputBox(Prompt:="选择要求的单元格区域:", Type:=8)

If Err Then
MsgBox Err.Description
Exit Sub
End If

Dim M As Long
Dim N As Long
M = myRange.Rows.Count
N = myRange.Columns.Count

ReDim textObj(M, N) As AcadText
ReDim TextStr(M, N) As String

Dim i As Long
Dim j As Long
For i = 1 To M
For j = 1 To N
TextStr(i, j) = myRange.Cells(i, j).Text
Next
Next

ForceForegroundWindow AcadApplication.hWnd

Dim InsertPnt As Variant
InsertPnt = ThisDrawing.Utility.GetPoint(, "指定插入点: ")

Dim VDistOfText As Double
Dim HDistOfText As Double
Dim TextHeight As Double
VDistOfText = Val(TextBox1.Text)
HDistOfText = Val(TextBox2.Text)
TextHeight = Val(TextBox3.Text)

Dim Pnt As Variant
For i = 1 To M
For j = 1 To N
If TextStr(i, j) <> "" Then
Set textObj(i, j) = ThisDrawing.ModelSpace.AddText(TextStr(i, j), InsertPnt, TextHeight)
Pnt = textObj(i, j).InsertionPoint
Pnt(0) = InsertPnt(0) + (j - 1) * HDistOfText
Pnt(1) = InsertPnt(1) - (i - 1) * VDistOfText
textObj(i, j).InsertionPoint = Pnt
textObj(i, j).Rotation = 4 * Atn(1) * Val(TextBox4.Text) / 180
End If
Next
Next

ThisDrawing.Regen acActiveViewport
UserForm1.Show
End Sub

Private Sub CommandButton2_Click()
End
End Sub

Private Sub UserForm_Initialize()
TextBox1.Text = 0
TextBox2.Text = 50
TextBox3.Text = 5
TextBox4.Text = 90
End Sub


程序运行界面:
20090310235942140.png
列偏移为桩号文字在cad图中的间距,桩号文字横放在excel表格中。
回复

相关推荐

APP内打开