- 积分
- 111
- 明经币
- 个
- 注册时间
- 2011-11-4
- 在线时间
- 小时
- 威望
-
- 金钱
- 个
- 贡献
-
- 激情
-
|
本人菜鸟一只,学与编同时进行,请大神们看下面代码:
Public Sub ReadDatabase()
Dim layer As AcadLayer
Dim util As New clsLayerUtility
If Not util.NewLayer("里程标", layer) Then
MsgBox "创建图层失败"
End If
Dim color As New AcadAcCmColor
color.ColorIndex = acWhite
layer.TrueColor = color
util.SetCurrentLayer ("里程标")
Dim con As New ADODB.Connection
con.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & GetCurrentDvbFilePath() & "Database\point.mdb"
Dim rstPoly As New ADODB.Recordset
rstPoly.Open "Select [PolylineID] From Polyline", con, adOpenDynamic, adLockOptimistic
While Not rstPoly.EOF
Dim rstVerts As New ADODB.Recordset
Dim sql As String
sql = "Select [里程]From Point Where [PointID] In (Select [PointID] From PolylinePoint Where PolylineID = " & CStr(rstPoly.Fields(0)) & ")"
rstVerts.Open sql, con, adOpenDynamic, adLockOptimistic
Dim verts As New cls2dPointArray
Dim vert(0 To 1) As Double
Dim a As Single, j As Single
a = CDbl(rstVerts.Fields("里程")) - 910
While Not rstVerts.EOF
SetPoint2d vert, CDbl(rstVerts.Fields("里程")) - a, 245
j = CDbl(rstVerts.Fields("里程"))
verts.Append vert
rstVerts.MoveNext
Wend
rstVerts.Close
Dim mspace As New clsModelSpace
mspace.AddLWPolyline verts.toarray()
rstPoly.MoveNext
Wend
'画竖线
Dim i As Single, k As Single
k = j - a
For i = 910 To k Step 10
Dim lcbz As AcadLine
Dim lcbzsp(0 To 2) As Double, lcbzep(0 To 2) As Double
SetPoint3d lcbzsp, i, 245, 0
SetPoint3d lcbzep, i, 244, 0
Set lcbz = ThisDrawing.ModelSpace.AddLine(lcbzsp, lcbzep)
Next i
' 写数字
Dim lcbx(0 To 2) As Double, lcby(0 To 2) As Double
Dim kongge As String, m As Integer, biaozhu As String
If Not rstVerts.EOF Then
If j Mod 1000 = 0 Then
m = Int(j / 1000)
ElseIf j Mod 100 = 0 Then
m = Int((j - Int(j / 1000) * 1000) / 100)
biaozhu = m
End If
kongge = " "
SetPoint3d lcbx, 910, 242, 0
SetPoint3d lcby, k, 244, 0
mspace.AddTextInRectangle lcbx, lcby, biaozhu & kongge
rstVerts.MoveNext
End If
rstPoly.Close
con.Close
End Sub
这个画里程标注的代码,为了标注里程数字,我加了红色部分,但是一直提示对象关闭时不允许操作,怎么解决呢?
|
|