frmcreatebuffer.frm

师兄做的一个利用VB结合mapx组件做的超市查询小系统

VERSION 5.00
Begin VB.Form frmCreateBuffer 
   Caption         =   "生成缓冲区"
   ClientHeight    =   2820
   ClientLeft      =   60
   ClientTop       =   450
   ClientWidth     =   4425
   LinkTopic       =   "Form1"
   ScaleHeight     =   2820
   ScaleWidth      =   4425
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton cmdCancel 
      Caption         =   "取消"
      Height          =   375
      Left            =   2640
      TabIndex        =   7
      Top             =   2160
      Width           =   1215
   End
   Begin VB.CommandButton cmdOK 
      Caption         =   "确定"
      Height          =   375
      Left            =   720
      TabIndex        =   6
      Top             =   2160
      Width           =   1215
   End
   Begin VB.CommandButton cmdLayers 
      Caption         =   "..."
      Height          =   375
      Left            =   3720
      TabIndex        =   5
      Top             =   1320
      Width           =   495
   End
   Begin VB.TextBox txtLayers 
      Height          =   375
      Left            =   1920
      TabIndex        =   4
      Text            =   "Temp"
      Top             =   1320
      Width           =   1575
   End
   Begin VB.ComboBox cboUnit 
      Height          =   300
      Left            =   3120
      TabIndex        =   3
      Top             =   630
      Width           =   1095
   End
   Begin VB.TextBox txtDistance 
      Height          =   375
      Left            =   1920
      TabIndex        =   2
      Top             =   600
      Width           =   975
   End
   Begin VB.Label Label3 
      Caption         =   "缓冲区图层："
      Height          =   375
      Left            =   480
      TabIndex        =   1
      Top             =   1440
      Width           =   1215
   End
   Begin VB.Label Label2 
      Caption         =   "缓冲区距离："
      Height          =   375
      Left            =   480
      TabIndex        =   0
      Top             =   720
      Width           =   1215
   End
End
Attribute VB_Name = "FrmCreateBuffer"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Dim oLayer As MapXLib.Layer
Dim FileName As String

Private Sub cmdCancel_Click()
  Unload Me
End Sub

Private Sub cmdLayers_Click()
  Call AddLayer
End Sub

Private Sub cmdok_Click()
  Dim BufferFea As MapXLib.Feature
  Dim FTRS As MapXLib.Features
  Dim FeaFac As FeatureFactory
  Dim Fea As MapXLib.Feature
  Dim Ftr As MapXLib.Feature
  Dim Lyr As MapXLib.Layer
  Dim TempLyr As MapXLib.Layer
  Dim SelectionUnit  As Integer
  Dim i As Integer
  
  If txtDistance.Text = "" Then
    MsgBox "请输入距离", vbInformation
    Exit Sub
  End If
  
  If txtLayers.Text = "Temp" Then
    For i = 1 To frmMain.MapDisp.Layers.Count
        If frmMain.MapDisp.Layers(i).Name = "Temporary Layer" Then
            Set TempLyr = frmMain.MapDisp.Layers.Item("Temporary Layer")
            GoTo AddBuffer
        End If
    Next
    frmMain.CreateTempLayer
    Set TempLyr = frmMain.MapDisp.Layers.Item("Temporary Layer")
  Else
    Set TempLyr = frmMain.MapDisp.Layers.Item(FileName)
  End If

AddBuffer:
  Set FeaFac = frmMain.MapDisp.FeatureFactory
  SelectionUnit = IdentifyUnits
  
  
    For Each Lyr In frmMain.MapDisp.Layers
        If Lyr.Selection.Count <> 0 Then
            Set FTRS = Lyr.Selection.Clone
            Set Ftr = FeaFac.CombineFeatures(FTRS)
            For Each Fea In FTRS
                Set BufferFea = FeaFac.BufferFeatures(Ftr, Val(txtDistance.Text), SelectionUnit)
                TempLyr.AddFeature BufferFea
            Next
        End If
    Next
 
  Unload Me
End Sub

Private Sub Form_Load()
    
  cboUnit.AddItem "Mile"
  cboUnit.AddItem "Kilometer"
  cboUnit.AddItem "Inch"
  cboUnit.AddItem "Foot"
  cboUnit.AddItem "Yard"
  cboUnit.AddItem "Millimeter"
  cboUnit.AddItem "Centimeter"
  cboUnit.AddItem "Meter"
  cboUnit.AddItem "SurveyFoot"
  cboUnit.AddItem "NauticalMile"
  cboUnit.AddItem "Twip"
  cboUnit.AddItem "Point"
  cboUnit.AddItem "Pica"
  cboUnit.AddItem "Degree"
  cboUnit.AddItem "Link"
  cboUnit.AddItem "Chain"
  cboUnit.AddItem "Rod"
  cboUnit.ListIndex = 7
  
End Sub

Private Function IdentifyUnits() As Integer
    Dim Unit As Integer
    
    Select Case cboUnit.ListIndex
        Case 0 ' Miles
            Unit = miUnitMile
        Case 1 ' Kilometers
            Unit = miUnitKilometer
        Case 2 ' Inches
            Unit = miUnitInch
        Case 3 ' Feet
            Unit = miUnitFoot
        Case 4 ' Yards
            Unit = miUnitYard
        Case 5 ' Millimeters
            Unit = miUnitMillimeter
        Case 6 ' Centimeters
            Unit = miUnitCentimeter
        Case 7 ' Meters
            Unit = miUnitMeter
        Case 8 ' Survey Feet
            Unit = miUnitSurveyFoot
        Case 9 ' Nautical Miles
            Unit = miUnitNauticalMile
        Case 10 ' Twips
            Unit = miUnitTwip
        Case 11 ' Points
            Unit = miUnitPoint
        Case 12 ' Picas
            Unit = miUnitPica
        Case 13 ' Degrees
            Unit = miUnitDegree
        Case 14 ' Links
            Unit = miUnitLink
        Case 15 ' Chains
            Unit = miUnitChain
        Case 16 ' Rods
            Unit = miUnitRod
    End Select
    IdentifyUnits = Unit
End Function

Function AddLayer()
  With frmMain.cdlTest
    .DialogTitle = "保存图层"
    .CancelError = True
    .FileName = ""
    .Filter = "mapinfo table(*.tab)|*.tab"
    .ShowSave
    If Len(.FileName) = 0 Then
        MsgBox "请选择图层!"
    End If
  End With
  Me.txtLayers.Text = frmMain.cdlTest.FileTitle
  FileName = Left(frmMain.cdlTest.FileTitle, Len(frmMain.cdlTest.FileTitle) - 4)
  
End Function