ddwordpad.frm

地理信息系统工程案例精选程序,本书所有案例均需要单独配置

        
        Set g_searchShape = Nothing
        Set RecQuery = Map1.Layers(NameToIndex(abProMap.Bands("barStandard").Tools("cmbWork").text)).Records
        frmSQLSearch.InitForm GetActiveLayer
        frmSQLSearch.Show vbModal
    Case "mpMapTips"
        abProMap.Bands("barMapTip").Visible = Not abProMap.Bands("barMapTip").Visible
        Call abProMap_TextChange(abProMap.Bands("barStandard").Tools("cmbWork"))
        
    Case "mpRecord"
        If MsgBox("这可能需要很多时间，是否继续？", vbQuestion + vbOKCancel, "注意") = vbOK Then
        Set g_searchShape = Nothing
        Set RecQuery = Map1.Layers(NameToIndex(abProMap.Bands("barStandard").Tools("cmbWork").text)).Records
        frmSQLSearch.InitForm GetActiveLayer
        frmTrackSearch.InitForm GetActiveLayer
        frmTrackSearch.Show
        End If
    '---------------------------------------------------------------------------
    '以下处理记录添加修改删除
    '---------------------------------------------------------------------------

    Case "mpZDEdit"
        
        abProMap.Bands("barStandard").Tools("mpZDOperate").Checked = True
        
        Map1.MousePointer = moArrow
        SetTipText "请点击所需要修改的记录..."
    Case "mpZDAdd"
        
        abProMap.Bands("barStandard").Tools("mpZDOperate").Checked = True
        
        Map1.MousePointer = moArrow
        SetTipText "请点击需要增加记录的位置..."
    Case "mpZDDel"
        
        abProMap.Bands("barStandard").Tools("mpZDOperate").Checked = True
        
        Map1.MousePointer = moArrow
        SetTipText "请点击所需要删除的记录..."
    Case "mPrint"
    
    
    '---------------------------------------------------------------------------
    '以下处理几何图形查询
    '---------------------------------------------------------------------------

    Case "mqRectangle"
        abProMap.Bands("barStandard").Tools("mpSearchShape").Checked = True
        Map1.MousePointer = moArrow
        SetTipText "请拖动鼠标选择需要查询的矩形区域..."
        
    Case "mqCircle"
        abProMap.Bands("barStandard").Tools("mpSearchShape").Checked = True
        Map1.MousePointer = moArrow
        SetTipText "请拖动鼠标选择需要查询的圆形区域..."
    Case "mqPolygon"
        abProMap.Bands("barStandard").Tools("mpSearchShape").Checked = True
        Map1.MousePointer = moArrow
        SetTipText "请拖动鼠标选择需要查询的多边形区域..."
    Case "mqPoint"
        abProMap.Bands("barStandard").Tools("mpSearchShape").Checked = True
        Map1.MousePointer = moArrow
        SetTipText "请拖动鼠标选择需要查询的点..."
   
    '---------------------------------------------------------------------------
    '以下处理图形测量
    '---------------------------------------------------------------------------
    Case "MeaLength"
        abProMap.Bands("barStandard").Tools("mpMeasure").Checked = True
        Map1.MousePointer = moArrow
        SetTipText "请选择需要测量长度的路线..."
    Case "MeaPerimeter"
        abProMap.Bands("barStandard").Tools("mpMeasure").Checked = True
        Map1.MousePointer = moArrow
        SetTipText "请选择需要测量周长的多边形..."
    Case "MeaArea"
        abProMap.Bands("barStandard").Tools("mpMeasure").Checked = True
        Map1.MousePointer = moArrow
        SetTipText "请选择需要测量面积的多边形..."
    
    Case "MeaPerimeter2"
        abProMap.Bands("barStandard").Tools("mpMeasure").Checked = True
        Map1.MousePointer = moArrow
        SetTipText "请绘制需要测量周长的多边形,双击结束..."
    Case "MeaArea2"
        abProMap.Bands("barStandard").Tools("mpMeasure").Checked = True
        Map1.MousePointer = moArrow
        SetTipText "请绘制需要测量面积的多边形,双击结束..."
    
    
    '-----------------------------------------------------------------------------
    '处理界面上元素是否显示
    '-----------------------------------------------------------------------------
    Case "miVOptions"
        '图层选择窗口和缩略图窗口的显示和隐藏
        abProMap.Bands("barLayer").Visible = Not abProMap.Bands("barLayer").Visible
        abProMap.Refresh
    
    Case "miVToolbar"
        '切换toolbar的显示和隐藏
        abProMap.Bands("barStandard").Visible = Not abProMap.Bands("barStandard").Visible
        
        abProMap.Refresh
        abProMap.Bands("barStandard").Refresh
    Case "miVStatus"
        '切换状态栏的显示和隐藏
        abProMap.Bands("sb").Visible = Not abProMap.Bands("sb").Visible
        abProMap.Refresh
    Case "miVOverall"
        '切换缩略图的显示与隐藏
        If frmLayer.Map2.Visible Then
            Tool.Checked = False
            frmLayer.Map2.Visible = False
            frmLayer.Movebar.Visible = False
            frmLayer.treeLayer.Height = frmLayer.treeLayer.Height + frmLayer.Map2.Height
        Else
            Tool.Checked = True
            frmLayer.Map2.Visible = True
            frmLayer.Movebar.Visible = True
            frmLayer.treeLayer.Height = frmLayer.ScaleHeight * Partition
            frmLayer.Map2.Top = frmLayer.Movebar.Top + frmLayer.Movebar.Height
        End If
    Case "miVRuler"
        '切换比例尺的显示与隐藏
        If FraZoom.Visible Then
            FraZoom.Visible = False
            Tool.Checked = False
        Else
            FraZoom.Visible = True
            Tool.Checked = True
        End If
    Case "mPrint"
        SetTipText "正在打印地图..."
        Map1.PrintMap frmMain.Caption, "", True
        SetTipText "完毕"
   
    Case "miHContents"
        frmLayer.SetFocus
        SendKeys "{F1}"
        Tool.Checked = False
    Case "miHAbout"
        MsgBox "城市交通地理信息系统 Version 1.0" & vbNewLine & vbNewLine & "Copyright (c) 2004 xxx地理信息系统公司" & vbNewLine & "All Right Reserved", vbInformation, "关于"
    
