basform.frm

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

VERSION 5.00
Begin VB.Form BasWorkArea 
   Caption         =   "基本工作区"
   ClientHeight    =   4290
   ClientLeft      =   165
   ClientTop       =   735
   ClientWidth     =   6960
   FillColor       =   &H00FFFFFF&
   Icon            =   "BasForm.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   4290
   ScaleWidth      =   6960
   StartUpPosition =   3  'Windows Default
   Begin VB.Menu PntWorkArea 
      Caption         =   "Pnt工作区操作"
      Begin VB.Menu LoadSavePntFile 
         Caption         =   "加载,保存点文件"
      End
      Begin VB.Menu AddUptDelPnt 
         Caption         =   "添加,更新,删除点"
      End
      Begin VB.Menu GetSetPntInfo 
         Caption         =   "取,设点工作区信息"
      End
      Begin VB.Menu CopyPntArea 
         Caption         =   "工作区之间实体拷贝"
      End
      Begin VB.Menu QueryNearPnt 
         Caption         =   "查找工作区最近点"
      End
      Begin VB.Menu PartToList 
         Caption         =   "拷贝部分实体到IDList"
      End
      Begin VB.Menu TicDotMethod 
         Caption         =   "控制点(Tic)存取函数"
      End
   End
   Begin VB.Menu LinWorkArea 
      Caption         =   "Lin工作区操作"
      Begin VB.Menu AddUptDeLin 
         Caption         =   "添加,更新,删除线"
      End
      Begin VB.Menu GetDatLen 
         Caption         =   "取线，线数据长度"
      End
      Begin VB.Menu QueryNearLin 
         Caption         =   "查找工作区最近线"
      End
   End
   Begin VB.Menu RegWorkArea 
      Caption         =   "Reg工作区操作"
      Begin VB.Menu GetorCalMethod 
         Caption         =   "Reg工作区中有关计算"
      End
      Begin VB.Menu RegQuery 
         Caption         =   "Reg中Seek,IsDotIn用法"
      End
      Begin VB.Menu AddUptDelReg 
         Caption         =   "添加,更新,删除区"
      End
      Begin VB.Menu GetAreaInf 
         Caption         =   "取区域各种信息"
      End
      Begin VB.Menu UnionSplitMath 
         Caption         =   "合并,分裂,匹配区域"
      End
   End
   Begin VB.Menu NetWorkArea 
      Caption         =   "Net工作区操作"
      Begin VB.Menu AddUptDelNet 
         Caption         =   "网络实体操作"
      End
      Begin VB.Menu AllocArcprj 
         Caption         =   "弧段分配方案"
      End
      Begin VB.Menu NetPathOper 
         Caption         =   "网络路径操作"
      End
      Begin VB.Menu NetNodOper 
         Caption         =   "网络结点操作"
      End
   End
   Begin VB.Menu TblWorkArea 
      Caption         =   "Tbl工作区操作"
      Begin VB.Menu AttStruOper 
         Caption         =   "属性结构操作"
      End
      Begin VB.Menu AttOperMethod 
         Caption         =   "属性操作方法"
      End
      Begin VB.Menu RcdOperMethod 
         Caption         =   "记录操作方法"
      End
      Begin VB.Menu FieldOperMethod 
         Caption         =   "字段操作方法"
      End
      Begin VB.Menu ModAllMethod 
         Caption         =   "字段统改方法"
      End
      Begin VB.Menu CopyRecord 
         Caption         =   "拷贝属性方法"
      End
   End
End
Attribute VB_Name = "BasWorkArea"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'全局变量声明
Dim bRes As Boolean
Dim lRes As Long
Dim nRes As Integer

Private Sub AddUptDeLin_Click()
Dim LinAi As New LinArea
Dim pos As New D_DotSet
Dim pos3d As New D_3DotSet
Dim inf As Lin_Info
Dim dimen As Integer

'打开一个线文件
If Not LinAi.Load Then
Exit Sub
End If

