analysis.frm

里面有我用VB二次开发MAPGIS的20个例子

VERSION 5.00
Begin VB.Form TAnalysis 
   Caption         =   "空间分析"
   ClientHeight    =   3195
   ClientLeft      =   165
   ClientTop       =   450
   ClientWidth     =   4680
   Icon            =   "Analysis.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   3195
   ScaleWidth      =   4680
   Begin VB.Menu VectorAnalysis 
      Caption         =   "矢量叠加分析"
      Begin VB.Menu RegToReg 
         Caption         =   "区对区"
      End
      Begin VB.Menu LinToReg 
         Caption         =   "线对区"
      End
      Begin VB.Menu PntToReg 
         Caption         =   "点对区"
      End
      Begin VB.Menu PntToLin 
         Caption         =   "点对线"
      End
      Begin VB.Menu RegToPnt 
         Caption         =   "区对点"
      End
   End
   Begin VB.Menu ClipAnalysis 
      Caption         =   "裁剪分析"
      Begin VB.Menu ClipP 
         Caption         =   "裁剪点"
      End
      Begin VB.Menu ClipL 
         Caption         =   "裁剪线"
      End
      Begin VB.Menu ClipR 
         Caption         =   "裁剪区"
      End
      Begin VB.Menu ClipG 
         Caption         =   "裁剪图形"
      End
   End
   Begin VB.Menu BufferAnalysis 
      Caption         =   "缓冲区分析"
      Begin VB.Menu oneLinBuf 
         Caption         =   "一条线"
      End
      Begin VB.Menu OnePntBuf 
         Caption         =   "一个点"
      End
      Begin VB.Menu OneRegBuf 
         Caption         =   "一个区"
      End
      Begin VB.Menu TolLinBuf 
         Caption         =   "全部线"
      End
      Begin VB.Menu TolPntBuf 
         Caption         =   "全部点"
      End
      Begin VB.Menu TolRegBuf 
         Caption         =   "全部区"
      End
      Begin VB.Menu ListLin 
         Caption         =   "线可变半径"
      End
      Begin VB.Menu ListPnt 
         Caption         =   "点可变半径"
      End
      Begin VB.Menu ListReg 
         Caption         =   "区可变半径"
      End
   End
End
Attribute VB_Name = "TAnalysis"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
 Dim objAnalysis As Analysis
 
Private Sub ClipG_Click()
'...................裁剪图形.........................
Dim objLinArea0 As LinArea
Dim objRegArea1 As RegArea
Dim objRegArea2 As RegArea
Dim radiu As Double
Dim op As Enum_Clip_Type
Dim rtl As Boolean

Set objLinArea0 = New LinArea '裁剪框工作区对象
Set objRegArea1 = New RegArea '被裁剪工作区对象
Set objRegArea2 = New RegArea '结果工作区对象
objLinArea0.Load '装入裁剪框工作区
objRegArea1.Load '装入被裁剪工作区
radiu = 0.0598 '模糊半径
op = gisOVLY_INCLIP '裁剪类型-内
rtl = objAnalysis.ClipRegGraph(objLinArea0, objRegArea1, objRegArea2, radiu, op)

If rtl Then
    MsgBox "裁剪成功"
Else
    MsgBox "裁剪失败"
End If

Set objLinArea0 = Nothing
Set objRegArea1 = Nothing
Set objRegArea2 = Nothing

End Sub

Private Sub ClipL_Click()
'...................裁剪线.........................
Dim objLinArea0 As LinArea
Dim objLinArea1 As LinArea
Dim objLinArea2 As LinArea
Dim radiu As Double
Dim op As Enum_Clip_Type
Dim rtl As Boolean

Set objLinArea0 = New LinArea '裁剪框工作区对象
Set objLinArea1 = New LinArea '被裁剪工作区对象
Set objLinArea2 = New LinArea '结果工作区对象
objLinArea0.Load '装入裁剪框工作区
objLinArea1.Load '装入被裁剪工作区
radiu = 0.0598 '模糊半径
op = gisOVLY_INCLIP '裁剪类型-内
rtl = objAnalysis.ClipLin(objLinArea0, objLinArea1, objLinArea2, radiu, op)

If rtl Then
    MsgBox "裁剪成功"
Else
    MsgBox "裁剪失败"
End If

Set objLinArea0 = Nothing
Set objLinArea1 = Nothing
Set objLinArea2 = Nothing

End Sub

Private Sub ClipP_Click()
'...................裁剪点.........................
Dim objLinArea0 As LinArea
Dim objPntArea1 As PntArea
Dim objPntArea2 As PntArea
Dim radiu As Double
Dim op As Enum_Clip_Type
Dim rtl As Boolean

Set objLinArea0 = New LinArea '裁剪框工作区对象
Set objPntArea1 = New PntArea '被裁剪工作区对象
Set objPntArea2 = New PntArea '结果工作区对象
objLinArea0.Load '装入裁剪框工作区
objPntArea1.Load '装入被裁剪工作区
radiu = 0.0598 '模糊半径
op = gisOVLY_INCLIP  '裁剪类型-内
rtl = objAnalysis.ClipPnt(objLinArea0, objPntArea1, objPntArea2, radiu, op)

