frmgeometry.frm

MO+VB的很多个简单示例

VERSION 5.00
Object = "{9BD6A640-CE75-11D1-AF04-204C4F4F5020}#2.0#0"; "Mo20.ocx"
Object = "{BDC217C8-ED16-11CD-956C-0000C04E4C0A}#1.1#0"; "TABCTL32.OCX"
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   6630
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   9765
   LinkTopic       =   "Form1"
   ScaleHeight     =   6630
   ScaleWidth      =   9765
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton btnClear 
      Caption         =   "Command1"
      Height          =   435
      Left            =   7920
      TabIndex        =   6
      Top             =   4140
      Width           =   1635
   End
   Begin VB.Frame Frame1 
      Caption         =   "添加的图形"
      Height          =   1575
      Left            =   7920
      TabIndex        =   2
      Top             =   2160
      Width           =   1635
      Begin VB.OptionButton Option2 
         Caption         =   "多边形"
         Height          =   195
         Left            =   240
         TabIndex        =   4
         Top             =   1020
         Width           =   1275
      End
      Begin VB.OptionButton Option1 
         Caption         =   "线"
         Height          =   255
         Left            =   240
         TabIndex        =   3
         Top             =   480
         Value           =   -1  'True
         Width           =   1215
      End
   End
   Begin MapObjects2.Map Map1 
      Height          =   5595
      Left            =   120
      TabIndex        =   1
      Top             =   480
      Width           =   7635
      _Version        =   131072
      _ExtentX        =   13467
      _ExtentY        =   9869
      _StockProps     =   225
      BackColor       =   16777215
      BorderStyle     =   1
      Contents        =   "frmGeometry.frx":0000
   End
   Begin TabDlg.SSTab SSTab1 
      Height          =   6135
      Left            =   60
      TabIndex        =   0
      Top             =   60
      Width           =   9675
      _ExtentX        =   17066
      _ExtentY        =   10821
      _Version        =   393216
      Tabs            =   4
      Tab             =   3
      TabsPerRow      =   4
      TabHeight       =   520
      TabCaption(0)   =   "差运算"
      TabPicture(0)   =   "frmGeometry.frx":001A
      Tab(0).ControlEnabled=   0   'False
      Tab(0).ControlCount=   0
      TabCaption(1)   =   "交运算"
      TabPicture(1)   =   "frmGeometry.frx":0036
      Tab(1).ControlEnabled=   0   'False
      Tab(1).ControlCount=   0
      TabCaption(2)   =   "并运算"
      TabPicture(2)   =   "frmGeometry.frx":0052
      Tab(2).ControlEnabled=   0   'False
      Tab(2).ControlCount=   0
      TabCaption(3)   =   "异或运算"
      TabPicture(3)   =   "frmGeometry.frx":006E
      Tab(3).ControlEnabled=   -1  'True
      Tab(3).ControlCount=   0
   End
   Begin VB.Label Label1 
      BackColor       =   &H80000002&
      Caption         =   "Label1"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   13.5
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   -1  'True
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H80000018&
      Height          =   375
      Left            =   300
      TabIndex        =   5
      Top             =   6240
      Width           =   9240
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'控件:  1 x MapObjects2.0,  2 x VB Option Buttons
'       1 x Label,          1 x Microsoft Tabbed Dialog Control v6.0,
'       1 x Frame Control,  1 x Command Button

'函数:
'Difference - performs a Difference on two shapes
'Union - performs a Difference on two shapes
'Intersect - performs a Difference on two shapes
'Difference - performs a Difference on two shapes'
'DrawRes - creates a Geoevent on the Map of a result of an operation
'TrackShape - creates a shape from a tracked Line or Polygon

Option Explicit

Dim shape1 As Boolean   '已经获得的第一个几何形状
Dim shp As Object       '跟踪用户第一个输入的几何形状
Dim shp2 As Object      '跟踪用户第二个输入的几何形状

Private Sub btnClear_Click()
  Map1.TrackingLayer.ClearEvents
  Set shp = Nothing
  Set shp2 = Nothing
  shape1 = True
  Label1.Caption = "更新Tracking Layer...无已获得的图形"
End Sub

Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  
  On Error GoTo errorHandler
  '没有获得任何图形，则将跟踪用户输入，并将其存储到shape1中
  If shape1 Then
    Set shp = trackShape
    shape1 = False
    Label1.Caption = "图形一已设置...请设置图形二..."
  '若已获得一个图形，则将跟踪用户输入，并将其存储到shape2中
  Else
    Set shp2 = trackShape
    '执行选定的运算
    If SSTab1.Tab = 0 Then
      Label1.Caption = "图形二已设置...执行差运算..."
      Call Difference(shp, shp2)
    End If
    If SSTab1.Tab = 1 Then
      Label1.Caption = "图形二已设置...执行交运算..."
      Call Intersect(shp, shp2)
    End If
    If SSTab1.Tab = 2 Then
      Label1.Caption = "图形二已设置...执行并运算..."
      Call Union(shp, shp2)
    End If
    If SSTab1.Tab = 3 Then
      Label1.Caption = "图形二已设置...执行异或运算..."
      Call Xor1(shp, shp2)
    End If
    '清空
    Set shp = Nothing
    Set shp2 = Nothing
    shape1 = True
  End If
  
errorHandler:
  If Err = 5001 Then
    Debug.Print Err
    MsgBox "您所输入的几何图形对于当前操作不可用", vbInformation, "运算错误"
  ElseIf Err > 0 Then
    MsgBox "无法识别的错误" & vbNewLine & Err & ", " & Error
    Debug.Print Err
  End If
