form1.frm

使用VB和MAPX开发的一个比较通用的实例程序

         Width           =   2295
      End
      Begin MSComctlLib.Toolbar tbToolBar 
         Height          =   420
         Left            =   0
         TabIndex        =   1
         Top             =   600
         Width           =   6690
         _ExtentX        =   11800
         _ExtentY        =   741
         ButtonWidth     =   609
         ButtonHeight    =   582
         Appearance      =   1
         ImageList       =   "imlToolbarIcons"
         _Version        =   393216
         BeginProperty Buttons {66833FE8-8583-11D1-B16A-00C0F0283628} 
            NumButtons      =   6
            BeginProperty Button1 {66833FEA-8583-11D1-B16A-00C0F0283628} 
               Key             =   "Open"
               Object.ToolTipText     =   "Open"
               ImageIndex      =   1
            EndProperty
            BeginProperty Button2 {66833FEA-8583-11D1-B16A-00C0F0283628} 
               Key             =   "Save"
               Object.ToolTipText     =   "Save"
               ImageIndex      =   2
            EndProperty
            BeginProperty Button3 {66833FEA-8583-11D1-B16A-00C0F0283628} 
               Style           =   3
            EndProperty
            BeginProperty Button4 {66833FEA-8583-11D1-B16A-00C0F0283628} 
               Key             =   "Print"
               Object.ToolTipText     =   "Print"
               ImageIndex      =   3
            EndProperty
            BeginProperty Button5 {66833FEA-8583-11D1-B16A-00C0F0283628} 
               Style           =   3
            EndProperty
            BeginProperty Button6 {66833FEA-8583-11D1-B16A-00C0F0283628} 
               Key             =   "Copy"
               Object.ToolTipText     =   "Copy"
               ImageIndex      =   4
            EndProperty
         EndProperty
      End
   End
   Begin VB.Menu f 
      Caption         =   "文件(&F)"
      Begin VB.Menu f1 
         Caption         =   "打开表"
      End
      Begin VB.Menu f2 
         Caption         =   "关闭表"
      End
      Begin VB.Menu f3 
         Caption         =   "打开GEOSET"
      End
      Begin VB.Menu f4 
         Caption         =   "关闭GEOSET"
      End
      Begin VB.Menu f5 
         Caption         =   "-"
      End
      Begin VB.Menu f6 
         Caption         =   "关闭"
      End
   End
   Begin VB.Menu v 
      Caption         =   "视图(&V)"
      Begin VB.Menu v1 
         Caption         =   "放大"
      End
      Begin VB.Menu v2 
         Caption         =   "缩小"
      End
      Begin VB.Menu v3 
         Caption         =   "漫游"
      End
      Begin VB.Menu v4 
         Caption         =   "中心显示"
      End
      Begin VB.Menu v5 
         Caption         =   "全图显示"
      End
      Begin VB.Menu pp 
         Caption         =   "-"
      End
      Begin VB.Menu ls 
         Caption         =   "某层全图显示"
      End
   End
   Begin VB.Menu s 
      Caption         =   "选择(&S)"
      Begin VB.Menu s1 
         Caption         =   "单个选择"
      End
      Begin VB.Menu s2 
         Caption         =   "多边形选择"
      End
      Begin VB.Menu s3 
         Caption         =   "圆形选择"
      End
      Begin VB.Menu s4 
         Caption         =   "矩形选择"
      End
   End
   Begin VB.Menu t 
      Caption         =   "专地图(&T)"
   End
   Begin VB.Menu b 
      Caption         =   "标注(&B)"
      Begin VB.Menu b1 
         Caption         =   "自动标注"
      End
      Begin VB.Menu b2 
         Caption         =   "手工标注"
      End
      Begin VB.Menu b3 
         Caption         =   "移去标注"
      End
      Begin VB.Menu b4 
         Caption         =   "选择标注字段"
      End
   End
   Begin VB.Menu d 
      Caption         =   "数据绑定(&D)"
   End
   Begin VB.Menu k 
      Caption         =   "图层控制(&K)"
   End
   Begin VB.Menu a 
      Caption         =   "加图元(&A)"
      Begin VB.Menu a1 
         Caption         =   "加线"
      End
      Begin VB.Menu a2 
         Caption         =   "加点"
      End
      Begin VB.Menu a3 
         Caption         =   "加面"
      End
      Begin VB.Menu a4 
         Caption         =   "加文本"
      End
      Begin VB.Menu a5 
         Caption         =   "加折线"
      End
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Private Sub a1_Click()
Map1.Layers.Item(lname).Editable = True
Set Map1.Layers.InsertionLayer = Map1.Layers.Item(lname)
Map1.CurrentTool = miAddLineTool
End Sub