'初始化要添加的2D线
pos.Append 50, 50
pos.Append 150, 150
'取得第一条线的信息，先判断是否存在
If LinAi.GetExistFlag(1) <> 1 Then
Exit Sub
End If
If LinAi.GetInfo(1, inf) Then
'1. 添加一条线
lRes = LinAi.Append(pos, inf)
End If
'返回最后的线号
Debug.Print "当前工作区有"; lRes; "条线!"

'初始化要添加的3D线
pos3d.Append 100, 100, 0
pos3d.Append 200, 200, 0
'仅为方便，线信息不变,
'2. 添加一条线
lRes = LinAi.Append3D(pos3d, inf)

'这里假设把线颜色号改变一下
inf.lclr = 10
'3. 更新第一条线的线信息,忽略返回值
bRes = LinAi.UpdateInfo(1, inf)

'改变线位置
pos(1).x = 80
pos(1).y = 80
pos(1).x = 180
pos(1).y = 180
pos3d(0).x = 20
pos3d(0).y = 20
pos3d(1).x = 120
pos3d(1).y = 120

'以下更新前面添加的线实体
'4. 更新线实体(2D)
bRes = LinAi.Update(lRes - 1, pos, inf)
'5. 更新线实体(3D)
bRes = LinAi.Update3D(lRes, pos3d, inf)

'6. 删除线实体
LinAi.Del lRes - 1
LinAi.Del lRes

'7.撤消删除的线实体
If LinAi.GetExistFlag(lRes - 1) = -1 Then
LinAi.UnDel lRes - 1
End If

Set inf = Nothing
Set pos = Nothing
Set pos3d = Nothing
Set LinAi = Nothing
End Sub

Private Sub AddUptDelNet_Click()
Dim NetAi As New NetArea
Dim ndat As LONGList
Dim pos As D_DotSet
Dim NetInfo As Net_Info
Dim LinDat As LinData
Dim LinInfo As Lin_Info
Dim ni As Long

'打开网文件
If Not NetAi.Load Then
Exit Sub
End If

'1. 取网络,ndat得到网段号集合
If NetAi.GetExistFlag(1) Then
nRes = NetAi.Get(1, ndat, NetInfo)
End If
If nRes <> 1 Then
Exit Sub
End If

'2. 更新网络实体图形信息
nRes = NetAi.GetInfo(1, NetInfo)

'3. 添加网络实体
'取得线数据
Set LinDat = NetAi.Lin

'构造一个网络(此处为相交的两条线)
Set pos = New D_DotSet
pos.Append 50, 50
pos.Append 50, 100
'假设取第一条线的信息为添加的线信息
bRes = LinDat.GetInfo(1, LinInfo)
'添加一条网段
If bRes Then
lRes = LinDat.Append(pos, LinInfo)
End If
pos.RemoveAll
pos.Append 25, 75
pos.Append 75, 75
lRes = LinDat.Append(pos, LinInfo)
'添加上面的网段号
ndat.Append lRes - 1
ndat.Append lRes

'添加一个网,返回网络号
'为方便，跟第一个网络实体的网络信息相同
ni = NetAi.Append(ndat, NetInfo)

'4. 更新网络实体
'再添加一条线
pos.RemoveAll
pos.Append 25, 25
pos.Append 100, 100
lRes = LinDat.Append(pos, LinInfo)
ndat.Append lRes

'为方便，假设NetInfo只改变颜色
NetInfo.lclr = 50
nRes = NetAi.Update(ni, ndat, NetInfo)

'5. 若只更新网信息，则使用以下方法：
nRes = NetAi.UpdateInfo(ni, NetInfo)

'6. 删除网络实体
If NetAi.GetExistFlag(ni) = 1 Then
 bRes = NetAi.Del(ni)
End If

If bRes Then
'7. 恢复被删除的网络实体
NetAi.UnDel ni
End If

NetAi.SaveAs
Set pos = Nothing
Set ndat = Nothing
Set NetAi = Nothing
Set LinDat = Nothing
Set NetInfo = Nothing
Set LinInfo = Nothing
End Sub