If rtl Then
    MsgBox "裁剪成功"
Else
    MsgBox "裁剪失败"
End If

Set objLinArea0 = Nothing
Set objPntArea1 = Nothing
Set objPntArea2 = Nothing

End Sub

Private Sub ClipR_Click()
'...................裁剪区.........................
Dim objLinArea0 As LinArea
Dim objRegArea1 As RegArea
Dim objRegArea2 As RegArea
Dim radiu As Double
Dim op As Enum_Clip_Type
Dim rtl As Boolean

Set objLinArea0 = New LinArea '裁剪框工作区对象
Set objRegArea1 = New RegArea '被裁剪工作区对象
Set objRegArea2 = New RegArea '结果工作区对象
objLinArea0.Load '装入裁剪框工作区
objRegArea1.Load '装入被裁剪工作区
radiu = 0.0598 '模糊半径
op = gisOVLY_INCLIP '裁剪类型-内
rtl = objAnalysis.ClipReg(objLinArea0, objRegArea1, objRegArea2, radiu, op)

If rtl Then
    MsgBox "裁剪成功"
Else
    MsgBox "裁剪失败"
End If

Set objLinArea0 = Nothing
Set objRegArea1 = Nothing
Set objRegArea2 = Nothing
End Sub

Private Sub Form_Load()
Set objAnalysis = New Analysis
End Sub


Private Sub Form_Terminate()
Set objAnalysis = Nothing

End Sub


Private Sub LinToReg_Click()
'...................线对区的叠加.........................
Dim objLinArea0 As LinArea
Dim objRegArea1 As RegArea
Dim objLinArea2 As LinArea
Dim radiu As Double
Dim op As Enum_Overlay_Type
Dim rtl As Boolean

Set objLinArea0 = New LinArea '叠加工作区对象
Set objRegArea1 = New RegArea '被叠加工作区对象
Set objLinArea2 = New LinArea '结果工作区对象
objLinArea0.Load '装入叠加工作区
objRegArea1.Load '装入被叠加工作区
radiu = 0.01 '模糊半径
op = gisOVLY_UNION '叠加类型-并
rtl = objAnalysis.OverlayLinReg(objLinArea0, objRegArea1, objLinArea2, radiu, op)

If rtl Then
    MsgBox "叠加成功"
Else
    MsgBox "叠加失败"
End If

Set objLinArea0 = Nothing
Set objRegArea1 = Nothing
Set objLinArea2 = Nothing

End Sub

Private Sub ListLin_Click()
'...............求指定线可变半径BUFFER区......................

Dim objLinArea As LinArea
Dim r1 As Rad
Dim rBuf As RadSet
Dim i As Integer
Dim objRegArea As RegArea
Dim useMode As Enum_UseMode_Type
Dim knodFlg As Enum_KnobFlg_Type
Dim rtl As Boolean

Set objLinArea = New LinArea
objLinArea.Load  '装入线文件
Set r1 = New Rad
Set rBuf = New RadSet
For i = 1 To 10
r1.i = i '图元号
r1.r = i  '缓冲区半径
rBuf.Append r1
Next i
Set objRegArea = New RegArea '生成区工作区实例
useMode = gisVectMode   '光栅化/矢量化
knodFlg = gisRoundKnob  '圆头/方头
rtl = objAnalysis.ListLinBuffer(objLinArea, rBuf, objRegArea, useMode, knodFlg)
If rtl Then
    MsgBox "线缓冲区生成成功"
Else
    MsgBox "线缓冲区生成失败"
End If

Set r1 = Nothing
Set rBuf = Nothing
Set objLinArea = Nothing
Set objRegArea = Nothing
End Sub

Private Sub ListPnt_Click()
'...............求指定点可变半径BUFFER区......................

Dim objPntArea As PntArea
Dim r1 As Rad
Dim rBuf As RadSet
Dim i As Integer
Dim objRegArea As RegArea
Dim useMode As Enum_UseMode_Type
Dim rtl As Boolean

Set objPntArea = New PntArea
objPntArea.Load '装入点文件
Set r1 = New Rad
Set rBuf = New RadSet
For i = 1 To 10
r1.i = i '图元号
r1.r = i  '缓冲区半径
rBuf.Append r1
Next i
Set objRegArea = New RegArea '生成区工作区实例
useMode = gisVectMode   '光栅化/矢量化
rtl = objAnalysis.ListPntBuffer(objPntArea, rBuf, objRegArea, useMode)
If rtl Then
    MsgBox "线缓冲区生成成功"
Else
    MsgBox "线缓冲区生成失败"
End If

Set r1 = Nothing
Set rBuf = Nothing
Set objPntArea = Nothing
Set objRegArea = Nothing
End Sub

Private Sub ListReg_Click()
'...............求指定区可变半径BUFFER区......................

Dim objRegArea0 As RegArea
Dim r1 As Rad
Dim rBuf As RadSet
Dim i As Integer
Dim objRegArea As RegArea
Dim useMode As Enum_UseMode_Type
Dim rtl As Boolean

Set objRegArea0 = New RegArea
objRegArea0.Load  '装入区文件