frmmain.frm

都是基于VB所做的程序集合,值得大家作为实践的参考资料.

VERSION 5.00
Object = "{03ED3B1E-ED1B-4A2E-8FE3-D8D1A673F5D4}#5.2#0"; "SuperMap.ocx"
Begin VB.Form frmMain 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "Buffer分析"
   ClientHeight    =   7080
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   10245
   Icon            =   "frmMain.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   7080
   ScaleWidth      =   10245
   StartUpPosition =   2  'CenterScreen
   Begin SuperMapLib.SuperWorkspace SuperWorkspace 
      Left            =   3660
      Top             =   3000
      _Version        =   327682
      _ExtentX        =   847
      _ExtentY        =   847
      _StockProps     =   0
   End
   Begin SuperMapLib.SuperMap SuperMap 
      Height          =   2715
      Left            =   0
      TabIndex        =   8
      Top             =   480
      Width           =   2415
      _Version        =   327682
      _ExtentX        =   4260
      _ExtentY        =   4789
      _StockProps     =   160
   End
   Begin VB.CommandButton btnSelect 
      Caption         =   "选择"
      Height          =   375
      Left            =   3300
      TabIndex        =   7
      Top             =   38
      Width           =   1065
   End
   Begin VB.CommandButton btnBuffer 
      Caption         =   "生成Buffer"
      Height          =   375
      Left            =   5430
      TabIndex        =   6
      Top             =   38
      Width           =   1065
   End
   Begin VB.ComboBox cmbQueryWay 
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   9.75
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   360
      Left            =   7575
      Style           =   2  'Dropdown List
      TabIndex        =   5
      Top             =   45
      Width           =   2625
   End
   Begin VB.CommandButton btnAnalyse 
      Caption         =   "分析"
      Height          =   375
      Left            =   6495
      TabIndex        =   4
      Top             =   38
      Width           =   1065
   End
   Begin VB.CommandButton btnViewEntire 
      Caption         =   "全幅显示"
      Height          =   375
      Left            =   4365
      TabIndex        =   3
      Top             =   38
      Width           =   1065
   End
   Begin VB.CommandButton btnPan 
      Caption         =   "平移"
      Height          =   375
      Left            =   2235
      TabIndex        =   2
      Top             =   38
      Width           =   1065
   End
   Begin VB.CommandButton btnZoomFree 
      Caption         =   "自由缩放"
      Height          =   375
      Left            =   1140
      TabIndex        =   1
      Top             =   38
      Width           =   1095
   End
   Begin VB.CommandButton btnLine 
      Caption         =   "量算距离"
      Height          =   375
      Left            =   45
      TabIndex        =   0
      Top             =   38
      Width           =   1095
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'=====================================SuperMap Objects示范工程说明=======================================
'
'功能简介：示范SuperMap的查询分析功能(QueryEx)和创建缓冲区的功能。
'所用控件：SuperMap控件和SuperWorkspace控件。
'所用数据：..\Data\BufferQueryEx\data.sdb和data.sdd文件
'操作说明：
'        1、单击"自由缩放"、"平移"、"选择"、"全幅显示"可以进行地图基本操作。
'        2、单击"量算"可以量算两点间的距离。
'        3、选择好一个对象(一个点或一个面)，单击"生成Buffer"，可以生成该对象的Buffer缓冲区(其半径在程序中给定，可以修改)。
'        4、选定好下拉列表框的项，单击"分析"按提示可以进行相应的分析。
'
'===================================SuperMap Objects示范工程说明结束=====================================

Option Explicit
Dim bAnalyse As Boolean

Private Function QueryAnalyse(objGeometry As soGeometry) As Boolean
    Dim objDtVector As soDatasetVector
    Dim objRecordset As soRecordset
    
    '取得要对其进行分析的数据集(一定是矢量数据集)
    '本图中只有两个图层，所以可以这样去取，若有多个则不行。
    If SuperMap.Layers(1).Dataset.Type = scdPoint Then
        Set objDtVector = SuperMap.Layers(1).Dataset
    Else
        Set objDtVector = SuperMap.Layers(2).Dataset
    End If
    If objDtVector Is Nothing Then
        MsgBox "打开数据集失败！", vbInformation, "示范"
        Exit Function
    Else
        '进行查询分析
        Set objRecordset = objDtVector.QueryEx(objGeometry, scsContaining, "")
    End If
    
    If objRecordset Is Nothing Then
        MsgBox "打开记录集失败！", vbInformation, "示范"
        QueryAnalyse = False
        Exit Function
    Else
        If objRecordset.RecordCount = 0 Then
            MsgBox "没有符合条件的对象！", vbInformation, "示范"
            QueryAnalyse = True
        Else
            SuperMap.selection.RemoveAll
            Set SuperMap.selection.Dataset = objDtVector
            SuperMap.selection.FromRecordset objRecordset  '高亮显示结果
            SuperMap.Refresh
            QueryAnalyse = True
        End If
    End If
End Function

Private Sub btnLine_Click()                   '量算两点间的距离
    bAnalyse = False
    SuperMap.Action = scaTrackLinesect      '在TrackingLayer图层上画直线
End Sub

Private Sub btnZoomFree_Click()               '自由缩放
    SuperMap.Action = scaZoomFree
End Sub

Private Sub btnPan_Click()                    '地图平移
    SuperMap.Action = scaPan
End Sub

Private Sub btnViewEntire_Click()             '全幅显示
    SuperMap.ViewEntire
End Sub

