basform.frm

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

'(2)保存原来的文件
PntAi.Save
'(3)另存文件为（忽略返回值）...
'可以保存为本地文件，也可以是网络数据文件
PntAi.SaveAs

'3. 自由加载(弹出对话框选择）
If Not PntAi.Load Then
MsgBox "加载点文件失败！", vbInformation
End If

'(4) 保存部分点
'点信息
Dim PntInfo As Pnt_Info
'点信息开关板
Dim PntPad As New Pnt_Pad
'层开关板
Dim LayOnOff As New LayerOnOffPad
'假定保存的点信息为第一个点的点信息
Call PntAi.GetInfo(1, PntInfo)
'设置点信息开关板,假设如下设置
With PntPad
.iclr = gisON
.infoDx = gisON
.infoDy = gisON
.layer = gisOFF
.linNo = gisOFF
.ovprnt = gisOFF
.rect = gisON
.res0 = gisON
.res1 = gisON
.Sub.angle = gisOFF
.Sub.fclr = gisOFF
.Sub.Height = gisOFF
.Sub.penw = gisOFF
.Sub.subno = gisOFF
.Sub.Width = gisOFF
.Type = gisON
'所有开关置为ON
LayOnOff.SetAllOn
End With
'保存部分点到原文件
bRes = PntAi.SavePart(PntPad, PntInfo, LayOnOff)

Set PntAi = Nothing
Set PntInfo = Nothing
Set LayOnOff = Nothing
End Sub

Private Sub ModAllMethod_Click()
Dim TblAi As New TblArea
Dim ATT As Record
Dim lst As New IDList
Dim pRepFldFlg As New RepFldFlag

'打开一个表文件
If Not TblAi.Load Then
Exit Sub
End If

'//字段统改
'//======替换ptLst表所含记录的字段值===========================//
'//Lst-统改记录号表，Lst(0)=记录数,Lst(1)-Lst(Lst(0))=记录号
'//ptLst=NULL则统改所有记录
'//titleName-统改条件输入窗口标题
'//返回值:IDYES(6)、IDNO(7)、IDCANCEL(2)，失败=0
'//==========================================================//
'假设统改前三条记录(统改哪些记录，由开发人员决定)
lst.Append 1
lst.Append 2
lst.Append 3
'统改lst中的记录，弹除对话框进行统改
nRes = TblAi.RepLstRcdFld(lst, "这是统改标题")
TblAi.SaveAs

'//统改属性记录字段
'//======根据条件表达式替换指定的记录字段======================//
'//替换ptLst表所列记录的指定字段,返回统改的记录数
'//lst同上面所述
'//ptRepFldFlag-替换字段开关;ptRepFldFlag（i）对应i(从0开始)
'//号字段,1=替换，0=不替换
'//attExp-属性条件表达式字符串,可为NULL,即无属性条件
'//repAtt-替换值记录数据,
'//==========================================================//
'如下，假设替换值记录数据为第一条记录，只改动第二个字段,属性条件为空
pRepFldFlg.Append 0
pRepFldFlg.Append 1
'取第一条记录
nRes = TblAi.Get(1, ATT)

If Not TblAi Is Nothing Then
lRes = TblAi.RepLstRcdFld0(lst, pRepFldFlg, "", ATT)
Debug.Print "统改的记录数为："; lRes
End If
TblAi.SaveAs

'统改所有字段域值 , lst = NULL则统改所有记录
'如下统改lst中所列记录的第i号字段(给定所有记录的字段均修改成一样的值)
nRes = TblAi.ModLstRcdFldVal(lst, 1, "这是统改字段域值")

TblAi.SaveAs
Set lst = Nothing
Set ATT = Nothing
Set TblAi = Nothing
Set pRepFldFlg = Nothing
End Sub

Private Sub NetPathOper_Click()
Dim NetAi As New NetArea
Dim nPath As IDList
Dim aPath As IDList
Dim LinInfo As Lin_Info
Dim nLen As Long
Dim aLen As Long

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

'取网络路径
If NetAi.Path.Get(1, nPath, aPath, LinInfo) Then
'1. 取网络路径数据项数
nRes = NetAi.Path.GetLen(1, nLen, aLen)
If nRes Then
Debug.Print "结点数为："; nLen; Chr(13); "弧段数为："; aLen
End If

'2. 删除网络路径
nRes = NetAi.Path.Del(1)
If nRes Then
Debug.Print "网络路径１已删除！"

'3. 恢复被删除的网络路径
NetAi.Path.UnDel 1
End If

'4.更新网络路径信息
'这里假设只改变线颜色
LinInfo.lclr = 10
nRes = NetAi.Path.UpdateInfo(1, LinInfo)
If nRes Then
Debug.Print "更改线信息成功！"
End If

'5.更新路径
'.............
End If

