ddwordpad.frm

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

            Set MeasurePolygon = Nothing
        Case "mpMove"
            '移动图像
            Map1.MousePointer = moPanning
            Set LastExtent = Map1.Extent
            Map1.Pan
            Map1.MousePointer = moPan
            
        Case "mpInfo"
            '点击图像点上的相应信息
            If frmInfo.ProInfo_GetRecSet(NameToIndex(abProMap.Bands("barStandard").Tools("cmbWork").text), x, Y) Then
                If Not frmInfo.Visible Then
                    frmInfo.Show
                Else
                    frmInfo.SetFocus
                End If
            End If
            
        Case "mqRectangle"
            '查询所选矩形区域中的所有点的信息
            Call hProcess_SearchByShape(byRectangle)
            
        Case "mqCircle"
            '查询所选圆形区域中的所有点的信息
            Call hProcess_SearchByShape(byCircle)
            
        Case "mqPolygon"
             '查询所选多边形区域中的所有点的信息
            Call hProcess_SearchByShape(byPolygon)
            
        Case "mqPoint"
            '搜索点附近的所有信息
            Call hProcess_SearchByShape(byPoint, x, Y)
        
        Case "mpZDAdd"
            '添加记录
            Call hProcess_MapEditor(NameToIndex(abProMap.Bands( _
                "barStandard").Tools("cmbWork").text), Add, x, Y)
        Case "mpZDEdit"
            '编辑记录
            Call hProcess_MapEditor(NameToIndex(abProMap.Bands( _
                "barStandard").Tools("cmbWork").text), Edit, x, Y)
        Case "mpZDDel"
            '删除记录
            Call hProcess_MapEditor(NameToIndex(abProMap.Bands( _
                "barStandard").Tools("cmbWork").text), Del, x, Y)
    End Select
Else
    If Button = vbLeftButton And Shift <> 0 Then
        '鼠标右键平移地图
        Map1.Pan
    Else
        If Button = vbLeftButton And Shift = 0 Then
        Else
            Set RectangleX = Map1.TrackRectangle
            If Not RectangleX Is Nothing Then Map1.Extent = RectangleX
                
        End If
    End If
    
End If

End Sub
Private Sub Form_Load()

'设置activebar的主窗口，附属窗口
abProMap.ClientAreaControl = Map1
m_mapTip.Initialize Map1, tmrTip, PicTip, lblTip

Set abProMap.Bands("barLayer").Tools("frmLayer").Custom = frmLayer
Call fnLoadProjectFile(App.Path & "\data\promap")
bIsConfig = True
modDefinition.Search_PointTolerance = 100
AssertAllTool

End Sub

Sub AssertButton_barStandard()
Attribute AssertButton_barStandard.VB_Description = "根据软件情况刷新abPromap"

abProMap.Bands("barStandard").Tools("mpPointer").Checked = False
abProMap.Bands("barStandard").Tools("mpMove").Checked = False
abProMap.Bands("mnuEx").Tools("mnumpMove").Checked = False
abProMap.Bands("barStandard").Tools("mpZoomin").Checked = False
abProMap.Bands("mnuEx").Tools("mnumpZoomin").Checked = False
abProMap.Bands("barStandard").Tools("mpZoomout").Checked = False
abProMap.Bands("mnuEx").Tools("mnumpZoomout").Checked = False
abProMap.Bands("barStandard").Tools("mpInfo").Checked = False
abProMap.Bands("mnuQuest").Tools("mnumpInfo").Checked = False
abProMap.Bands("barStandard").Tools("mpMeasure").Checked = False
abProMap.Bands("barStandard").Tools("mpSearchShape").Checked = False
abProMap.Bands("barStandard").Tools("mpZDOperate").Checked = False

End Sub

Private Sub Map1_MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single)
    Call RefleshXY(x, Y)
    If abProMap.Bands("barMapTip").Visible Then m_mapTip.MouseMove x, Y
End Sub

Private Sub PicHide_Click()
FraZoom.Visible = False
abProMap.Bands("mnuView").Tools("miVRuler").Checked = False
End Sub

Private Sub hProcess_SearchByShape(g_searchType As SearchTYPE, _
    Optional x As Single, Optional Y As Single)

DoEvents
Select Case g_searchType
    Case SearchTYPE.byPoint
        '点查询
        Set g_searchShape = Map1.ToMapPoint(x, Y)
        Call GetDataset(NameToIndex(abProMap.Bands( _
            "barStandard").Tools("cmbWork").text), byPoint)
    Case SearchTYPE.byCircle
        '圆形查询
        Set g_searchShape = Map1.TrackCircle
        Call GetDataset(NameToIndex(abProMap.Bands( _
            "barStandard").Tools("cmbWork").text), byCircle)
    Case SearchTYPE.byPolygon
        '多边形查询
        Set g_searchShape = Map1.TrackPolygon
        Call GetDataset(NameToIndex(abProMap.Bands( _
            "barStandard").Tools("cmbWork").text), byPolygon)
    Case SearchTYPE.byRectangle
        '矩形查询
        Set g_searchShape = Map1.TrackRectangle
        Call GetDataset(NameToIndex(abProMap.Bands( _
            "barStandard").Tools("cmbWork").text), byPolygon)
End Select

'无限制条件
g_searchExpression = ""
'查询结果高亮显示
'Call HighLightShape(GetActiveLayer, RecQuery)
frmSQLSearch.InitForm (GetActiveLayer)
'显示查询结果
frmTrackSearch.InitForm (GetActiveLayer)
frmTrackSearch.Show
End Sub
Private Sub hProcess_MapEditor(Index As Long, _
    EditType As ModifyTYPE, x As Single, Y As Single)

