modquest.bas

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

Attribute VB_Name = "ModQuest"
Function fnLocatePointInRecEx(x As Single, Y As Single) As Boolean
'判定当前图层指定点附近是否有几何对象
'若存在,则将数据游标指向这条记录

If RecModify Is Nothing Then
    fnLocatePointInRecEx = False
    Exit Function
End If

Dim PointX As MapObjects2.POINT
PointX.x = x
PointX.Y = Y

RecModify.MoveFirst

If RecModify.EOF Then
    fnLocatePointInRecEx = False
    Exit Function
End If

Dim sNearestDistance As Single
Dim lSeek As Long
lSeek = 0
Dim lpointer As Long
lpointer = 0
sNearestDistance = PointX.DistanceTo(RecModify.Fields("Shape").Value)

Do Until RecordX.EOF
    '逐一判断是否满足条件
    If PointX.DistanceTo(RecModify.Fields("Shape").Value) < sNearestDistance Then
        If PointX.DistanceTo(RecModify.Fields("Shape").Value) < frmMain.Map1.ToMapDistance(100) Then
            sNearestDistance = PointX.DistanceTo(RecModify.Fields("Shape").Value)
            lSeek = lpointer
        End If
    End If
    
    RecModify.MoveNext
    lpointer = lpointer + 1
Loop

If sNearestDistance > frmMain.Map1.ToMapDistance(100) Then
    '不存在满足条件的记录
    fnLocatePointInRecEx = False
    Exit Function
End If

RecModify.MoveFirst
For lpointer = 1 To lSeek
    RecModify.MoveNext
    DoEvents
Next lpointer
fnLocatePointInRecEx = True

End Function
Function fnLocatePointInRec(x As Single, Y As Single, Optional bIsPolygon As Boolean = False) As Boolean
'判定当前图层指定点附近是否有几何对象
'若存在,则将数据游标指向这条记录

If RecModify Is Nothing Then
    fnLocatePointInRec = False
    Exit Function
End If

Dim PotX As New MapObjects2.POINT
Dim PolygonX As MapObjects2.Polygon
Set PotX = frmMain.Map1.ToMapPoint(x, Y)

RecModify.MoveFirst

If RecModify.EOF Then
    fnLocatePointInRec = False
    Exit Function
End If

Do Until RecModify.EOF
    If Not IsNull(RecModify.Fields("Shape").Value) Then
        '判断是不是多边形
        If Not bIsPolygon Then
            '判断是否满足条件
            If PotX.DistanceTo(RecModify.Fields("Shape").Value) < frmMain.Map1.ToMapDistance(100) Then
                '闪烁图形
                frmMain.Map1.FlashShape RecModify.Fields("Shape").Value, 2
                Exit Do
            End If
        Else
            Set PolygonX = RecModify.Fields("Shape").Value
            '判断是否满足条件
            If PolygonX.IsPointIn(PotX) Then
                '闪烁图形
                frmMain.Map1.FlashShape RecModify.Fields("Shape").Value, 2
                Exit Do
            End If
        End If
    End If
    DoEvents
    RecModify.MoveNext
Loop
    
If RecModify.EOF Then
    fnLocatePointInRec = False
Else
    fnLocatePointInRec = True
End If

End Function
Public Sub GetDataset(ByVal Index As String, g_searchType As SearchTYPE)
'------------------------------------------------------------------------------
'根据搜索条件生成搜索结果g_searchset
'2002-10-15:修改判定,以g_searchType存储集合搜索时几何图形的类型
'           且改进点查询时的查寻范围
'------------------------------------------------------------------------------
Dim LayerX As MapLayer
Set LayerX = frmMain.Map1.Layers(Index)


If Not (g_searchShape Is Nothing) Then
    '几何图形查询
    Select Case g_searchType
        Case SearchTYPE.byPoint
            Set RecQuery = LayerX.SearchByDistance(g_searchShape, frmMain.Map1.ToMapDistance(modDefinition.Search_PointTolerance), g_searchExpression)
        Case SearchTYPE.byCircle
            Set RecQuery = LayerX.SearchByDistance(g_searchShape.Center, g_searchShape.Width * 0.5, g_searchExpression)
        Case SearchTYPE.byPolygon
            Set RecQuery = LayerX.SearchShape(g_searchShape, 7, g_searchExpression)
        Case SearchTYPE.byExpression
            Set RecQuery = LayerX.SearchExpression(g_searchExpression)
    End Select
Else
    '条件查询
    Set RecQuery = LayerX.SearchExpression(g_searchExpression)
End If
End Sub

Public Function GetLayerIndex(LayerName As String) As Long

Dim lpLayer As Long
For lpLayer = 0 To frmMain.Map1.Layers.Count - 1
    If InStr(1, frmMain.Map1.Layers(lpLayer).Name, LayerName) > 0 Then Exit For
Next
If lpLayer >= frmMain.Map1.Layers.Count Then
    GetLayerIndex = 0
Else
    GetLayerIndex = lpLayer
End If

End Function