'6. 添加路径
'.............
'(5,6省略)

NetAi.SaveAs
Set aPath = Nothing
Set nPath = Nothing
Set NetAi = Nothing
Set LinInfo = Nothing
End Sub

Private Sub PartToList_Click()
Dim PntAi As New PntArea
'层开关板
Dim LayPad As New LayerOnOffPad
'点信息
Dim PntInfo As Pnt_Info
'点信息开关板
Dim PntPad As Pnt_Pad
'ID列表(集合)
Dim lst As IDList
Dim lCount As Long

'打开一个点文件
If Not PntAi.Load Then
MsgBox "打开文件失败！"
Exit Sub
End If

'假定拷贝的点信息为第一个点的点信息
If PntAi.GetExistFlag(1) Then
Call PntAi.GetInfo(1, PntInfo)
Else
Exit Sub
End If
'设置点信息开关板,假设如下设置
Set PntPad = New Pnt_Pad

Set lst = PntAi.PartToList(PntPad, PntInfo)

With PntPad
.iclr = gisON
.infoDx = gisON
.infoDy = gisON
.layer = gisON
.linNo = gisON
.ovprnt = gisON
.rect = gisON
.res0 = gisON
.res1 = gisON
.Sub.angle = gisON
.Sub.fclr = gisON
.Sub.Height = gisON
.Sub.penw = gisON
.Sub.subno = gisON
.Sub.Width = gisON
.Type = gisON
End With
'所有开关置为ON
LayPad.SetAllOn

'拷贝部分点到列表
'方法1
Set lst = PntAi.PartToList(PntPad, PntInfo)
'方法2，考虑层开关板
Set lst = PntAi.PartToList(PntPad, PntInfo, LayPad)

'依次显示满足的IDList中的ID号
For lCount = 0 To lst.count - 1
Debug.Print lst(lCount)
Next lCount

Set lst = Nothing
Set PntAi = Nothing
Set LayPad = Nothing
Set PntPad = Nothing
Set PntInfo = Nothing
End Sub

Private Sub QueryNearLin_Click()
Dim LinAi As New LinArea
Dim xy As New D_Dot
Dim dis As Double
Dim LayPad As New LayerOnOffPad

'打开一个点文件
If Not LinAi.Load Then
MsgBox "打开文件失败！"
Exit Sub
End If

'给定一个点坐标
xy.x = 100
xy.y = 100

' 查找点工作区上离xy最近的线
'注意：下面LayPad,dis是可选参数

'方法1，返回线号
lRes = LinAi.Near(xy)

'方法2，考虑层，设置层开关板
LayPad.SetAllOn '设为全开
lRes = LinAi.Near(xy, LayPad)

'方法3，可取得点到线的最近距离
lRes = LinAi.Near(xy, , dis)
Debug.Print "最近距离是："; dis

Set xy = Nothing
Set LinAi = Nothing
Set LayPad = Nothing

End Sub

Private Sub QueryNearPnt_Click()
Dim PntAi As New PntArea
Dim xy As New D_Dot
Dim dis As Double
Dim LayPad As New LayerOnOffPad

'打开一个点文件
If Not PntAi.Load Then
MsgBox "打开文件失败！"
Exit Sub
End If

'给定一个点坐标
xy.x = 100
xy.y = 100

' 查找点工作区上离xy最近的点
'注意：下面LayPad,dis是可选参数

'方法1，返回点号
lRes = PntAi.Near(xy)

'方法2，考虑层，设置层开关板
LayPad.SetAllOn '设为全开
lRes = PntAi.Near(xy, LayPad)

'方法3，可取得两点间的距离
lRes = PntAi.Near(xy, , dis)
Debug.Print "最近距离是："; dis

Set xy = Nothing
Set PntAi = Nothing
Set LayPad = Nothing
End Sub

Private Sub RcdOperMethod_Click()
Dim TblAi As New TblArea
Dim ATT As Record

'打开一个表文件
If Not TblAi.Load Then
Exit Sub
End If

'注意：以下对记录的操作必须是表工作区!!!
Set ATT = New Record
'假设已经知道表中字段为ID号，长度等等
'首先取得表中的属性结构
ATT.hd = TblAi.stru

'也可以直接取得某条属性记录(因为属性结构都是一样的)
'如下取得第一条记录的属性
nRes = TblAi.Get(1, ATT)

'给每个字段赋值
ATT.Value(0) = 100
ATT.Value(1) = 134.23
'......其余字段的赋值
'将att做为一个记录添加到到表格的最后
'lRes返回最后的记录号
lRes = TblAi.AppendRcd(ATT)

'删除第i条记录(此处为最后一条)
If TblAi.DelRcd(lRes) Then
'撤消对第i条记录的删除
TblAi.UnDelRcd lRes
End If

'要想删除所有记录，只要使用如下方法就可：
TblAi.Clear

