buildmap.bas

一个交通专用的gis-T系统

Attribute VB_Name = "BuildMap"
'*********************************************************************
'*
'*                本源码完全免费，共交通同仁学习参考                 *
'*                      www.tranbbs.com                              *
'*                   Developed by Yang Ming                          *
'*       Nanjing Institute of City Transportation Planning           *
'*                 请保留本版权信息，谢谢合作                        *
'*                      中国交通技术论坛                             *
'*                                                                   *
'*                                                                   *
'*********************************************************************
Public Sub Build()
 
Dim Sqlsel As String
Dim Lyr As mapxlib.Layer
   
Load FrmProgress
FrmProgress.Show

        '绘制路网
        
        Dim rs As Recordset
        Set rs = mDbBiblio.OpenRecordset("nodes", dbOpenDynaset)

        rs.MoveFirst
        Do Until rs.EOF
            If allnodenum < Val(rs("Nodeid")) Then
                allnodenum = Val(rs("Nodeid"))
            End If
            rs.MoveNext
        Loop
        
        ReDim NodesCoriX(1 To allnodenum)
        ReDim NodesCoriY(1 To allnodenum)
        
        rs.MoveFirst
        Do Until rs.EOF
            NodesCoriX(rs("NodeId")) = rs("NodeX")
            NodesCoriY(rs("NodeId")) = rs("NodeY")
            rs.MoveNext
        Loop
        rs.Close
        
       '画节点
        Set Lyr = Main.Mapshow.Layers.Item("Node")
        Lyr.Editable = True
        
        Main.Mapshow.Bounds = Lyr.Bounds

        
        Dim ds As mapxlib.Dataset
        Dim Rvs As New RowValues
        Dim Rv As New RowValue
        
        Dim ProgressV
        ProgressV = 0
        step = 100 / allnodenum
                
        For i = 1 To allnodenum
        
            If NodesCoriX(i) <> 0 And NodesCoriY(i) <> 0 Then
            
                Dim NodeI As New Point
                Dim ObjNewFeature As New Feature
                Dim ObjFeature As Feature
                
                NodeI.Set NodesCoriX(i), NodesCoriY(i)
                Set ObjNewFeature = Main.Mapshow.FeatureFactory.CreateCircularRegion(1, NodeI, NodeRadius, 7, 32)
                Set ObjFeature = Lyr.AddFeature(ObjNewFeature)
                ObjFeature.Style.RegionColor = NodeColor
                Lyr.Refresh
                
                Lyr.KeyField = "NodeId"
                ObjFeature.KeyValue = i
                ObjFeature.Update
                
               
            End If
            
                ProgressV = ProgressV + step
                Call Progress(ProgressV, "绘制节点图，")
       
        Next
        
       
        Set Lyr = Main.Mapshow.Layers.Item("Link")
        Main.Mapshow.Bounds = Lyr.Bounds
      
        Set rs = mDbBiblio.OpenRecordset("links", dbOpenDynaset)
        rs.MoveLast

        alllinknum = rs.RecordCount
        step = 100 / alllinknum
        ProgressV = 0
        
        
        rs.MoveFirst
        i = 0

        

        '琢点绘制线路
        Do Until rs.EOF
            
                '判断点的属性，如果是形心点就不画
                Dim Rsnode As Recordset
                Set Rsnode = mDbBiblio.OpenRecordset("select * from Nodes where NodeId=" & rs("NodeI"))
                
                If Rsnode.RecordCount > 0 Then
                
'                    If RsNode("NodeType") <> "a*" Then
                
                        Dim DrawLine As mapxlib.Feature
                        Dim Ftr As mapxlib.Feature
                        Dim ps As New Points
                        Dim P As New Point
                        
                        ps.RemoveAll
                        
                        P.Set NodesCoriX(rs("NodeI")), NodesCoriY(rs("NodeI"))
                        ps.Add P
                        P.Set NodesCoriX(rs("NodeJ")), NodesCoriY(rs("NodeJ"))
                        ps.Add P
                        
                        Set Ftr = Main.Mapshow.FeatureFactory.CreateLine(ps)
                        Ftr.Style.LineStyle = 1
                        Ftr.Style.LineWidth = LinkWidth
                        
                        Ftr.Style.LineColor = LinkColor
                        Set DrawLine = Lyr.AddFeature(Ftr)
                        
                        Lyr.KeyField = "LinkId"
                        DrawLine.KeyValue = rs("LinkId")
                        DrawLine.Update
                    
'                    End If
                    
                End If
                    
                    rs.MoveNext
                    i = i + 1
                    ProgressV = ProgressV + step
                    
                    Call Progress(ProgressV, "绘制路网图，")
                
        Loop
        
        Main.Mapshow.Bounds = Lyr.Bounds
       
        Unload FrmProgress
    
End Sub