|
|
菜鸟一只，请大神们看下面代码：
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
关键是红色部分，没有红色部分时能够运行，加入红色部分后提示对象关闭时不允许操作，怎么解决呢？原来写这个代码的时候也出现过这问题，我把部分语句调了下位置就可以运行了，但这个菜鸟级的方法太盲目，请大神们指点。 |
|
置顶卡
