test_basatt.frm

mapgis二次开发,vb示例 mapgis二次开发,vb示例

VERSION 5.00
Begin VB.Form AttOper 
   AutoRedraw      =   -1  'True
   Caption         =   "属性操作"
   ClientHeight    =   3555
   ClientLeft      =   165
   ClientTop       =   735
   ClientWidth     =   5385
   Icon            =   "TEST_B~1.frx":0000
   LinkTopic       =   "FormBas"
   ScaleHeight     =   3555
   ScaleWidth      =   5385
   StartUpPosition =   3  'Windows Default
   Begin VB.Menu ATT_STRU 
      Caption         =   "属性结构"
      Begin VB.Menu GetAttStru 
         Caption         =   "取属性结构"
      End
      Begin VB.Menu APPENDFLD 
         Caption         =   "添加字段"
      End
      Begin VB.Menu IDMN_STRU_DEL 
         Caption         =   "删除字段"
      End
      Begin VB.Menu IDMN_STRU_MOD 
         Caption         =   "修改字段"
      End
   End
   Begin VB.Menu ATT 
      Caption         =   "属性"
      Begin VB.Menu GATATT 
         Caption         =   "取属性"
      End
      Begin VB.Menu WRITEATT 
         Caption         =   "写一条属性记录"
      End
   End
End
Attribute VB_Name = "AttOper"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'取属性结构信息(包括字段总数，
'每一个字段的字段名称，字段类型，
'字段字符长度,字段序号,小数位数)
Private Sub GetAttStru_Click()

Dim pntObj As PntArea

Dim fldNum As Integer       '字段数
Dim rcdNum As Long          '纪录数

Dim fldname As String       '字段名称
Dim fldtype As Integer      '字段类型
Dim msk_leng As Long        '字段字符长度
Dim ptc_pos As Integer      '字段序号
Dim point_leng As Integer   '小数位数

Dim i As Integer

'取点属性结构信息
Set pntObj = New PntArea
If (pntObj.Load()) Then
    
    fldNum = pntObj.ATT.stru.numbfield

    
    For i = 0 To pntObj.ATT.stru.numbfield - 1
        fldname = pntObj.ATT.stru(i).fieldname
        fldtype = pntObj.ATT.stru(i).fieldtype
        msk_leng = pntObj.ATT.stru(i).msk_leng
        point_leng = pntObj.ATT.stru(i).point_leng
        ptc_pos = pntObj.ATT.stru(i).ptc_pos
    Next i
    
End If

Set pntObj = Nothing

End Sub

'添加字段
Private Sub APPENDFLD_Click()
Dim pntObj As PntArea
Dim linObj As LinArea
Dim regObj As RegArea
Dim fldinf As Field_Head
Dim mystru As Record_Head
Dim flag As Boolean

Set pntObj = New PntArea
If (pntObj.Load()) Then

'构造需添加的字段信息
    Set fldinf = New Field_Head
    fldinf.fieldname = "newflddouble"
    fldinf.fieldtype = gisDOUBLE_TYPE
    fldinf.point_leng = 0.3
    fldinf.msk_leng = 10
    fldinf.edit_enable = 1
    fldinf.ptc_pos = -1
'方法1 ...添加字段
    flag = pntObj.ATT.stru.AppendField(fldinf)
'    fldinf.fieldname = "newfldstr"
'    fldinf.fieldtype = gisSTR_TYPE
'    fldinf.msk_leng = 32
'    fldinf.edit_enable = 1
'    fldinf.ptc_pos = -1
'    flag = pntObj.Att.stru.AppendField(fldinf)
'方法2：...添加字段
'    Set mystru = pntObj.Att.stru.Clone()
'    flag = mystru.AppendField(fldinf)
'    flag = pntObj.Att.stru.Set(mystru)
'    Set mystru = Nothing
    
    Set fldinf = Nothing

End If

pntObj.Save
Set pntObj = Nothing

End Sub
'删除字段
Private Sub IDMN_STRU_DEL_Click()

Dim pntObj As PntArea
Dim fldinf As Field_Head
Dim mystru As Record_Head
Dim flag As Boolean
Dim i As Long

Set pntObj = New PntArea
If (pntObj.Load()) Then
    
    '方法1：根据字段名称删除字段
    'flag = pntObj.ATT.stru.DelField("mystr")
    
    '方法2: 根据字段序号删除字段
    flag = pntObj.ATT.stru.DelField2(0)
    
    '循环删除字段
