basform.frm

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

If Not TblAi.Load Then
Exit Sub
End If

'取属性(取某条记录)
'注意：字段数是Integer,从0到numbfield-1排列
'记录数是Long,从1到numbrecord - 1条记录
For i = 1 To TblAi.nCount
    nRes = TblAi.Get(i - 1, ATT)
    For j = 0 To TblAi.nCount
        val = ATT.Item(j).Value
        Debug.Print val
    Next j
    Set ATT = Nothing
Next i

'写属性值
For i = 1 To TblAi.nCount
    nRes = TblAi.Get(i, ATT)
    ATT.Value(0) = i           '写整形值
    '或者根据字段名赋值
    ATT.Value("ID") = i        '写整形值
    '.......省略其余字段赋值，由开发者自己决定
    '写某条属性
    bRes = TblAi.Write(i, ATT)
    Set ATT = Nothing
Next i

'可以取得缺省的属性记录
bRes = TblAi.GetDef(ATT)
'也可以设置缺省属性
'这里省略属性字段的赋值
bRes = TblAi.WriteDef(ATT)

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

Private Sub AttStruOper_Click()
Dim TblAi As New TblArea
Dim stru As Record_Head
Dim FieldNum As Integer
Dim fldinf As New Field_Head
'打开一个表文件
If Not TblAi.Load Then
Exit Sub
End If

'1. 取属性结构
Set stru = TblAi.stru
'可以取各字段名(当然还可以取得字段其他的描述信息)
For FieldNum = 0 To stru.numbfield - 1
Debug.Print stru(FieldNum).fieldname
Next FieldNum

'构造需添加的字段信息
fldinf.fieldname = "newfld"
fldinf.fieldtype = gisDOUBLE_TYPE
fldinf.point_leng = 0.3
fldinf.msk_leng = 10
fldinf.edit_enable = 1
fldinf.ptc_pos = -1
'2. 添加属性结构字段,添加到最后
bRes = stru.AppendField(fldinf)
'如果想插入到属性结构的某一位置，则可以：
'bRes = stru.InsertField(fldinf, insTo)
'从insTo(从0开始)位置插入

'3.设置表工作区属性结构
TblAi.stru = stru
'以上也可以如下方法代替：
'bRes = TblAi.stru.AppendField(fldinf)

'若想删除属性结构，可以直接如下方法：
bRes = TblAi.stru.DelField("ID")
'或者如下：(fldi为字段号)
'bRes = TblAi.stru.DelField2(fldi)

'4. 有时需要比较属性结构，可使用如下方法:
Dim pIStru0  As New Record_Head
'....此处省略PIStru0的字段添加
bRes = TblAi.stru.IsEqual(pIStru0)

TblAi.SaveAs
Set stru = Nothing
Set TblAi = Nothing
Set fldinf = Nothing
End Sub

Private Sub CopyPntArea_Click()
'clone,copyall,copylist,copymapparam
'copyPart,copyTicDots等方法的使用
Dim PntAi As New PntArea
Dim ai As WorkArea
Dim ai1 As PntArea
Dim lst As IDList
Dim rtnNo As Integer
'打开一个点文件
If Not PntAi.Load Then
Exit Sub
End If

'1. 克隆工作区
Set ai = PntAi.Clone
ai.SaveAs '保存后可以查看是否相同

'2. 拷贝所有实体到工作区ai1中,返回实体数
'此处一定要先New一个PntArea对象
Set ai1 = New PntArea
lRes = PntAi.CopyAll(ai1)

'3. 拷贝列表中的点到工作区ai1
'假设拷贝所有点（仅为了方便）
'取所有没有被删除的点号
Set lst = PntAi.GetAllExistNo
If ai1.Clear Then
'rtnNo-是否通过lst返回新的实体号,返回拷贝的实体数
lRes = PntAi.CopyList(lst, ai1, rtnNo)
End If

'4. 拷贝地图参数到工作区ai
bRes = PntAi.CopyMapParam(ai1)