Set ATT = Nothing
Set TblAi = Nothing
End Sub

Private Sub RegQuery_Click()
Dim RegAi As New RegArea
Dim xy As New D_Dot
Dim LayPad As New LayerOnOffPad
Dim flg As Integer
Dim regnum As Long
xy.x = 200
xy.y = 200
'打开一个区文件
If Not RegAi.Load Then
Exit Sub
End If

LayPad.SetAllOn
'查找点在哪个区内
lRes = RegAi.Seek(xy)
'如果打开层开关板，则如下：
lRes = RegAi.Seek(xy, LayPad)
'立即窗口显示区号
Debug.Print "点在区"; lRes; "内"

'点是否在区域内
For regnum = 1 To RegAi.count
'flg==1则严格套合，否则只检查第一圈
'返回值：2/1/0=内/边界/外
nRes = RegAi.IsDotIn(xy, regnum, flg)
If nRes = 2 Then
Debug.Print "点在区"; regnum; "内"
Exit For
End If
If nRes = 1 Then
Debug.Print "点在区"; regnum; "边界上"
Exit For
End If
Next regnum

Set xy = Nothing
Set RegAi = Nothing
Set LayPad = Nothing
End Sub

Private Sub TicDotMethod_Click()
Dim PntAi As New PntArea
Dim tic As New Tic_Dot
Dim lst As Tic_DotSet
'打开一个点文件
If Not PntAi.Load Then
Exit Sub
End If

'初始化TicDot
tic.xy0.x = 50   '图形坐标值
tic.xy0.y = 50
tic.xy1.x = 100  '理论坐标值
tic.xy1.y = 100

'判断是否有Tic点
If PntAi.GetTicNum <= 0 Then
MsgBox "当前工作区没有Tic点!"
End If

'添加Tic点
If PntAi.AppendTicDot(tic) Then
'取Tic点列表
bRes = PntAi.GetTicList(lst)
End If

Dim ai As New PntArea
'拷贝所有TIC点到ai工作区
If PntAi.CopyTicDots(ai) Then
Debug.Print ai.GetTicNum
End If

tic.xy0.x = 20
tic.xy0.x = 20
tic.xy1.y = 40
tic.xy1.y = 40
'给lst中再添加一个Tic点
lst.Append tic
'将lst中的TIC点替换ai工作区中原来的TIC点
If PntAi.ReplaceTicList(lst) Then
'显示目前工作区的的点数
Debug.Print PntAi.GetTicNum
End If

'清除所有Tic点,忽略返回值
PntAi.ClearAllTicDot

Set ai = Nothing
Set tic = Nothing
Set lst = Nothing
Set PntAi = Nothing
End Sub

Private Sub UnionSplitMath_Click()
Dim RegAi As New RegArea
Dim delCommArc As Integer '是否删除公共弧段
Dim rdat As LONGList
Dim RegInfo As Reg_Info

'打开一个区文件
If Not RegAi.Load Then
Exit Sub
End If

'合并子区弧段
'如下把第一个区的弧段合并为一
If RegAi.Lin.count < 2 Then
Set RegAi = Nothing
Exit Sub
End If

'保证两个区存在(区2和区3)
If (RegAi.GetExistFlag(2) = 0) Or (RegAi.GetExistFlag(3) = 0) Then
Set RegAi = Nothing
Exit Sub
End If

Set rdat = New LONGList
bRes = RegAi.UnionArc(rdat)
If bRes Then
    MsgBox "合并弧段成功！"
Else
    MsgBox "合并弧段失败！"
End If

'区域合并
'把区域ra合并到区域rb, (delCommArc:是否删除公共弧段)
'如下: 把区域2合并到3
delCommArc = 0 '(不删除弧段)
bRes = RegAi.UnionAtoB(2, 3, delCommArc)
If bRes Then
    MsgBox "区域合并成功！"
Else
    MsgBox "区域合并失败！"
End If

'分裂区，如下把上面合并的区域分裂
'用于分裂区的弧段必须是经过结点平差后的弧段
'......RegAi.Split...略
If RegAi.Get(3, rdat, RegInfo) Then
nRes = RegAi.Split(3, rdat)
End If
If nRes Then
    MsgBox "分裂区域成功！"
Else
    MsgBox "分裂区域失败！"
End If

'匹配子区
'重新搜索所有区之间的包含关系，建立匹配关系
'匹配子区3
If RegAi.MathSubreg(3) Then
    MsgBox "匹配子区3成功！"
Else
    MsgBox "匹配子区3失败！"
End If

'匹配所有子区
If RegAi.MathAllSubreg Then
    MsgBox "匹配所有子区成功！"
Else
    MsgBox "匹配所有子区失败！"
End If

Set rdat = Nothing
Set RegAi = Nothing
Set RegInfo = Nothing
End Sub