www.pudn.com > 12136.rar > Form07.frm

VERSION 5.00 
Object = "{9BD6A640-CE75-11D1-AF04-204C4F4F5020}#2.0#0"; "mo20.ocx" 
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "Comdlg32.ocx" 
Begin VB.Form Form07  
   Caption         =   "form" 
   ClientHeight    =   5235 
   ClientLeft      =   60 
   ClientTop       =   345 
   ClientWidth     =   6765 
   LinkTopic       =   "Form1" 
   ScaleHeight     =   5235 
   ScaleWidth      =   6765 
   StartUpPosition =   3  '窗口缺省 
   Begin MSComDlg.CommonDialog CommonDialog1  
      Left            =   1080 
      Top             =   4680 
      _ExtentX        =   847 
      _ExtentY        =   847 
      _Version        =   393216 
   End 
   Begin VB.CommandButton Command1  
      Caption         =   "Command1" 
      Height          =   495 
      Left            =   2760 
      TabIndex        =   1 
      Top             =   4680 
      Width           =   1215 
   End 
   Begin MapObjects2.Map Map1  
      Height          =   4575 
      Left            =   0 
      TabIndex        =   0 
      Top             =   0 
      Width           =   6735 
      _Version        =   131072 
      _ExtentX        =   11880 
      _ExtentY        =   8070 
      _StockProps     =   225 
      BackColor       =   16777215 
      BorderStyle     =   1 
      Contents        =   "Form07.frx":0000 
   End 
End 
Attribute VB_Name = "Form07" 
Attribute VB_GlobalNameSpace = False 
Attribute VB_Creatable = False 
Attribute VB_PredeclaredId = True 
Attribute VB_Exposed = False 
'Xuewei,2003/6/13 
'新建一个polygon图层的示例； 
 
Option Explicit 
 
Dim moSymbol As New MapObjects2.Symbol 
Dim moPolygons As New Collection 
 
Private Sub Command1_Click() 
  Dim gds As MapObjects2.GeoDataset 
  Dim sName As String 
  Dim Desc As New TableDesc 
  Dim dc As New DataConnection 
  Dim Lyr As New MapObjects2.MapLayer 
  Dim lPoly As Long 
   
  If moPolygons.Count < 1 Then 
    MsgBox "先在地图上画多边形" 
    Exit Sub 
  End If 
   
  With CommonDialog1 
    .Filter = "ESRI Shapefiles (*.shp)|*.shp" 
    .DefaultExt = ".shp" 
    .ShowSave 
 
    If Len(.FileName) = 0 Then Exit Sub 
    dc.Database = CurDir 
    If Not dc.Connect Then Exit Sub 
     
    '取掉扩展名； 
    sName = Left(.FileTitle, Len(.FileTitle) - 4) 
  End With 
  MsgBox sName 
 
  With Desc 
    .FieldCount = 3 
 
    '设置字段名； 
    .FieldName(0) = "Name" 
    .FieldName(1) = "Area" 
    .FieldName(2) = "Perimeter" 
 
    '设置字段类型； 
    .FieldType(0) = moString 
    .FieldType(1) = moDouble 
    .FieldType(2) = moDouble 
 
    '设置字段长度； 
    .FieldLength(0) = 16 
    .FieldPrecision(1) = 15 
    .FieldScale(1) = 3 
    .FieldPrecision(2) = 15 
    .FieldScale(2) = 3 
  End With 
 
  Set gds = dc.AddGeoDataset(sName, moPolygon, Desc) 
  If gds Is Nothing Then Exit Sub 
   
  Set Lyr.GeoDataset = gds 
  Map1.Layers.Add Lyr 
  Map1.Refresh 
 
  For lPoly = 1 To moPolygons.Count 
    With Lyr.Records 
      .AddNew 
      .Fields("Shape").Value = moPolygons(lPoly) 
      .Fields("Name").Value = "Name " & lPoly 
      .Fields("Area").Value = moPolygons(lPoly).Area 
      .Fields("Perimeter").Value = moPolygons(lPoly).Perimeter 
      .Update 
    End With 
  Next 
  Lyr.Records.StopEditing 
End Sub 
 
Private Sub Form_Load() 
  With moSymbol 
    .SymbolType = moFillSymbol 
    .Style = moSolidFill 
    .Color = moRed 
  End With 
  Command1.Caption = "保存" 
  Me.Caption = "Shape文件生成" 
End Sub 
 
Private Sub Map1_AfterTrackingLayerDraw(ByVal hDC As stdole.OLE_HANDLE) 
  Dim oPoly As MapObjects2.Polygon 
  If moPolygons.Count <> 0 Then 
    For Each oPoly In moPolygons 
      Map1.DrawShape oPoly, moSymbol 
    Next 
  End If 
End Sub 
 
Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 
  Dim oRect As MapObjects2.Rectangle 
  Dim oPoly As New MapObjects2.Polygon 
     
  Set oPoly = Map1.TrackPolygon 
  moPolygons.Add oPoly 
  Map1.TrackingLayer.Refresh True 
End Sub