'5. 拷贝部分点到ai1工作区
'点信息
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
'返回拷贝的实体数
If ai1.Clear Then
lRes = PntAi.CopyPart(PntPad, PntInfo, ai1)
'若打开层开关板，则如下
'lRes = PntAi.CopyPart(PntPad, PntInfo, Ai1, LayOnOff)
End If

'6. 拷贝所有TIC点到ai工作区
'假如存在Tic点
If (PntAi.GetTicNum > 0) And ai.Clear Then
bRes = PntAi.CopyTicDots(ai)
End If
'释放空间
Set ai = Nothing
Set ai1 = Nothing
Set lst = Nothing
Set PntAi = Nothing
Set PntPad = Nothing
Set PntInfo = Nothing
Set LayOnOff = Nothing
End Sub

Private Sub CopyRecord_Click()
Dim TblAi As New TblArea
Dim ai1 As New TblArea
Dim lst As New IDList
'打开一个表文件
If Not TblAi.Load Then
Exit Sub
End If

'CopyAll 拷贝所有属性记录到ai1的attType1类型表中
'ai1必须是ITblArea, attType1必须是TBL或DBSTBL
lRes = TblAi.CopyAll(ai1)
Debug.Print "拷贝了"; lRes; "条纪录"
ai1.SaveAs

ai1.Clear
'CopyList 拷贝lst指定的记录到ai1的attType1类型表中
'假设ai有多于三条的纪录,如下拷贝三条纪录到ai1的属性表里
lst.Append 1: lst.Append 2: lst.Append 3
lRes = TblAi.CopyList(lst, ai1)

'如果考虑可选参数,就可如下表示:
'changeStru: 是否改变ai1的属性结构，使其结构和ai0的相同
'rtnNo -是否通过lst返回新的实体号
lRes = TblAi.CopyList(lst, ai1, 1, 0)
'上面表示改变属性结构,不通过lst返回新的实体号
'changeStru=1,rtnNo=0也是默认参数

Set ai1 = Nothing
Set lst = Nothing
Set TblAi = Nothing
End Sub

Private Sub FieldOperMethod_Click()
'这里使用区文件是为了方便
Dim RegAi As New RegArea
Dim ATT As Record
Dim fldinf As New Field_Head
Dim errVal
'打开一个区文件
If Not RegAi.Load Then
Exit Sub
End If

'根据实体号1取属性ID , 返回属性ID号
lRes = RegAi.RegAtt.GetID(1)

'取最大ID值
lRes = RegAi.RegAtt.GetMaxID

'//计算字段值:======================================================
'入口参数:
'      fldName-计算字段名称
'      calExp-计算表达式
'      domainErrVal-表达式计算过程中定义域错时(如除0错)，计算结果替换值
'      若domainErrVal!=NULL,则用domainErrVal作为fldName的字段值
'      若domainErrVal==NULL,则不修改当前记录的fldName字段值
'例:
'    ...
'    errVal=10.0;
'    ...
'工作区对象.CalculateFldVal("人均土地面积","面积/人口",errVal)
'就是计算ai(区工作区)工作区中的REG类型属性中的"人均土地面积"字段值，
'计算表达式为"面积/人口",即面积字段值除人口字段值,当人口字段值为0时，
'产生除0错，此时，用errVal值(10.0)作为"人均土地面积"的字段值。
'================================================================//
'主要用在区工作区属性中，如下添加一个字段名为:计算的字段值
'其值为面积除以周长 (区默认属性字段有面积和周长)
fldinf.fieldname = "面积除周长"
fldinf.fieldtype = gisSTR_TYPE
fldinf.msk_leng = 32
fldinf.edit_enable = 1
fldinf.ptc_pos = -1

bRes = RegAi.RegAtt.stru.AppendField(fldinf)
RegAi.Save
If bRes Then
errVal = 10#
bRes = RegAi.RegAtt.CalculateFldVal("面积除周长", "面积/周长", 10)
End If