'关闭MapTips功能
'否则由于共享访问可能不能修改数据
abProMap.Bands("barMapTip").Visible = False
Call abProMap_TextChange(abProMap.Bands("barStandard").Tools("cmbWork"))
'断开数据连接
RemoveAllRelation

Dim LayerX As MapLayer
Dim bIsLocate As Boolean
Dim AddShape As Object
Dim IDNumber As Long
Set LayerX = Map1.Layers(Index)
Set RecModify = LayerX.Records

'获取一个新的ID号,用于唯一标识某记录
IDNumber = RecModify.CalculateStatistics("SID").Max + 1

If EditType = Add Then
    '填加新记录
    bIsLocate = True
Else
    '编辑记录
    '则定为到这个要编辑的记录
    bIsLocate = fnLocatePointInRec(x, Y, _
        LayerX.shapeType = moShapeTypePolygon)
End If

'判断是否定可以编辑
If RecModify.Updatable Then
    '是否定为到指定记录
    If bIsLocate Then
        Select Case EditType
            Case ModifyTYPE.Edit
                '编辑记录
                '显示当前记录的所有属性信息
                frmModifyData.InitForm (GetActiveLayer)
                frmModifyData.Show
            Case ModifyTYPE.Add
                '根据当前层的类型,填加图形
                Select Case LayerX.shapeType
                    Case moShapeTypePoint
                        '添加点
                        Dim PointX As New MapObjects2.POINT
                        Set PointX = Map1.ToMapPoint(x, Y)
                        Set AddShape = PointX
                    Case moShapeTypeLine
                        '添加线
                        Dim LineX As New MapObjects2.Line
                        '地图上跟踪用户输入的折线
                        Set LineX = Map1.TrackLine
                        Set AddShape = LineX
                    Case moShapeTypePolygon
                        '添加多边形
                        Dim PolygonX As New MapObjects2.Polygon
                        '地图上跟踪用户输入的多边形
                        Set PolygonX = Map1.TrackPolygon
                        Set AddShape = PolygonX
                End Select
                '添加几何图形
                RecModify.AddNew
                '将几何图形添加到数据库中
                Set RecModify.Fields("Shape").Value = AddShape
                RecModify.Fields("SID").Value = IDNumber
                RecModify.Update
                '修改记录完毕一定要StopEditing
                RecModify.StopEditing
                
                If CustomLayers(Index).RelationCount > 0 Then
                    '在连接的数据库中添加相应信息
                    Data1.DatabaseName = CustomLayers(Index).Relation(0).Database
                    Data1.RecordSource = CustomLayers(Index).Relation(0).Table
                    Data1.Refresh
                    Data1.Recordset.AddNew
                    Data1.Recordset.Fields("SID").Value = IDNumber
                    Data1.Recordset.Update
                    Data1.DatabaseName = ""
                    Data1.Refresh
                End If
                
                Map1.RefreshLayer Index
                
                If fnLocatePointInRec(x, Y) Then
                    '修改属性数据
                    frmModifyData.InitForm (GetActiveLayer)
                    frmModifyData.Show
                End If
                
            Case ModifyTYPE.Del
                '删除数据
                If MsgBox("本操作将会删除当前点，是否继续？", vbExclamation + vbOKCancel, "注意") = vbOK Then
                    
                    If CustomLayers(Index).RelationCount > 0 Then
                        '删除连接的数据库中相应记录
                        Data1.DatabaseName = CustomLayers(Index).Relation(0).Database
                        Data1.RecordSource = "select * from " & CustomLayers(Index).Relation(0).Table & " where SID=" & RecModify.Fields("SID").ValueAsString
                        Data1.Refresh
                        If Not Data1.Recordset.EOF Then
                            Data1.Recordset.Delete
                        End If
                    End If
                    '删除数据
                    RecModify.Delete
                    '同样需要StopEditing
                    RecModify.StopEditing
                    Set RecModify = Nothing
                    '重新添加所有到外部数据库表的连接
                    AddAllRelation
                    Map1.Refresh
                End If
        End Select
    End If
Else
    MsgBox "当前层不可更新数据，请重试。", vbInformation, "注意"
End If

End Sub

Public Function GetActiveLayer() As Long
GetActiveLayer = NameToIndex(abProMap.Bands("barStandard").Tools("cmbWork").text)
End Function

'----------------------------------------------------------------------------------------------
'以下代码处理ProgressBar
'----------------------------------------------------------------------------------------------
Public Sub SetTipText(strText As String)
abProMap.Bands("sb").Tools("miStatus").Caption = strText
abProMap.RecalcLayout

End Sub
Public Sub Progress_SetValue(Value As Long, Sum As Long)
abProMap.Bands("sb").Tools("miProgress1").Caption = CStr(CLng(Value / Sum * 100)) & "%"
If Value / Sum > 0.99 Then
    abProMap.Bands("sb").Tools("miProgress1").Width = 1000
    abProMap.Bands("sb").Tools("miProgress2").Width = 0
    abProMap.Bands("sb").Tools("miProgress2").Visible = False
Else
    abProMap.Bands("sb").Tools("miProgress1").Width = CLng(Value / Sum * 1000)
    abProMap.Bands("sb").Tools("miProgress2").Width = CLng((1 - Value / Sum) * 1000)
End If

abProMap.RecalcLayout
End Sub

Public Sub Progress_Enable()

abProMap.Bands("sb").Tools("miProgress2").Visible = True
bLocked = True
End Sub
Public Sub Progress_Disable()
Progress_SetValue 1, 1
bLocked = False
End Sub

Private Sub tmrTip_Timer()
m_mapTip.Timer
End Sub