basdemo.frm

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

VERSION 5.00
Begin VB.Form BasObj 
   Caption         =   "基本对象"
   ClientHeight    =   3195
   ClientLeft      =   165
   ClientTop       =   450
   ClientWidth     =   4680
   Icon            =   "BasDemo.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   3195
   ScaleLeft       =   1000
   ScaleMode       =   0  'User
   ScaleTop        =   1000
   ScaleWidth      =   4680
   Begin VB.Menu MapGisObject 
      Caption         =   "MapGis全局对象"
      Begin VB.Menu MapGisAbout 
         Caption         =   "版本信息"
      End
      Begin VB.Menu ClockAndCursor 
         Caption         =   "走钟与光标"
      End
      Begin VB.Menu GetFileInfo 
         Caption         =   "取文件信息"
      End
      Begin VB.Menu DefParamOper 
         Caption         =   "缺省参数操作"
      End
      Begin VB.Menu CompMapParam 
         Caption         =   "比较图形参数"
      End
      Begin VB.Menu EditMapParam 
         Caption         =   "编辑图形参数"
      End
      Begin VB.Menu NetDataSource 
         Caption         =   "网络数据源操作"
      End
      Begin VB.Menu SelectShow 
         Caption         =   "公共对话框函数"
      End
      Begin VB.Menu CalLinLenAndDot 
         Caption         =   "计算线段长度交点"
      End
      Begin VB.Menu ReplaceParam 
         Caption         =   "修改参数替换条件结果"
      End
   End
   Begin VB.Menu OtherObject 
      Caption         =   "其它相关对象"
      Begin VB.Menu SetRelateObject 
         Caption         =   "集合相关对象"
      End
      Begin VB.Menu AttRelateObject 
         Caption         =   "属性相关对象"
      End
   End
End
Attribute VB_Name = "BasObj"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim bRes As Boolean
Dim nRes As Integer
Dim lRes As Long

Private Sub AttRelateObject_Click()
'关于扩展属性结构,属性结构,属性,记录等的使用
Dim val As Variant
'--------------------------------------------
'Field_ExtHead的使用
'--------------------------------------------
Dim objFieldExtHead As Field_ExtHead
Dim bResult As Boolean
Dim nResult As Integer
Dim ttlStr As String
'创建一个Field_ExtHead实例
Set objFieldExtHead = New Field_ExtHead
'使用时一定要先初始化扩展字段
bResult = objFieldExtHead.Init(gisDATE_TYPE, 2)
If Not bResult Then
    MsgBox "初始化扩展字段失败!"
    Exit Sub
End If

'设置字段别名
objFieldExtHead.alias = "字段为日期类型"
'允许为空
objFieldExtHead.IsNull = True
'设置字段形态,可为编辑框/组合框/复选框/按扭
objFieldExtHead.Shape = gisFLD_SHP_COMBO

'数值型,日期,时间,邮戳类型可有缺省值和最大最小值
'设置缺省值
objFieldExtHead.SetDefVal ("1-1-1990")
'设置最大值
objFieldExtHead.SetMaxVal ("12-12-1999")
'设置最小值
objFieldExtHead.SetMinVal ("12-30-1990")
'设置字段形态信息,此处省略返回值处理
bResult = objFieldExtHead.SetShapeInfo(0, "字段形态0", "3-4-1977")
bResult = objFieldExtHead.SetShapeInfo(1, "字段形态1", "4-5-1987")

'是否有缺省值
If objFieldExtHead.HasDefVal Then
    '取缺省值
    objFieldExtHead.GetDefVal val
    '打印显示值
    Debug.Print val
End If

'是否有最大值
If objFieldExtHead.HasMaxVal Then
    '取最大值
    objFieldExtHead.GetMaxVal val
    Debug.Print val
End If

'是否有最小值
If objFieldExtHead.HasMinVal Then
    '取最小值
    objFieldExtHead.GetMinVal val
    Debug.Print val
End If

'取字段类型,显示
Debug.Print objFieldExtHead.GetFieldType

'显示字段形态信息
For nResult = 1 To objFieldExtHead.GetShapeInfoNum
'取字段形态信息
bResult = objFieldExtHead.GetShapeInfo(nResult - 1, ttlStr, val)
If bResult Then
Debug.Print ttlStr; " "; val
Else: Exit For
End If
Next nResult
'--------------------------------------------
'Field_Head的使用
'--------------------------------------------
'创建Field_Head对象实例
Dim objFieldHead1 As New Field_Head
Dim objFieldHead2 As New Field_Head
Dim buf() As Byte