Private Sub btnAnalyse_Click()                '分析
    SuperMap.TrackingLayer.ClearEvents
    
    If cmbQueryWay.ListIndex = 0 Then            '落入指定范围内的点
        MsgBox "请在图上选择一个面！", vbInformation, "示范"
        SuperMap.Action = scaSelect
        bAnalyse = True
    Else                                    '落入线段一定范围内的点
        MsgBox "请在图上画一条折线，单击右键结束画线！", vbInformation, "示范"
        bAnalyse = True
        SuperMap.TrackingLayer.ClearEvents
        SuperMap.Action = scaTrackPolyline
    End If
End Sub

Private Sub btnBuffer_Click()                 '生成Buffer
    Dim objGeometry As soGeometry
    Dim objGeoRegion As soGeoRegion
    Dim objGeoPoint As soGeoPoint
    Dim objRecordset As soRecordset
    Dim objStyle As New soStyle
    
    SuperMap.TrackingLayer.ClearEvents
    
    With objStyle
        .BrushStyle = 2
        .BrushBackTransparent = True
        .PenColor = vbDesktop
        .PenWidth = 7
    End With
    
    If SuperMap.selection.Count = 0 Then
        MsgBox "请先在图中选择一个对象！", vbInformation, "示范"
    Else
        Set objRecordset = SuperMap.selection.ToRecordset(True)
        Set objGeometry = objRecordset.GetGeometry()
        If objGeometry.Type = scgPoint Then
            Set objGeoPoint = objGeometry
            Set objGeoRegion = objGeoPoint.Buffer(20, 40)
        ElseIf objGeometry.Type = scgRegion Then
            Set objGeoRegion = objGeometry
            Set objGeoRegion = objGeoRegion.Buffer(20, 40)
        End If
        
        If objGeometry Is Nothing Then
            MsgBox "错误！", vbInformation, "示范"
        Else
            SuperMap.TrackingLayer.AddEvent objGeoRegion, objStyle, ""
            SuperMap.Refresh
        End If
    End If
    
    Set objStyle = Nothing
End Sub

Private Sub btnSelect_Click()
      '选择
    bAnalyse = False
    SuperMap.Action = scaSelect
End Sub

Private Sub Form_Load()
    SuperMap.Connect SuperWorkspace.Handle   '建立SuperMap与SuperWorkspace之间的联系
    
    Dim objDS As soDataSource
    Dim i As Integer
    
    Set objDS = SuperWorkspace.OpenDataSource(App.Path & "\..\Data\BufferQueryEx\Data.sdb", "Data", sceSDBPlus, False)
    If objDS Is Nothing Then
        MsgBox "打开数据源文件错误！" & vbCrLf & "请检查程序和文件！", vbInformation, "示范"
        End
    Else
        '把数据源中的所有数据集都加入到SuperMap中，显示出来
        For i = 1 To objDS.Datasets.Count
            SuperMap.Layers.AddDataset objDS.Datasets(i), False
        Next
    End If
    
    SuperMap.MarginPanEnable = False         '关闭SuperMap的自动滚屏功能(默认为打开)
    cmbQueryWay.AddItem "落入指定范围内的点"
    cmbQueryWay.AddItem "落入线段一定范围内的点"
    cmbQueryWay.ListIndex = 0
End Sub

Private Sub Form_Resize()
    SuperMap.Width = Me.ScaleWidth - 2 * SuperMap.Left
    SuperMap.Height = Me.ScaleHeight - SuperMap.Top - 40
End Sub

Private Sub Form_Unload(Cancel As Integer)
    SuperMap.Close
    SuperMap.Disconnect
    SuperWorkspace.Close
End Sub

Private Sub SuperMap_GeometrySelected(ByVal nSelectedGeometryCount As Long)
    Dim objGeometry As soGeometry
    Dim objRecordset As soRecordset
    
    If bAnalyse = False Then Exit Sub
    Set objRecordset = SuperMap.selection.ToRecordset(True)
    If objRecordset Is Nothing Then
        MsgBox "错误！", vbInformation, "示范"
        Exit Sub
    Else
        objRecordset.MoveFirst
        Set objGeometry = objRecordset.GetGeometry()
    End If
    If objGeometry Is Nothing Then
        MsgBox "错误！", vbInformation, "示范"
    Else
        If QueryAnalyse(objGeometry) = False Then
            MsgBox "分析失败！", vbInformation, "示范"
        End If
    End If
End Sub

Private Sub SuperMap_Tracked()
    Dim objGeoLine As soGeoLine
    Dim objGeoRegion As soGeoRegion
    Dim objStyle As New soStyle
    
    SuperMap.TrackingLayer.ClearEvents
    
    With objStyle
        .BrushStyle = 1
        .PenColor = vbActiveTitleBar
        .PenWidth = 5
    End With
    
    Set objGeoLine = SuperMap.TrackedGeometry  '取得所画的对象(此处为线对象)
    If bAnalyse = False Then                   '量算距离
        If Not (objGeoLine Is Nothing) Then
            MsgBox "线长：" & objGeoLine.Length, vbInformation, "示范"
        End If
    Else                                       '进行分析;生成所画线的缓冲区
        Set objGeoRegion = objGeoLine.Buffer(40, 40)
        '上一行代码中，第一个40，表示线两侧40长度单位(如40米)的范围，此值可以参考量算得到的值。
        '第二个40表示生成范围时，以(40段折线/圆)来模拟圆弧。
        If objGeoRegion Is Nothing Then
            MsgBox "错误！", vbInformation, "示范"
        Else
            '显示所画的线，objStyle参数为显示风格，见前面的设定
            SuperMap.TrackingLayer.AddEvent objGeoLine, objStyle, ""
            '显示所画的线的范围
            SuperMap.TrackingLayer.AddEvent objGeoRegion, objStyle, ""
            If QueryAnalyse(objGeoRegion) = False Then
                MsgBox "分析失败！", vbInformation, "示范"
            End If
        End If
    End If
    
    Set objStyle = Nothing
End Sub