End Sub

Private Function trackShape() As Object
  '依照用户的选择，在TrackingLayer上创建图形
  If Option1.Value Then
    Dim line As New MapObjects2.line
    Set line = Map1.TrackLine
    Set trackShape = line
    Dim evLine As New MapObjects2.GeoEvent
    Set evLine = Map1.TrackingLayer.AddEvent(line, 1)
  ElseIf Option2.Value Then
    Dim poly As New MapObjects2.Polygon
    Set poly = Map1.TrackPolygon
    Set trackShape = poly
    Dim evPoly As New MapObjects2.GeoEvent
    Set evPoly = Map1.TrackingLayer.AddEvent(poly, 2)
  End If
End Function
Private Sub drawRes(shape As Object)
  '在TrackingLayer上通过添加GeoEvent的方法绘制shape
  Dim res As New MapObjects2.GeoEvent
  If shape.shapeType = moLine Then
    Set res = Map1.TrackingLayer.AddEvent(shape, 4)
  ElseIf shape.shapeType = moShapeTypePolygon Or shape.shapeType = _
        moShapeTypeRectangle Then
    Set res = Map1.TrackingLayer.AddEvent(shape, 3)
  ElseIf shape.shapeType = moShapeTypePoint Or shape.shapeType = _
        moShapeTypeMultipoint Then
    Set res = Map1.TrackingLayer.AddEvent(shape, 5)
  End If
End Sub

Private Sub Difference(firstShape As Object, secondShape As Object)
  '对两个几何对象进行差运算
  Dim diffResult As Object
  Set diffResult = firstShape.Difference(secondShape)
  If Not diffResult Is Nothing Then
    Call drawRes(diffResult)
  Else
    Label1.Caption = "差运算无返回结果..."
  End If
End Sub

Private Sub Intersect(firstShape As Object, secondShape As Object)
  '对两个几何对象进行交运算
  Dim interResult As Object
  Set interResult = firstShape.Intersect(secondShape)
  If Not interResult Is Nothing Then
    Call drawRes(interResult)
  Else
    Label1.Caption = "交运算无返回结果..."
  End If
End Sub

Private Sub Union(firstShape As Object, secondShape As Object)
  '对两个几何对象进行并运算
  Dim unionResult As Object
  Set unionResult = firstShape.Union(secondShape)
  If Not unionResult Is Nothing Then
    Call drawRes(unionResult)
  Else
    Label1.Caption = "并运算无返回结果..."
  End If
End Sub
Private Sub Xor1(firstShape As Object, secondShape As Object)
  '对两个几何对象进行异或运算
  Dim xorResult As Object
  Set xorResult = firstShape.Xor(secondShape)
  If Not xorResult Is Nothing Then
    Call drawRes(xorResult)
  Else
    Label1.Caption = "异或运算无返回结果..."
  End If
End Sub

Private Sub Form_Load()
  
  Option1.Caption = "线"
  Option2.Caption = "多边形"
  btnClear.Caption = "清除输入的图形"
  shape1 = True
  
  '添加一个shape图层作为底图
  '这里使用MapObjects自带的States.shp文件
  '它一般存在于C:\Program Files\ESRI\MapObjects2\Samples\Data\USA处
  Dim dc As New MapObjects2.DataConnection
  dc.Database = "C:\Program Files\ESRI\MapObjects2\Samples\Data\USA"
  If Not dc.Connect Then
    MsgBox "连接错误", vbCritical, "连接错误"
    End
  End If
  
  Dim lyr As New MapObjects2.MapLayer
  Set lyr.GeoDataset = dc.FindGeoDataset("States")
  
  If lyr Is Nothing Then
    MsgBox "找不到需要的图层。", vbCritical, "连接错误"
    End
  Else
    lyr.Symbol.Color = moPaleYellow
    Map1.BackColor = moNavy
    Map1.Layers.Add lyr
    Dim r As New MapObjects2.Rectangle
    Set r = Map1.FullExtent
    Map1.Extent = r
    Map1.ScrollBars = False
  End If
   
  '创建Tracking Layer的符号属性
  Map1.TrackingLayer.SymbolCount = 6
  With Map1.TrackingLayer.Symbol(0)
    .SymbolType = moPointSymbol
    .Style = moTriangleMarker
    .Color = moRed
    .Size = 5
  End With
  With Map1.TrackingLayer.Symbol(1)
    .SymbolType = moLineSymbol
    .Color = moRed
    .Size = 3
  End With
  With Map1.TrackingLayer.Symbol(2)
    .SymbolType = moFillSymbol
    .Style = moGrayFill
    .Color = moRed
    .OutlineColor = moRed
  End With
  With Map1.TrackingLayer.Symbol(3)
    .SymbolType = moFillSymbol
    .Style = moGrayFill
    .Color = moGreen
    .OutlineColor = moGreen
  End With
  With Map1.TrackingLayer.Symbol(4)
    .SymbolType = moLineSymbol
    .Color = moGreen
    .Style = moDotLine
    .Size = 3
  End With
  With Map1.TrackingLayer.Symbol(5)
    .SymbolType = moPointSymbol
    .Style = moTriangleMarker
    .Color = moGreen
    .Size = 5
  End With

End Sub

Private Sub SSTab1_Click(PreviousTab As Integer)
  btnClear_Click
End Sub