'    If (pntObj.ATT.stru.numbfield >= 1) Then
'        For i = pntObj.ATT.stru.numbfield - 1 To 0 Step -1
'            flag = pntObj.ATT.stru.DelField2(i)
'        Next i
'    End If
    
End If

Set pntObj = Nothing

End Sub
'修改字段 (字段名称，字段类型等等）
Private Sub IDMN_STRU_MOD_Click()
Dim pntObj As PntArea
Dim mystru As Record_Head
Dim myfld As Field_Head
Dim flag As Boolean

Set pntObj = New PntArea
If (pntObj.Load()) Then
   Set mystru = pntObj.ATT.stru.Clone()
   Set myfld = mystru(0)
   
   myfld.fieldname = "myddd"
   myfld.fieldtype = gisDOUBLE_TYPE
   myfld.point_leng = 3
   myfld.msk_leng = 15
   mystru(0) = myfld
   
   flag = pntObj.ATT.stru.Set(mystru)
   Set myfld = Nothing
   Set mystru = Nothing
   
End If

Set pntObj = Nothing
End Sub
'取属性
Private Sub GATATT_Click()
Dim pntObj As PntArea
Dim i, j As Long
Dim val As Variant
Dim ATT As Record
Dim flag As Integer

'取点属性  ===(包括取二进制字段值)
Set pntObj = New PntArea
If (pntObj.Load()) Then
    For i = 1 To pntObj.Count
        flag = pntObj.ATT.Get(i, ATT)
        For j = 0 To pntObj.ATT.stru.numbfield - 1
            val = ATT.Item(j).Value
        Next j
        Set ATT = Nothing
    Next i
End If
Set pntObj = Nothing


End Sub

'写属性纪录
Private Sub WRITEATT_Click()
Dim TblAi As TblArea
Dim i As Long
Dim val As Variant
Dim ATT As Record
Dim flag As Boolean
Dim byteval(9) As Byte
Dim variantval(9)
Dim aType As Enum_Field_Type

'写点属性id值,如下写一条属性记录：
Set TblAi = New TblArea
If (TblAi.Load()) Then
    '取一条纪录
    flag = TblAi.Get(1, ATT)
    If Not flag Then
     GoTo EndWrite
    End If
    
    For i = 0 To TblAi.stru.numbfield - 1
        aType = ATT.Item(i).FieldHD.fieldtype
    Select Case aType
    Case gisBIN_DATA_TYPE
        For j = 0 To 9                 '写二进制值
           byteval(j) = 10 + j
        Next j
        ATT.Value(i) = byteval
    '此处还可以根据字段名来赋值，如：
    'att.Value("ID") =byteval
    Case gisBOOL_TYPE       '布尔型
        ATT.Value(i) = True '或者0/1
    Case gisBYTE_TYPE       '字节型
        ATT.Value(i) = 1
    Case gisDATE_TYPE       '日期型
        ATT.Value(i) = "2000-1-20"
    Case gisDOUBLE_TYPE     '双精度型
        ATT.Value(i) = 10.0567
    Case gisFLOAT_TYPE      '浮点型
        ATT.Value(i) = 4.5
    Case gisLONG_TYPE       '长整型
        ATT.Value(i) = 43425345
    Case gisNUMBERIC_TYPE   '数字型
        ATT.Value(i) = 43.42
    Case gisSHORT_TYPE      '短整型
        ATT.Value(i) = 4
    Case gisSTR_TYPE        '字符串
        ATT.Value(i) = "字符串"
    Case gisTIME_TYPE       '时间型
        ATT.Value(i) = "20:17:50"
    Case gisTIMESTAMP_TYPE  '邮戳型
        ATT.Value(i) = "2000-10-10 22:15:36"
    Case gisMAP_TYPE        '地图型
    
    Case gisPICTURE_TYPE    '图象型
    
    Case gisSOUND_TYPE      '声音型
    
    Case gisTABLE_TYPE      '表格数据
    
    Case gisTEXT_TYPE       '文本型
                                                             
    Case gisEXT_TYPE        '扩展型
            
    Case gisVIDEO_TYPE      '视频图象型
    
    Case gisUNKNOWN_TYPE    '未知类型
        MsgBox "未知类型！"
    End Select
    Next i
End If
        
'写第一条属性记录
flag = TblAi.Write(1, ATT)

EndWrite:
Set ATT = Nothing
Set TblAi = Nothing
End Sub