End Select
        
abProMap.RecalcLayout

End Sub

Private Sub Form_Unload(Cancel As Integer)
Unload frmChart
Unload frmInfo
Unload frmLayer
Unload frmModifyData

Unload frmPicture
Unload frmPreview

Unload frmSQLSearch
Unload frmStatistic
Unload frmTrackSearch

End
End Sub
Private Sub Map1_AfterLayerDraw(ByVal Index As Integer, ByVal canceled As Boolean, ByVal hdc As stdole.OLE_HANDLE)
  
  If Index = 0 Then
    ' 在改变主视图以后，改变浏览视图
    frmLayer.Map2.TrackingLayer.Refresh True
    
  End If

End Sub

Private Sub RefleshXY(x As Single, Y As Single)
'鼠标定为以后显示坐标
Dim PointX As New MapObjects2.POINT
Set PointX = Map1.ToMapPoint(x, Y)

abProMap.Bands("sb").Tools("miX").Caption = "(" & Get2Decimal(Str(PointX.x)) & "," & Get2Decimal(Str(PointX.Y)) & ")"
abProMap.Bands("sb").Refresh

End Sub
Public Function Get2Decimal(strNum As String) As String

'保留小数点以后2位小数
Dim lSeek As Long
lSeek = InStrRev(strNum, ".")
If lSeek > 0 And Len(strNum) - lSeek > 2 Then
    Get2Decimal = Mid(strNum, 1, lSeek + 2)
Else
    Get2Decimal = strNum
End If

End Function