Private Sub a2_Click()
Map1.Layers.Item(lname).Editable = True
Set Map1.Layers.InsertionLayer = Map1.Layers.Item(lname)
Map1.CurrentTool = miAddPointTool
End Sub

Private Sub a3_Click()
Map1.Layers.Item(lname).Editable = True
Set Map1.Layers.InsertionLayer = Map1.Layers.Item(lname)
Map1.CurrentTool = miAddRegionTool
End Sub

Private Sub a4_Click()
Map1.Layers.Item(lname).Editable = True
Set Map1.Layers.InsertionLayer = Map1.Layers.Item(lname)
Map1.CurrentTool = miTextTool
End Sub

Private Sub a5_Click()
Map1.Layers.Item(lname).Editable = True
Set Map1.Layers.InsertionLayer = Map1.Layers.Item(lname)
Map1.CurrentTool = miAddPolylineTool
End Sub

Private Sub b1_Click()
Dim ly As Layer
For Each ly In Map1.Layers
ly.AutoLabel = True
Next ly
End Sub

Private Sub b2_Click()
Map1.CurrentTool = miLabelTool
End Sub

Private Sub b3_Click()
Dim ly As Layer
For Each ly In Map1.Layers
ly.AutoLabel = False
ly.ClearCustomLabels
Next ly
End Sub

Private Sub b4_Click()
If d.Enabled = True Then
MsgBox ("你还没有数据绑定")
Else
biaozhu.Show
End If
End Sub

Private Sub Combo1_Click()
 lname = Combo1.Text