With objFieldHead1
'编辑使能标志(0/1/2=不能/能/禁止)
.edit_enable = 1
'字段名称
.fieldname = "字段1"
'字段类型
.fieldtype = gisDOUBLE_TYPE
'字段字符长度
.msk_leng = 8
'小数位数
.point_leng = 4
'打印标志
.pt_flg = 1
'字段序号,依次为0,1,2...
.ptc_pos = 0
End With

With objFieldHead2
.edit_enable = 1
.fieldname = "字段2"
.fieldtype = gisSTR_TYPE
.msk_leng = 16
.point_leng = 0
.pt_flg = 1
.ptc_pos = 1
End With

'判断是否相等
If objFieldHead1.IsEqual(objFieldHead2) Then
    Debug.Print "两对象实例相等"
End If

Set objFieldHead2 = Nothing
'克隆出一个新的Field_Head
Set objFieldHead2 = objFieldHead1.Clone

'计算FIELD_HEAD对象所占的字节数
val = objFieldHead1.CalSize

' 保存CFiedl_Head到buf中
ReDim buf(255)
objFieldHead1.Save buf(0), val
'从buf中装入IField_Head

'判断是否有扩展属性
If Not objFieldHead1.HasField_ExtHead Then
'设置扩展属性
    If objFieldHead1.Set(objFieldExtHead) Then
        Set objFieldExtHead = Nothing
        '取字段扩展属性
        Set objFieldExtHead = objFieldHead1.GetExtField_Head
    End If
End If

'删除扩展字段
 If objFieldHead1.DelField_ExtHead Then
    Debug.Print "扩展字段已删除"
 End If

'从buf中装入IField_Head
'If objFieldHead1.Load(buf, Val) Then
' Debug.Print "原Field_Head对象内容已装入"
' End If

'复制，ptIFld0=NULL则清除
Set objFieldHead2 = Nothing
objFieldHead2.Set objFieldHead1

'--------------------------------------------
'Record_Head的使用
'--------------------------------------------
Dim objRecordHead As New Record_Head
Dim objRecordHead1 As Record_Head
Dim nCount As Integer
'分配空字段,此处为2个
objRecordHead.AllocEmptyField2

With objFieldHead1
'编辑使能标志(0/1/2=不能/能/禁止)
.edit_enable = 1
'字段名称
.fieldname = "字段1"
'字段类型
.fieldtype = gisDOUBLE_TYPE
'字段字符长度
.msk_leng = 8
'小数位数
.point_leng = 4
'打印标志
.pt_flg = 1
'字段序号,依次为0,1,2...
.ptc_pos = 0
End With

'添加字段,省略返回值
objRecordHead.AppendField objFieldHead1

With objFieldHead2
.edit_enable = 1
.fieldname = "字段2"
.fieldtype = gisSTR_TYPE
.msk_leng = 32
.point_leng = 0
.pt_flg = 1
.ptc_pos = 1
End With

bResult = objRecordHead.InsertField(objFieldHead2, 0)
If Not bResult Then
    Debug.Print "插入失败"
End If

'克隆一个新的Record_Head
Set objRecordHead1 = objRecordHead.Clone
'比较相同
If objRecordHead.IsEqual(objRecordHead1) Then
    Debug.Print "属性结构完全相同"
End If

'依次打印属性结构中的各字段名
For nCount = 0 To objRecordHead.numbfield - 1
    Debug.Print objRecordHead.fldEntry(nCount).fieldname
Next nCount

'计算Record_Head对象占用存储空间大小
Debug.Print "Record_Head1对象占用存储空间大小为：" _
; objRecordHead.CalSize

'保存Record_Head到buf中
ReDim buf(255)
lRes = objRecordHead.Save(buf(0), 256)
'从buf中装入Record_Head
objRecordHead.Load buf(0), lRes

'删除字段(方法一)
objRecordHead.DelField "字段2"
'删除字段(方法二)
objRecordHead.DelField2 0

'复制，pIStru0=NULL则清除所有字段头
objRecordHead.Set objRecordHead1

'--------------------------------------------
'Field的使用
'--------------------------------------------
Dim objField As New Field
Dim objField1 As New Field

'设置字段描述头
objField.FieldHD = objFieldHead1
'字段值,需要同字段描述头的类型相同
objField.Value = -342.12
'字段值的真实字节长度
Debug.Print objField.ActualSize

'设置字段描述头
objField1.FieldHD = objFieldHead2
'字段值,需要同字段描述头的类型相同
objField1.Value = "这是字段值"
'字段值的真实字节长度

'--------------------------------------------
'Record的使用
'--------------------------------------------
Dim objRecord As New Record
Dim objRecord1 As New Record

