basdemo.frm

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

End If

'比较点实体1和点实体2的点信息
If PntAi.GetExistFlag(1) Then
 Call PntAi.GetInfo(1, inf0)
End If

If PntAi.GetExistFlag(2) Then
 Call PntAi.GetInfo(2, inf1)
End If

Set pad = New Pnt_Pad
With pad
.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

'根据pad条件比较点图形参数inf0和inf1是否相同
'完全相同返回1，否则返回0
'方法一
If CompPntParam(pad, inf0, inf1) Then
    Debug.Print "图形参数inf0和inf1相同!"
    Else
    Debug.Print "图形参数inf0和inf1不相同!"
End If

'方法二
If PntTypeParamSame(pad, inf0, inf1) Then
    Debug.Print "图形参数inf和pinf相同!"
    Else
    Debug.Print "图形参数inf和pinf不相同!"
End If

'根据pad条件比较其他图形参数inf0和inf1是否相同
'可以参照上面的方法一

Set pad = Nothing
Set inf0 = Nothing
Set inf1 = Nothing
Set PntAi = Nothing
End Sub

Private Sub DefParamOper_Click()
Dim LinInfo As Lin_Info

'修改缺省的线实体图形信息参数
If ModLinDefParam Then
Debug.Print "修改线参数成功！"
End If

'修改缺省的网实体图形信息参数
ModNetDefParam
'修改缺省的点实体图形信息参数
ModPntDefParam
'修改缺省的区实体图形信息参数
ModRegDefParam

'取缺省的线实体图形信息参数
Set LinInfo = GetLinDefParam
If Not LinInfo Is Nothing Then
Debug.Print "取缺省线参数成功！"
End If

'取缺省的网实体图形信息参数
'Set NetInfo = GetNetDefParam
'取缺省的点实体图形信息参数
'Set PntInfo = GetPntDefParam
'取缺省的区实体图形信息参数
'Set RegInfo = GetRegDefParam

LinInfo.lclr = 10
'...省略其他属性的赋值
'设缺省的线实体图形信息参数
If SetLinDefParam(LinInfo) Then
Debug.Print "设置线参数成功！"
End If

'......省略其他实体参数的设置

Set LinInfo = Nothing
End Sub

Private Sub EditMapParam_Click()
Dim PntInfo As Pnt_Info
Dim enableSelType As Integer
Dim PntPad As Pnt_Pad
'enableSelType表示是否允许选择点类型，0=不可选，1=可选.
'0=失败, IDOK=成功, IDCANCEL=取消

enableSelType = 1
'这里一定要先初始化一个实例
Set PntInfo = New Pnt_Info
nRes = EditPntParam(PntInfo, "编辑点图形参数", enableSelType)

Set PntPad = New Pnt_Pad
'编辑点图形参数及开关板
nRes = EditPntParamPad(PntInfo, PntPad, "编辑点图形参数及开关板", enableSelType)

'编辑点,线，区，网图形参数及开关板的方法是相似的,故省略

Set PntInfo = Nothing
Set PntPad = Nothing
End Sub

Private Sub GetFileInfo_Click()
Dim fAlias  As String
Dim off0 As Long
Dim LayerPad As LayerOnOffPad
Dim mpar As Map_Para
Dim frc As D_Rect
Dim ver As Long
Dim areaType As Integer

'1.取磁盘剩余空间  dsk 磁盘号:
'1=A,2=B... 返回磁盘空间，M为单位
Debug.Print "磁盘C剩余空间为："; _
GetDiskSpace(3); "MB"

off0 = 0

'2. 取文件别名
If GetFileAlias("C:\China.wt", fAlias, off0) Then
    Debug.Print "文件别名为："; fAlias
End If

'3. 取文件分类码
Debug.Print "文件分类码为："; GetFileClass("C:\China.wt", off0)

'4. 取文件图层信息板
'成功: 返回读取的信息长度 (以字节为单位)
'失败: 若fname所指的文件打不开则返回 -1
nRes = GetFileLayerPad("China.wt", LayerPad, off0)

'5. 从本地文件中取地图参数
If GetFileMapParam("China.wt", mpar, off0) Then
    Debug.Print "从本地文件中取地图参数成功!"
End If

'5. 从网络文件中取地图参数
bRes = GetFileMapParam1("China.wt", gisPNT, mpar, off0, "MYTESTDB", "sa", "")
If bRes Then
    Debug.Print "从网络文件中取地图参数成功!"
End If

'6. 取本地文件范围
bRes = GetFileRange("C:\China.wt", frc, off0)
If bRes Then
Debug.Print "文件范围为矩形：("; frc.xmin; ","; frc.ymin; ")"; ","; "("; frc.xmin; ","; frc.ymin; ")"
End If

