测量线段长度

Option Explicit
Dim dc As New DataConnection '数据源
Dim layer As MapLayer '图层变量
Dim strscale As String '记录比例尺，决定注记是否显示
Dim cnt As Integer '测距
Dim pts As mapobjects2.Points '画线测距离定义点
Dim g_line As mapobjects2.Line '画线测距离定义线
Dim poly As mapobjects2.Polygon '画多边形测周长和面积定义多边形Dim p As mapobjects2.Point
Public Sub LayerLoad(Map As Map)
Set layer = New MapLayer '动态申请一个图层变量
layer.GeoDataset = dc.FindGeoDataset("省界_region") '加入第一个图层layer.Symbol.Color = RGB(255, 255, 190)
layer.Symbol.OutlineColor = RGB(255, 255, 190)
yers.Add layer
End Sub
Private Sub Map1_AfterTrackingLayerDraw(ByValhdc As stdole.OLE_HANDLE) Dim sym As New Symbol '在map1上画线或多边形
Dim symstr As New Symbol '鼠标移动选中的街道的符号
Dim i As Long
If Not g_line Is Nothing And Not pts Is Nothing Then
sym.Color = moBlack
Map1.DrawShape pts, sym
If pts.Count> 1 Then
sym.Color = moRed
Map1.DrawShape g_line, sym
End If
ElseIf Not poly Is Nothing And Not pts Is Nothing Then
sym.Color = moBlue
Map1.DrawShape pts, sym
If pts.Count> 1 Then
sym.Color = moRed
sym.SymbolType = moFillSymbol
sym.Style = 7
sym.Size = 1
Map1.DrawShape poly, sym
End If
End If
End Sub
Private Sub Map1_DblClick()
'双击求线长和面积
If Toolbar1.Buttons(1).Value = 1 Then
MsgBox "距离=" & Format(g_line.Length, "0.00") & "米"
Set pts = Nothing '再次测定时清除上次所画痕迹
Set g_line = Nothing
End If
Map1.TrackingLayer.Refresh True
End Sub
Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim r As mapobjects2.Rectangle
If Toolbar1.Buttons(1).Value = 1 Then
'点击左键，则实现画直线测距离
If Button = vbLeftButton Then
'量距离
Dim p1 As mapobjects2.Point
If g_lineIs Nothing Then
Set g_line = New mapobjects2.Line
End If
If ptsIs Nothing Then
Set pts = New mapobjects2.Points
End If
Set p1 = Map1.ToMapPoint(X, Y)
pts.Add p1
If pts.Count = 1 Then
g_line.Parts.Addpts
Set pts = g_line.Parts(0)
End If
Map1.Refresh
End If
End If
End If
End Sub
Private Sub Map1_AfterLayerDraw(ByVal Index As Integer, ByVal canceled As Boolean, ByValhdc As stdole.OLE_HANDLE)
'量测距离时画点
If Not pts Is Nothing Then
If pts.Count>= 1 Then
Dim sym2 As New Symbol
sym2.Color = moBlue
sym2.SymbolType = moPointSymbol
sym2.Size = 5
Map1.DrawShape pts, sym2
End If
End If
'量测距离时画线
Dim sym As New Symbol
If Not g_line Is Nothing Then
If pts.Count> 1 Then
sym.Color = moRed
sym.SymbolType = moLineSymbol
sym.Size = 1
Map1.DrawShape g_line, sym
End If
End If
End Sub
Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button) If Toolbar1.Buttons(1).Value = 1 Then '点击测距图标
Set pts = Nothing
Set poly = Nothing
Map1.MousePointer = moCross
End If
End Sub
Private Sub Form_Load() '关联数据源
Form1.Move 0, 0
dc.Database = App.Path
If Not dc.ConnectThen
MsgBox "该文件夹下不存在满足条件的文件"
End
End If
LayerLoad Map1 '向map1中加载图层
End Sub。