Private Sub AddUptDelPnt_Click()
'添加，更新，删除点实体
Dim PntAi As New PntArea
Dim xy As D_Dot
Dim PntInfo  As Pnt_Info
Dim xyz As New D_3Dot
Dim szStr As String

'打开一个点文件
If Not PntAi.Load Then
Exit Sub
End If
'取第一个点的详细信息
nRes = PntAi.Get(1, xy, szStr, PntInfo)
'坐标平移，仅是为了方便
xy.x = xy.x + 100
xy.y = xy.y + 100
'1. 添加一个二维点
lRes = PntAi.Append(xy, "二维注释点", PntInfo)
Debug.Print "最后一个点实体号为:"; lRes

'坐标平移，仅是为了方便
xyz.x = xy.x - 100
xyz.y = xy.y - 100
xyz.z = 0
'2. 添加一个三维点
lRes = PntAi.Append3D(xyz, "三维注释点", PntInfo)
Debug.Print "最后一个点实体号为:"; lRes

'3.1 添加文件到工作区(方法一)
'添加网络数据文件China.wt到工作区
bRes = PntAi.AppendFile("China.wt", "MYTESTDB", "sa", "")
'3.2 添加文件到工作区(方法二)
bRes = PntAi.AppendFile '此处弹出文件对话框选择
'省略返回值的处理

'4 更新二维点实体（同时更新点坐标和点信息）
'为方便，此处只是变换一下坐标位置
xy.x = xy.x + 50
xy.y = xy.y + 50
'4.1 更新点坐标
'注意前面lRes返回的值为当时最后一个点的点号
bRes = PntAi.UpdatePos(lRes - 1, xy)
'点信息只改变一项,如下改变点的颜色
PntInfo.iclr = 100
'4.2 同时更新点坐标和点信息
bRes = PntAi.Update(lRes - 1, xy, "更新的二维注释点", PntInfo)

'5 更新三维点实体（同时更新点坐标和点信息）
'为方便，此处只是变换一下坐标位置
xyz.x = xyz.x - 50
xyz.y = xyz.y - 50
xyz.z = xyz.z - 50
'5.1 更新点坐标
bRes = PntAi.UpdatePos3D(lRes, xyz)
'5.2 更新前面添加的点实体
bRes = PntAi.Update3D(lRes, xyz, "更新的三维注释点", PntInfo)

'6 更新三维点信息,只改变颜色信息
PntInfo.iclr = 32
'1=成功 0=失败  -1=以被删除
nRes = PntAi.UpdateInfo(lRes, PntInfo)

'7 删除最后一个点实体(省略返回值）
Call PntAi.Del(lRes)
'可查看是否存在返回：1/0/-1=存在/不存在/被删除
Select Case PntAi.GetExistFlag(lRes)
Case 1
    Debug.Print "此点仍然存在！"
Case 0
    Debug.Print "此点不存在！"
Case -1
    Debug.Print "此点存在但被删除了！"
End Select

 '7 取消删除pi点
 If PntAi.UnDel(lRes) Then
 Debug.Print "已经取消了删除!"
 End If

'另存文件
PntAi.SaveAs
Set xy = Nothing
Set xyz = Nothing
Set PntAi = Nothing
Set PntInfo = Nothing
End Sub

Private Sub AddUptDelReg_Click()
Dim RegAi As New RegArea
Dim LinInfo As Lin_Info
Dim pos As New D_DotSet
Dim RegInfo As Reg_Info
Dim LinDat As LinData
Dim rdat As New LONGList
Dim ri As Long
'打开一个区文件
If Not RegAi.Load Then
Exit Sub
End If

'取线数据
Set LinDat = RegAi.Lin
'为方便,使用第一条弧段的线信息
bRes = LinDat.GetInfo(1, LinInfo)
'为方便,使用第一个区的区信息
If RegAi.GetExistFlag(1) = 1 Then
Call RegAi.GetInfo(1, RegInfo)
End If