'6. 取网络文件范围
bRes = GetFileRange1("China.wt", gisPNT, frc, off0, "MYTESTDB", "sa", "")
If bRes Then
Debug.Print "文件范围为矩形：("; frc.xmin; ","; frc.ymin; ")"; ","; "("; frc.xmin; ","; frc.ymin; ")"
End If

'7. 取文件版本号
ver = GetFileVersion("China.wt", off0)
Select Case ver
    Case gisVERSION_dos
        Debug.Print "文件版本为dos版!"
    Case gisVERSION4x
        Debug.Print "文件版本为win16版4.0或4.1或4.2!"
    Case gisVERSION50
        Debug.Print "文件版本为win16版5.0或w32版5.32!"
    Case gisVERSION60
        Debug.Print "文件版本为新版本6.0版!"
    Case gisVERSION70
        Debug.Print "文件版本为新版本7.0版!"
    Case gisVERSION80
        Debug.Print "文件版本为新版本8.0版!"
End Select

'8. 取文件类型
areaType = GetFileType("China.wt", off0, ver)
Select Case areaType
Case gisDBS
        Debug.Print "图库工作区!"
Case gisGRID
        Debug.Print "栅格工作区!"
Case gisGROUP
        Debug.Print "组工作区!"
Case gisLIN
        Debug.Print "线工作区!"
Case gisMSIIMG
        Debug.Print "图像工作区!"
Case gisNET
        Debug.Print "网工作区!"
Case gisPNT
        Debug.Print "点工作区!"
Case gisPRJ
        Debug.Print "工程工作区!"
Case gisREG
        Debug.Print "区工作区!"
Case gisTBL
        Debug.Print "表工作区!"
Case gisTIN
        Debug.Print "三角网工作区!"
Case gisUNKNOWN
Case Else
        Debug.Print "未知类型!"
End Select

Set frc = Nothing
Set mpar = Nothing
Set LayerPad = Nothing
End Sub

Private Sub MapGisAbout_Click()
Dim aType As Enum_Version
Dim objMapGis As MapGis

Set objMapGis = New MapGis
aType = objMapGis.MapGisAbout("关于MAPGIS")

'显示和关闭MAPGIS点位图
ShowMapGisBmp
CloseMapGisBmp

Set objMapGis = Nothing
End Sub

Private Sub NetDataSource_Click()
Dim dsn As String
Dim log As String
Dim psw As String

'1. 取MAPGIS数据源类型
If dbGetGisDSType = gisNET_GIS Then
    Debug.Print "MAPGIS数据源类型为网络数据源"
Else
    If dbGetGisDSType = gisPC_GIS Then
    Debug.Print "MAPGIS数据源类型为机器数据源"
    Exit Sub
    End If
End If

'2. 取MAPGIS缺省的网络数据源名称
bRes = dbGetDefGisDSName(dsn)
If bRes Then
    Debug.Print "缺省的网络数据源名称为："; dsn
End If

'3. 保证MAPGIS网络数据源个数有两个
If dbGetGisDSNumb <= 1 Then
    Exit Sub
End If

'4. 取第一个MAPGIS数据源名称
If dbGetFirstGisDSName(dsn) Then
    Debug.Print "第一个网络数据源名称为："; dsn
End If

'5. 取下一个MAPGIS数据源名称
If dbGetNextGisDSName(dsn) Then
    Debug.Print "下一个网络数据源名称为："; dsn
End If

'6. 取第1项MAPGIS网络数据源名称
If dbGetGisDSName(0, dsn) Then
    Debug.Print "第一个网络数据源名称为："; dsn
End If

'7. 取第一项数据源的登录号和登录口令
If dbGetLogPsw(dsn, log, psw) Then
    Debug.Print "登录号："; log; " 登录口令："; psw
End If

'8. 设置第一项数据源的登录号及口令
If dbSetLogPsw(dsn, "sa", "") Then
    Debug.Print "设置成功！"
End If

'9. 输入第一项数据源的登录号及口令
If dbInputLogPsw(dsn, log, psw) Then
    Debug.Print "输入成功！"
End If

'10. 测试数据源
If dbInputLogPsw(dsn, log, psw) Then
    Debug.Print "测试成功！"
End If

End Sub

Private Sub ReplaceParam_Click()
Dim PntAi As PntArea
Dim inf0 As Pnt_Info
Dim inf1 As Pnt_Info
Dim pad0 As Pnt_Pad
Dim pad1 As Pnt_Pad
Dim pntType As Integer

'根据pad条件比较图形参数inf0和inf1是否相同
'比较点参数
Set PntAi = New PntArea

If Not PntAi.Load Then
Set PntAi = Nothing
Exit Sub
End If