If bRes Then
MsgBox "成功计算字段值！"
End If

RegAi.SaveAs
Set ATT = Nothing
Set RegAi = Nothing
Set fldinf = Nothing
End Sub

Private Sub GetAreaInf_Click()
Dim RegAi As New RegArea
Dim rdat As LONGList
Dim ne As LONGList
Dim RegInfo As Reg_Info
Dim rate As Double
Dim xy As D_DotSet
Dim xy1 As L_DotSet
Dim xy0 As D_Dot

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

If RegAi.GetExistFlag(1) = 1 Then
'取区域 返回:1=成功0=失败-1=已被删除
nRes = RegAi.Get(1, rdat, RegInfo)
Else: Exit Sub
End If

'取区域圈数
If nRes = 1 Then
    If RegAi.GetCircleNum(rdat) < 1 Then
    Exit Sub
    End If
End If

'取区边界坐标
'rdat为区１的数据
'返回：xy为点坐标数据
'返回：ne为区域边界封闭圈点号集合
nRes = RegAi.GetEdge(rdat, xy, ne)

'取区域的长整数边界
rate = 1
Set xy0 = New D_Dot
xy0.x = 50
xy0.y = 50
nRes = RegAi.GetLongEdge(rdat, xy1, ne, xy0, rate)
'说明以上参数：
'xy1:区域边界坐标数据集合
'ne :区域边界封闭圈点号集合
'xy0:原点坐标
'rate:缩放比例

'返回rdat长度(下面为区１)
lRes = RegAi.GetDatLen(1)

Set ne = Nothing
Set xy = Nothing
Set xy0 = Nothing
Set xy1 = Nothing
Set rdat = Nothing
Set RegAi = Nothing
Set RegInfo = Nothing
End Sub

Private Sub GetDatLen_Click()
Dim LinAi As New LinArea
Dim count As Long
Dim length As Double
'打开一个线文件
If Not LinAi.Load Then
Exit Sub
End If

'GetDatLen和GetLength是不一样的功能
'前者取取线数据长度(字节长度),后者取线长度
'立即窗口打印各条线的线数据长度
For count = 1 To LinAi.count
Debug.Print LinAi.GetDatLen(count)
Next count

'立即窗口打印各条线的长度
For count = 1 To LinAi.count
bRes = LinAi.GetLength(count, length)
If bRes Then
Debug.Print length
End If
Next count

'可以对照以上显示的值
Set LinAi = Nothing
End Sub

Private Sub GetorCalMethod_Click()
Dim RegAi As New RegArea
Dim area As Double
Dim par As Double
Dim rdat As LONGList
Dim inf As Reg_Info
Dim minDis As Double
Dim maxDis As Double
Dim xy As New D_Dot

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

'计算面积 该函数要求xy构成的多边形封闭
'返回面积<0时表示该区逆时针旋转,>0时表
'示该区顺时针旋转
If RegAi.GetExistFlag(1) <> 1 Then
Exit Sub
End If
'为计算方便，这里计算第一个区的面积
'取区域1返回:1=成功0=失败-1=已被删除
If RegAi.Get(1, rdat, inf) = 1 Then
  bRes = RegAi.CalculateArea(rdat, area, par)
  If bRes Then
  Debug.Print area; par
  End If
End If

'计算给定区1的更简单的方法如下：
 If RegAi.GetArea(1, area) Then
 Debug.Print area
 End If

'取区域1的周长
If RegAi.GetPerimeter(1, par) Then
Debug.Print par
End If

xy.x = 100
xy.y = 100
'计算点到区之间的距离(包括最大，最小距离)
If RegAi.DistOfPntToReg(xy, 1, minDis, maxDis) Then
Debug.Print minDis; maxDis
End If
'计算点到区之间的最大距离
maxDis = RegAi.MaxDistOfPntToReg(xy, 1)
minDis = RegAi.MinDistOfPntToReg(xy, 1)
'比较三种方法得到的值
Debug.Print minDis; maxDis