'造一个区(如下构造一个矩型),一般是你自己的数据
pos.Append 50, 50
pos.Append 100, 50
'添加区弧段
lRes = LinDat.Append(pos, LinInfo)
'删除第一个点坐标
pos.Remove 0, 1
pos.Append 100, 100
'添加区弧段
lRes = LinDat.Append(pos, LinInfo)
'删除第一个点坐标
pos.Remove 0, 1
pos.Append 50, 100
'添加区弧段
lRes = LinDat.Append(pos, LinInfo)
'删除第一个点坐标
pos.Remove 0, 1
pos.Append 50, 50
'添加区弧段
lRes = LinDat.Append(pos, LinInfo)
'构造完毕

'共添加了四条弧段
rdat.Append lRes - 3
rdat.Append lRes - 2
rdat.Append lRes - 1
rdat.Append lRes

'添加区域 成功返回区号(>0) 失败返回0
ri = RegAi.Append(rdat, RegInfo)
If ri Then
Debug.Print "添加的区号为"; lRes
End If

RegAi.SaveAs
'更新区实体
'改变区为三角形（仅为方便）
rdat.Remove 3, 1
pos.Remove 0, 1
pos.Append 100, 100
lRes = LinDat.Append(pos, LinInfo)

'假设改变区信息的区域填充色
RegInfo.clr = 8
'更新前面添加的区域
nRes = RegAi.Update(ri, rdat, RegInfo)

'如果只改变区信息，使用如下方法更方便
nRes = RegAi.UpdateInfo(ri, RegInfo)

'删除区
nRes = RegAi.Del(ri)
If nRes = 1 Then
'撤消对区的删除
nRes = RegAi.UnDel(ri)
End If

RegAi.SaveAs
Set pos = Nothing
Set rdat = Nothing
Set RegAi = Nothing
Set LinDat = Nothing
Set LinInfo = Nothing
Set RegInfo = Nothing

End Sub

Private Sub AllocArcprj_Click()
Dim NetAi As New NetArea
Dim arcLst As LONGList
Dim AllocInf As Arc_Alloc_Info
Dim NetInfo As Net_Info
Dim ArcLin As New D_DotSet
Dim LinDat As LinData
Dim LinInfo As Lin_Info

'打开网文件
If Not NetAi.Load Then
Exit Sub
End If

'1. 取所有弧段数
lRes = NetAi.GetAllocatedArcsNum
Debug.Print "弧段分配数为："; lRes

'2. 取弧段分配方案,arcLst为弧段分配列表
bRes = NetAi.GetAllocatedArcs(arcLst)

'3. 取弧段分配信息(此处取弧段1的分配信息)
bRes = NetAi.GetArcAllocInfo(1, AllocInf)

'4.设置弧段分配方案
'首先增加一条弧段
ArcLin.Append 10, 10
ArcLin.Append 20, 20
Set LinDat = NetAi.Lin
'为方便，假设其线信息同弧段1的相同
If LinDat.GetInfo(1, LinInfo) Then
lRes = LinDat.Append(ArcLin, LinInfo)
'添加到弧段分配列表
Set arcLst = New LONGList
arcLst.Append lRes
'设置弧段分配方案
bRes = NetAi.SetAllocatedArcs(arcLst)
End If

'5.设置弧段分配信息(此处设置添加弧段的分配信息)
'假设其余信息不变，只是前一弧段属性改变
AllocInf.preArc = lRes - 1

'设置分配信息，省略返回值处理
bRes = NetAi.SetArcAllocInfo(lRes, AllocInf)

NetAi.SaveAs
Set NetAi = Nothing
Set arcLst = Nothing
Set LinDat = Nothing
Set ArcLin = Nothing
Set NetInfo = Nothing
Set LinInfo = Nothing
Set AllocInf = Nothing
End Sub

Private Sub AttOperMethod_Click()
Dim TblAi As New TblArea
Dim FieldNum As Integer
Dim ATT As Record
Dim i As Long
Dim j As Integer
Dim val As Variant

'打开一个表文件