'设置属性结构
objRecord.hd = objRecordHead
'添加字段,省略返回值
objRecord.Append objField
'在index位置插入一个字段,省略返回值
objRecord.Insert 0, objField1

'分别取记录里的字段名，字段值，并显示
For nCount = 0 To objRecord.Count - 1
    Debug.Print objRecord.Item(nCount).FieldHD.fieldname _
    ; " "; objRecord.Value(nCount)
Next nCount

'复制记录
objRecord1.Set objRecord

'删除记录中的字段,省略返回值
objRecord1.Remove 1

'--------------------------------------------
'RecordSet的使用
'--------------------------------------------
Dim objRecordSet As New Recordset

'添加一条记录，此处只有两个字段
objRecordSet.Append objRecord
'以下再添加两条记录
objRecord.Value(0) = 235.3
objRecord.Value(1) = "第二记录对应值"
objRecordSet.Append objRecord

objRecord.Value(0) = 235.3
objRecord.Value(1) = "第三记录对应值"
objRecordSet.Append objRecord

'书签,相当于RecordSet中记录的序号,第1条记录从1开始
'设置当前位置为第一条记录
objRecordSet.Bookmark = 1

'更新第一条记录
objRecord.Value(0) = 567.12
objRecord.Value(1) = "更新为第一记录对应值"
objRecordSet.Update objRecord

'将当前指针移到最后一条记录
objRecordSet.MoveLast

'当前记录位置是否在RecordSet中的第一条记录之前
While Not objRecordSet.BOF
'将当前指针前移一条记录,省略返回值
objRecordSet.MovePrevious
Wend

'以下依次在“立即”窗口中显示各条记录值
'将当前指针移到第一条记录,省略返回值
objRecordSet.MoveFirst
Do
For nCount = 0 To objRecordSet.numbfield - 1
Debug.Print objRecordSet.hd(nCount).fieldname _
; "------"; objRecordSet.Record.Value(nCount)
Next nCount
'将当前指针后移一条记录
    If Not objRecordSet.MoveNext Then
    Exit Do
End If
'直到当前记录位置在RecordSet中的最后一条记录之后
Loop While objRecordSet.EOF

'从start指定的位置开始移numRecords条记录
If objRecordSet.Move(1, gisBookmarkFirst) Then
    '删除当前位置记录
    objRecordSet.Remove
End If

'释放对象实例
Set objField = Nothing
Set objField1 = Nothing
Set objRecord = Nothing
Set objRecord1 = Nothing
Set objRecordSet = Nothing
Set objFieldHead1 = Nothing
Set objFieldHead2 = Nothing
Set objRecordHead = Nothing
Set objRecordHead1 = Nothing
Set objFieldExtHead = Nothing
End Sub

Private Sub CalLinLenAndDot_Click()
Dim la0 As New D_Dot '直线1
Dim la1 As New D_Dot
Dim lb0 As New D_Dot '直线2
Dim lb1 As New D_Dot
Dim xy As D_Dot       '交点
Dim length  As Double '长度
Dim DotSet As D_DotSet

'计算两直线段的交点
la0.x = 50
la0.y = 100
la1.x = 150
la1.y = 100
lb0.x = 100
lb0.y = 50
lb1.x = 100
lb1.y = 150

'计算交点
bRes = CalCrossDot(la0, la1, lb0, lb1, xy)
If bRes Then
Debug.Print "交点坐标为:("; xy.x; ","; xy.y; ")"
End If

'计算线段长度 (方法一)
length = SegmentLength(la0, la1)
Debug.Print "线段长度为："; length

'计算线段长度 (方法二)
length = SegmentLength1(100, 50, 100, 150)
Debug.Print "线段长度为："; length

'计算线段长度 (方法三)
Set DotSet = New D_DotSet
DotSet.Append2 la0
DotSet.Append2 la1
length = CalculateLength(DotSet)
Debug.Print "线段长度为："; length

Set xy = Nothing
Set la0 = Nothing
Set la1 = Nothing
Set lb0 = Nothing
Set lb1 = Nothing
Set DotSet = Nothing
End Sub

Private Sub ClockAndCursor_Click()
Dim i, j, k As Long
'走钟与光标适合长时间等待时的操作

'开始显示等待光标
StartWait

'开始时钟光标
StartClockCursor

For i = 1 To 100
    For j = 1 To 100
        For k = 1 To 10
'开始走钟
GoingClockCursor
        Next k
    Next j
Next i

'还原光标
EndClockCursor

'结束显示等待光标
EndWait
End Sub

Private Sub CompMapParam_Click()
Dim PntAi As PntArea
Dim inf0 As Pnt_Info
Dim inf1 As Pnt_Info
Dim pad As Pnt_Pad

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

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