Private Sub Map1_AfterTrackingLayerDraw(ByVal hdc As stdole.OLE_HANDLE)
'
  If Not g_HighlightShape Is Nothing Then
    Map1.DrawShape g_HighlightShape, g_HighlightSymbol
  End If
  ' Set the ScaleBar's MapExtent.
  '
  With PicZoom.MapExtent
    .MinX = Map1.Extent.Left
    .MinY = Map1.Extent.Bottom
    .MaxX = Map1.Extent.Right
    .MaxY = Map1.Extent.Top
  End With
  '
  ' Set the ScaleBar's PageExtent.
  '
  With PicZoom.PageExtent
    .MinX = Map1.Left / Screen.TwipsPerPixelX
    .MinY = Map1.Top / Screen.TwipsPerPixelY
    .MaxX = (Map1.Left + Map1.Width) / Screen.TwipsPerPixelX

    .MaxY = (Map1.Top + Map1.Height) / Screen.TwipsPerPixelY
  End With
  '
  ' Refresh the ScaleBar after the Map has changed.
  '
  PicZoom.Refresh

End Sub

Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)

If bLocked Then Exit Sub
Dim RectangleX As MapObjects2.Rectangle
Dim ow As Long
Dim LayerX As MapLayer
Dim PointX As MapObjects2.POINT
Dim MeasureLine As New MapObjects2.Line
Dim MeasurePolygon As New MapObjects2.Polygon

If Button = vbLeftButton And Shift = 0 Then

    Select Case strFunName
        
        
        Case "mpPointer"
        '-----------------------------------------------------------------------------
        '图层的缩放操作
        '-----------------------------------------------------------------------------
        Case "mpZoomin"
            '对图像进行放大
            Set RectangleX = Map1.TrackRectangle
            If Not RectangleX Is Nothing Then
                Set LastExtent = Map1.Extent
                Map1.Extent = RectangleX
            End If
            
        Case "mpZoomout"
            '对图像进行缩小操作
            Set RectangleX = Map1.Extent
            ow = Map1.TrackRectangle.Width
            If (ow > 0) Then
                RectangleX.ScaleRectangle Map1.Extent.Width / ow
            Else
                RectangleX.ScaleRectangle 1.5
            End If
            Set LastExtent = Map1.Extent
            Map1.Extent = RectangleX
        Case "MeaLength"
            
            Set MeasureLine = Map1.TrackLine
            MsgBox "您所测量的线路的长度为" & Get2Decimal(CStr(MeasureLine.Length)) & "米", vbInformation, "测量结果"
            Set MeasureLine = Nothing
        Case "MeaPerimeter"
            Set LayerX = frmMain.Map1.Layers(GetActiveLayer)
            Set PointX = frmMain.Map1.ToMapPoint(x, Y)
            Set RecQuery = LayerX.SearchShape(PointX, moPointInPolygon, "")
            RecQuery.MoveFirst
            If Not RecQuery.EOF Then
                Set MeasurePolygon = RecQuery.Fields("Shape").Value
                frmMain.Map1.FlashShape MeasurePolygon, 1
                MsgBox "您所测量的多边形周长为" & Get2Decimal(CStr(MeasurePolygon.Perimeter)) & "米", vbInformation, "测量结果"
                Set MeasurePolygon = Nothing
            End If
        Case "MeaArea"
            Set LayerX = frmMain.Map1.Layers(GetActiveLayer)
            Set PointX = frmMain.Map1.ToMapPoint(x, Y)
            Set RecQuery = LayerX.SearchShape(PointX, moPointInPolygon, "")
            RecQuery.MoveFirst
            If Not RecQuery.EOF Then
                Set MeasurePolygon = RecQuery.Fields("Shape").Value
                frmMain.Map1.FlashShape MeasurePolygon, 1
                MsgBox "您所测量的多边形面积为" & Get2Decimal(CStr(MeasurePolygon.Area)) & "平方米", vbInformation, "测量结果"
                Set MeasurePolygon = Nothing
            End If
        Case "MeaPerimeter2"
            Set MeasurePolygon = Map1.TrackPolygon
            frmMain.Map1.FlashShape MeasurePolygon, 1
            MsgBox "您所测量的多边形周长为" & Get2Decimal(CStr(MeasurePolygon.Perimeter)) & "米", vbInformation, "测量结果"
            Set MeasurePolygon = Nothing
        
        Case "MeaArea2"
            Set MeasurePolygon = Map1.TrackPolygon
            frmMain.Map1.FlashShape MeasurePolygon, 1
            MsgBox "您所测量的多边形面积为" & Get2Decimal(CStr(MeasurePolygon.Area)) & "平方米", vbInformation, "测量结果"