MapXtreme 测距功能＋画线，沿线标注

葡萄

开发环境：MapXtreme for Windows
代码：
测距得到长度后，运行创建层操作，添加2个端点，2端点之间画线，然后长度缘线标注
rem-------------------------------测距工具-------------
Function CalcMapDistance(ByVal dblMapX1,ByVal dblMapY1,ByVal dblMapX2,ByVal dblMapY2,ByRef dblDistance)
On Error Resume Next
dblDistance = Session(cMapXObject).Distance(dblMapX1, dblMapY1, dblMapX2, dblMapY2)
CalcMapDistance = True
If Err Then
  CalcMapDistance = False
  If Not HaveError() Then
   SetError "CalcMapDistance", Err.Number, Err.Description
  End If
End If
End Function
if  request("old_x")>0 then
     bRC = ConvertScreenCoordsToMap(request("old_x"), request("old_y"), _
    dblMapX1, dblMapY1)
         bRC = ConvertScreenCoordsToMap(request("new_x"), request("new_y"), _
    dblMapX2, dblMapY2)
            bRC = CalcMapDistance(dblMapX1, dblMapY1, dblMapX2, dblMapY2, dblMapDistance)  ''计算距离
             dblDistanceIn = Round(dblMapDistance,3)
             dhs = dblDistanceIn
end if
rem---------------------------------------测距工具完毕--------

rem----------------------------------------测距划线-----------
on error resume next
Session(SESN_MAPPER).Layers.Remove "text5"
if  request.form("maptool")="col" then
  set lyrTemp=Session(SESN_MAPPER).Layers.CreateLayer("text5", , 1)
  lyrTemp.KeyField = "Geoname"
  lyrTemp.LabelProperties.Style.TextFont.Name = "黑体"
  lyrTemp.LabelProperties.Style.TextFont.Size = 13
  lyrTemp.LabelProperties.Style.TextFont.shadow = True
  lyrTemp.LabelProperties.Style.TextFontHalo = True
  lyrTemp.LabelProperties.Style.TextFontColor = 16711680     'Black
  lyrTemp.LabelProperties.Style.TextFontBackColor = 16777215  'White
  lyrTemp.LabelProperties.Overlap = True
  lyrTemp.LabelProperties.LabelZoom=true
  lyrTemp.LabelProperties.LabelZoomMax = 10000
  lyrTemp.LabelProperties.LabelZoomMin = zoommin1

  lyrTemp.Autolabel = True
  lyrTemp.ZoomLayer = True
  lyrTemp.ZoomMax=zoommax1
  lyrTemp.ZoomMin=zoommin1
  Set Session(SESN_MAPPER).Layers.AnimationLayer = lyrTemp
  bRC = ConvertScreenCoordsToMap(request("old_x"), request("old_y"), X1, Y1)
     bRC = ConvertScreenCoordsToMap(request("new_x"), request("new_y"), X2, Y2)
     call addline(x1,y1,x2,y2,"text5")
  bRc=CreateMapFeature(ftrNewPt)
  ftrNewPt.Attach Session(SESN_MAPPER)
  ftrNewPt.Type = miFeatureTypeSymbol
     ftrNewPt.Style.SymbolCharacter = SCtx
     ftrNewPt.Style.SymbolFont.Name = SFNtx
     ftrNewPt.Style.SymbolFont.Size = SFStx
     ftrNewPt.Style.SymbolFontColor = SFCtx
   ftrNewPt.point.Set x1, y1
   Set ftrAddPt = lyrTemp.AddFeature(ftrNewPt)
   ftrNewPt.point.Set x2, y2
   Set ftrAddPt = lyrTemp.AddFeature(ftrNewPt)
  set lyrTemp=nothing
  set bRc=nothing
end if

function lineobj(x1,y1,x2,y2,byref obj)
   dim pts,style,bresult,objMapX,objCourier
   dim mapx1,mapy1,mapx2,mapy2
   Set objMapX = Session(SESN_MAPPER)
   set objCourier=Session(SESN_COURIER)
   set style=objCourier.createmapxstyle
   mapx1=x1
   mapy1=y1
   mapx2=x2
   mapy2=y2
   set pts=objCourier.createmapxpoints
   pts.addxy mapx1,mapy1,1
   pts.addxy mapx2,mapy2,2
   set obj=objMapX.featurefactory.createline(pts,style)
   obj.Style.LineWidth = 3
   obj.style.linecolor = 255
   obj.keyvalue=dhs&"公里"
   end function
   function addline(x1,y1,x2,y2,layername)
   dim f
   dim bresult,objMapX
   Set objMapX = Session(SESN_MAPPER)
   bresult=lineobj(x1,y1,x2,y2,f)
   objMapX.layers(layername).addfeature f

   end function
rem------------------------------测距划线完毕-----------------