Set xy = Nothing
Set inf = Nothing
Set rdat = Nothing
Set RegAi = Nothing
End Sub

Private Sub GetSetPntInfo_Click()
Dim PntAi As New PntArea
Dim xy As D_Dot
Dim xyz As New D_3Dot
Dim rect As D_Rect
Dim laynum As Integer
Dim mpar As Map_Para
Dim mmPath As String
Dim fName As String
Dim PntInfo As Pnt_Info
Dim pntType As Enum_Pnt_Type
'打开一个点文件
If Not PntAi.Load Then
Exit Sub
End If

'以下取各种实体信息均具有单独性,因此创建
'一个对象实例，加载文件后就可取的各种信息

'取点1存在标志
nRes = PntAi.GetExistFlag(1)
If nRes <> 1 Then
GoTo SampEnd
End If

'注意:以下给出返回值,但没有处理,可根据情况
'确定是否进行处理
'取点1的位置 1/0/-1成功/失败/已被删除
nRes = PntAi.GetPos(1, xy) '省略返回处理
'取点1的位置
nRes = PntAi.GetPos3D(1, xyz)
'取图元1范围 返回值:1/0/-1=存在/不存在/被删除
nRes = PntAi.GetRect(1, rect)
'取pi点所属图层号 返回值:1/0/-1=存在/不存在/被删除
nRes = PntAi.GetLayer(1, laynum)
'取图元1范围及图层返回值:1/0/-1=存在/不存在/被删除
nRes = PntAi.GetRectLayer(1, rect, laynum)
'取点数据长度(字节长度)
lRes = PntAi.GetDatLen(1)
'取1号图元信息 返回值:1/0/-1=存在/不存在/被删除
nRes = PntAi.GetInfo(1, PntInfo)
'返回点类型
nRes = PntAi.GetType(1, pntType)

'取工作区文件别名
bRes = PntAi.GetAreaAlias(fName)
'设工作区文件别名
bRes = PntAi.SetAreaAlias("点工作区文件别名")
'取工作区文件分类码
nRes = PntAi.GetAreaFClass
'设工作区文件分类码,设为0类型
bRes = PntAi.SetAreaFClass(1)
'取自动取二进制数据字段标志(0/1 - 不自动/自动)
nRes = PntAi.GetAutoGetBinDatFlag
'设自动取二进制数据字段标志(0/1 - 不自动/自动)
'设为自动取二进制数据字段
nRes = PntAi.SetAutoGetBinDatFlag(1)
'取工作区文件名(不包括路径)
bRes = PntAi.GetFileName(fName)
'取地图参数
bRes = PntAi.GetMapParam(mpar)
'设地图参数
bRes = PntAi.SetMapParam(mpar)
'取多媒体数据路径
bRes = PntAi.GetMMDPath(mmPath)
'设多媒体数据路径
bRes = PntAi.SetMMDPath("D:\MapGis61")

'以下为点工作区的一些属性如:
'PntAi.Count 工作区实体数,使用如下:
lRes = PntAi.count
'由于都是工作区对象属性,调用简单,故省略
'......
Set xy = Nothing
Set xyz = Nothing
Set mpar = Nothing
Set rect = Nothing
Set PntInfo = Nothing
SampEnd:
Set PntAi = Nothing
End Sub

Private Sub LoadSavePntFile_Click()
'加载点文件的三种方式
'保存点文件的四种方式

'1. 带文件名的加载
Dim PntAi As PntArea
Set PntAi = New PntArea
'加载China.wt文件到工作区
bRes = PntAi.Load("China.wt")
If bRes = True Then
MsgBox "China.wt点文件已成功加载！", vbInformation
End If
'(1)保存文件到网络数据库中（忽略返回值）
'MYTESTDB为数据源，sa为数据库用户，最后一个为密码
bRes = PntAi.Save("China.wt", "MYTESTDB", "sa", "")

'2. 加载网络数据文件
bRes = PntAi.Load("China", "MYTESTDB", "sa", "")