'修改点实体1和点实体2的点信息
If PntAi.GetExistFlag(1) Then
 Call PntAi.GetInfo(1, inf0)
 Else: Exit Sub
End If

If PntAi.GetExistFlag(2) Then
 Call PntAi.GetInfo(2, inf1)
 Else: Exit Sub
End If

Set pad0 = New Pnt_Pad

Set pad1 = New Pnt_Pad
With pad1
.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

'修改点参数替换条件和替换结果
'pntType制定要修改的点参数类型.若pntType非法
'则ReplacePntParam弹出点类型选择窗口
 nRes = ReplacePntParam(inf0, pad0, inf1, pad1, pntType = 0)
 If nRes = 1 Then
 Debug.Print "修改成功!"
 End If
      
'修改其他实体参数替换条件和替换结果的方法与上相似

Set pad0 = Nothing
Set pad1 = Nothing
Set inf0 = Nothing
Set inf1 = Nothing
Set PntAi = Nothing
End Sub

Private Sub SelectShow_Click()
Dim szPath As String
Dim colNo As Long
Dim ztNo As Integer
Dim patno As Integer
Dim subno As Long
Dim ltp As Integer
Dim fltp As Integer
Dim objMapGis As MapGis

Set objMapGis = New MapGis
'注意：这里不要objMapGis对象也可，因为MapGis
'下的方法就是全局的方法
'选择目录
bRes = objMapGis.SelDirectory(szPath, "选择路径")
If bRes Then
Debug.Print "你选择的路径为："; szPath
End If

'公共对话框函数
'返回值:0=失败, IDOK=成功, IDCANCEL=取消

'选择颜色
nRes = SelectColor(colNo)
If nRes Then
Debug.Print "你选择的颜色号为："; colNo
End If

'选择字体
nRes = SelectFontType(ztNo)
If nRes Then
Debug.Print "你选择的字体号为："; ztNo
End If

'选择线型
nRes = SelectLineType(ltp, fltp)
If nRes Then
Debug.Print "你选择的字体号为："; ztNo
End If

'选择填充图案
nRes = SelectPattern(patno)
If nRes Then
Debug.Print "你选择的填充图案号为："; ztNo
End If

'选择子图
nRes = SelectSubGraph(subno)
If nRes Then
Debug.Print "你选择的子图号为："; ztNo
End If

Set objMapGis = Nothing
End Sub

Private Sub SetRelateObject_Click()
'D_DotSet对象的使用
Dim bResult As Boolean
Dim lCount As Long

On Error Resume Next
'创建一个D_DotSet对象实例
Dim objDDotSet As D_DotSet
Set objDDotSet = New D_DotSet
'添加一个D_Dot点(方法一）
objDDotSet.Append 21.34, 98.12
'创建一个D_Dot对象实例
Dim objDDot As New D_Dot
objDDot.x = 23.43
objDDot.y = 2.38
'添加一个D_Dot点(方法二）
objDDotSet.Append2 objDDot

'在第index项之前插入一个D_Dot点(方法一）
objDDotSet.Insert 1, 0.32, 98.44
objDDot.x = 89.234
objDDot.y = -231.34
'在第index项之前插入一个D_Dot点(方法二）
objDDotSet.Insert2 1, objDDot

'另外创建一个D_DotSet对象实例
Dim objDDotSet1 As New D_DotSet

'替换（复制）对象
bResult = objDDotSet1.Set(objDDotSet)
If Not bResult Then
    MsgBox "复制失败!"
End If

'更新第index项数据(方法一）
objDDotSet.Update 2, -232, 9.324
'更新第index项数据(方法二）
objDDot.x = 78.2
objDDot.y = 70.34
objDDotSet.Update2 2, objDDot

'遍历整个集合打印各数据
For lCount = 0 To objDDotSet.Count - 1
    Debug.Print objDDotSet.Item(lCount).x; ""; _
    objDDotSet.Item(lCount).y
Next lCount

'删除从第index项开始的nCount个D_Dot点
objDDotSet.Remove 2, 2
'删除所有D_Dot点
objDDotSet.RemoveAll

'释放对象实例
Set objDDot = Nothing
Set objDDotSet = Nothing
Set objDDotSet1 = Nothing
End Sub
'***************************************************
'其它类似的如：L_DotSet,D_3DotSet,L_3DotSet,D_RectSet
'Tic_DotSet,RadSet,GeoLin3DSet,GeoLinSet,GeoNetSet
'GeoPathSet,GeoPntSet,GeoRegSet,LinSet,Lin3DSet
'LONGList,Net,NetSet,PathSet,PntSet,Reg,RegSet
'RepFldFlag等对象的方法，属性的使用可参照上述例子。
'***************************************************