Dim i As Integer
tname = Mid$(Map1.Layers.Item(lname).Filespec, Len(App.Path + "\MAP\") + 1)
i = Len(tname) - 4
tname = Left$(tname, i)
Text1.Text = "当前层：" + lname
Adodc1.RecordSource = "select * from " + tname
Set DataGrid1.DataSource = Adodc1
Adodc1.Refresh
DataGrid1.Refresh
Dim ly As Layer
End Sub

Private Sub d_Click()
Dim ly As Layer
For Each ly In Map1.Layers
Map1.Datasets.Add miDataSetLayer, ly, ly.Name, , , ly '数据绑定
Next ly
d.Enabled = False
End Sub

Private Sub DataGrid1_Click()
flag = True
If flag Then
Dim str1 As String
Dim fs As Feature
DataGrid1.Col = 0
str1 = DataGrid1.Text
For Each fs In Map1.Layers.Item(lname).AllFeatures
If fs.FeatureID = str1 Then
 Map1.Layers.Item(lname).Selection.ClearSelection
 Map1.Layers.Item(lname).Selection.SelectByID fs.FeatureID, 0
 Map1.CenterX = fs.CenterX
 Map1.CenterY = fs.CenterY
End If
Next fs
End If
End Sub

Private Sub f1_Click()
On Error Resume Next
With CommonDialog1
.DialogTitle = "打开表"
.Filter = "TAB文件|*.TAB|所有文件|*.*"
.FilterIndex = 1
.ShowOpen
If .FileName <> "" Then
Map1.Layers.Add .FileName, 1 '如果你要在哪一层打开，就改“1”
End If
End With
End Sub

Private Sub f2_Click()
closeform.Show
End Sub

Private Sub f3_Click()
On Error Resume Next
With CommonDialog1
.DialogTitle = "打开GEOSET"
.Filter = "GEOSET文件|*.gst|所有文件|*.*"
.FilterIndex = 1
.ShowOpen
If .FileName <> "" Then
Map1.Geoset = .FileName
End If
End With
End Sub

Private Sub f4_Click()
Map1.Geoset = ""
End Sub

Private Sub f6_Click()
End
End Sub

Private Sub Form_Load()
Map1.Geoset = App.Path + "\MAP\MAP.gst" '把生成的GEOSET文件给它
lname = Map1.Layers.Item(1).Name
Dim i As Integer
tname = Mid$(Map1.Layers.Item(lname).Filespec, Len(App.Path + "\MAP\") + 1)
i = Len(tname) - 4
tname = Left$(tname, i)
Adodc1.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" + App.Path + "\库\data.mdb;Persist Security Info=False" '添加数据库
Adodc1.RecordSource = "select * from " + tname
Adodc1.Refresh
Dim ly As Layer
For Each ly In Map1.Layers
Combo1.AddItem ly.Name
Next ly
Combo1.ListIndex = 0
Text1.Text = "当前层：" + Combo1.Text
Set DataGrid1.DataSource = Adodc1
End Sub

Private Sub k_Click()
Map1.Layers.LayersDlg
End Sub

Private Sub ls_Click()
Form2.Show
End Sub

Private Sub Map1_Click()
flag = False
End Sub

Private Sub Map1_SelectionChanged()
If Not flag Then
Dim fs As Feature
Dim str As String
str = ""
For Each fs In Map1.Layers.Item(lname).Selection
str = str + "or " + " MAPINFO_ID= " & fs.FeatureID
Next fs
If str <> "" Then '开始进行属性数据查找
str = Mid$(str, 4)
Adodc1.RecordSource = "select * from " + tname + " where " + str
Adodc1.Refresh
DataGrid1.Refresh
End If
End If
End Sub
Private Sub s1_Click()
Map1.CurrentTool = miSelectTool
End Sub

Private Sub s2_Click()
Map1.CurrentTool = miPolygonSelectTool
End Sub

Private Sub s3_Click()
Map1.CurrentTool = miRadiusSelectTool
End Sub

Private Sub s4_Click()
Map1.CurrentTool = miRectSelectTool
End Sub

Private Sub t_Click()
If d.Enabled = True Then
MsgBox ("你还没数据绑定")
Else
theme.Show
End If
End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
 On Error Resume Next
    Select Case Button.Key
        Case "Arrow"
    Map1.CurrentTool = miArrowTool
        Case "Zoom In"
    Map1.CurrentTool = miZoomInTool
        Case "Zoom Out"
    Map1.CurrentTool = miZoomOutTool
        Case "Pan"
     Map1.CurrentTool = miPanTool
        Case "Ruler"
        Map1.CurrentTool = RulerToolID
       Case "poly"
       Map1.CurrentTool = PolyRulerToolID
        Case "Select"
     Map1.CurrentTool = miSelectTool
        Case "Select Rectangle"
    Map1.CurrentTool = miRectSelectTool
        Case "Select Radius"
     Map1.CurrentTool = miRadiusSelectTool
        Case "Select Polygon"
    Map1.CurrentTool = miPolygonSelectTool
        Case "Label"
    Map1.CurrentTool = miLabelTool
        Case "Add Symbol Annotation"
   Map1.CurrentTool = miSymbolTool
        Case "Add Text Annotation"
   Map1.CurrentTool = miTextTool
   Case "help"
    End Select
End Sub

Private Sub v1_Click()
Map1.CurrentTool = miZoomInTool
End Sub

Private Sub v2_Click()
 Map1.CurrentTool = miZoomOutTool
End Sub

Private Sub v3_Click()
Map1.CurrentTool = miPanTool
End Sub

Private Sub v4_Click()
Map1.CurrentTool = miCenterTool
End Sub

Private Sub v5_Click()
Set Map1.Bounds = Map1.Layers.Item(1).Bounds
End Sub