📄 createfeature.frm
字号:
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Object = "{5E9E78A0-531B-11CF-91F6-C2863C385E30}#1.0#0"; "msflxgrd.ocx"
Begin VB.Form CreateFeature
Caption = "Form1"
ClientHeight = 6765
ClientLeft = 60
ClientTop = 345
ClientWidth = 8325
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 6765
ScaleWidth = 8325
StartUpPosition = 3 'Windows Default
Begin MSComctlLib.Toolbar Toolbar1
Align = 1 'Align Top
Height = 750
Left = 0
TabIndex = 0
Top = 0
Width = 8325
_ExtentX = 14684
_ExtentY = 1323
ButtonWidth = 4842
ButtonHeight = 582
Appearance = 1
TextAlignment = 1
_Version = 393216
BeginProperty Buttons {66833FE8-8583-11D1-B16A-00C0F0283628}
NumButtons = 5
BeginProperty Button1 {66833FEA-8583-11D1-B16A-00C0F0283628}
Caption = "连接Access数据库"
Key = "OpenAccess"
EndProperty
BeginProperty Button2 {66833FEA-8583-11D1-B16A-00C0F0283628}
Caption = "创建一个地物类"
Key = "OpenFeatureClass"
EndProperty
BeginProperty Button3 {66833FEA-8583-11D1-B16A-00C0F0283628}
Caption = "非事务态增加一个地物"
Key = "AddFeature"
EndProperty
BeginProperty Button4 {66833FEA-8583-11D1-B16A-00C0F0283628}
Caption = "编辑态增加一个地物"
Key = "AddFeature2"
EndProperty
BeginProperty Button5 {66833FEA-8583-11D1-B16A-00C0F0283628}
Caption = "事务态非编辑态增加一个地物"
Key = "AddFeature3"
EndProperty
EndProperty
End
Begin MSComctlLib.ImageList ImageList1
Left = 5100
Top = 6060
_ExtentX = 1005
_ExtentY = 1005
BackColor = -2147483643
ImageWidth = 16
ImageHeight = 16
MaskColor = 12632256
_Version = 393216
BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628}
NumListImages = 3
BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "CreateFeature.frx":0000
Key = ""
EndProperty
BeginProperty ListImage2 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "CreateFeature.frx":0353
Key = ""
EndProperty
BeginProperty ListImage3 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "CreateFeature.frx":066D
Key = ""
EndProperty
EndProperty
End
Begin MSFlexGridLib.MSFlexGrid MSFlexGrid1
Height = 4965
Left = 60
TabIndex = 1
Top = 1170
Width = 8115
_ExtentX = 14314
_ExtentY = 8758
_Version = 393216
ScrollTrack = -1 'True
FillStyle = 1
AllowUserResizing= 1
End
End
Attribute VB_Name = "CreateFeature"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim cfeastore As New CFeatureStore
'*********************************************************************************
'** 函数名：Toolbar1_ButtonClick
'** 输 入： ByVal Button
'** 输 出：
'** 功能描述：点击Toolbar按钮，连接数据库并添加节点
'** 全局变量：
'** 调用模块：
'** 作 者：yubo
'** 日 期：2004-07-20
'** 修改者：yubo
'** 日 期：2004-07-20
'** 版 本：1.0
'*********************************************************************************
Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
On Error GoTo ERRHANDLER
Select Case Button.Key
Case "OpenAccess"
OpenAccess
Case "OpenFeatureClass" '打开一个地物类
openFeatureClass
Case "AddFeature" '非事务态增加一个地物
cfeastore.AddFeature
ShowAllFeature
Case "AddFeature2" '编辑态增加一个地物
cfeastore.AddFeature2
ShowAllFeature
Case "AddFeature3" '事务态非编辑态增加一个地物
cfeastore.AddFeature3
ShowAllFeature
Case Else
Exit Sub
End Select
Exit Sub
ERRHANDLER:
MsgBox "连接失败!", vbOKOnly + vbInformation, "系统提示"
End Sub
'*********************************************************************************
'** 函数名：openAccess
'** 输 入：
'** 输 出：
'** 功能描述：连接Access数据库
'** 全局变量：
'** 调用模块：
'** 作 者：yubo
'** 日 期：2005-11-03
'** 修改者：yubo
'** 日 期：2005-11-03
'** 版 本：1.0
'*********************************************************************************
Private Sub OpenAccess()
On Error GoTo ERRHANDLER
'定义组件AccessDatabaseFactory
Dim pFactory As New GeoStarCore.AccessDatabaseFactory
'定义组件ConnectProperties，并初始化
Dim pConn As New GeoStarCore.ConnectProperties ' 1
'pConn.Database = "D:\Geostar5.0\开发示例\示例代码\VB\GeoData\AccessData.mdb"
pConn.Database = App.Path + "\AccessData.mdb"
'打开一个与数据库连接
Set pDatabase = pFactory.OpenDatabase(pConn) ' 2
If pDatabase Is Nothing Then
MsgBox "连接失败!", vbOKOnly + vbInformation, "系统提示"
Else
MsgBox "连接成功!", vbOKOnly + vbInformation, "系统提示"
End If
Set pFactory = Nothing
Set pConn = Nothing
Exit Sub
ERRHANDLER:
MsgBox "连接失败!", vbOKOnly + vbInformation, "系统提示"
End Sub
Private Sub openFeatureClass()
On Error GoTo del
'连接数据库
Dim feaclsname As String
feaclsname = "点test_P1"
Deletenewfeacls feaclsname
Dim pfields As New GeoStarCore.Fields
Dim Field1 As New Field
Dim Field2 As New Field
Dim Field3 As New Field
Dim Field4 As New Field
Dim Field5 As New Field
Dim Field6 As New Field
Dim Field7 As New Field
Dim Field8 As New Field
Field1.Type = GEO_SMALLINT_TYPE
Field1.name = "tt1"
Field1.DefaultValue = CInt("11")
Field2.Type = GEO_INTEGER_TYPE
Field2.name = "tt2"
Field2.DefaultValue = CLng("123")
Field3.Type = GEO_SINGLE_TYPE
Field3.name = "tt3"
Field3.DefaultValue = CSng("123.456")
Field4.Type = GEO_DOUBLE_TYPE
Field4.name = "tt4"
Field4.DefaultValue = CDbl("123.45678")
Field5.Type = GEO_STRING_TYPE
Field5.name = "tt5"
Field5.DefaultValue = "xxxxabcde"
Field6.Type = GEO_BLOB_TYPE
Field6.name = "tt6"
Field7.Type = GEO_DATE_TYPE
Field7.name = "tt7"
Field8.Type = GEO_BLOB_TYPE
Field8.name = "tt8"
Set pfields.Field(0) = Field1
Set pfields.Field(1) = Field2
Set pfields.Field(2) = Field3
Set pfields.Field(3) = Field4
Set pfields.Field(4) = Field5
Set pfields.Field(5) = Field6
Set pfields.Field(6) = Field7
Set pfields.Field(7) = Field8
Dim pGeomColInfo As New GeometryColumnInfo
Dim pSpatialRef As New SpatialReference
Dim var As Variant
pGeomColInfo.SetXYDomain 0, 10000, 0, 10000
pGeomColInfo.SetXYTolerance 0.001, 0.001
pGeomColInfo.MapScale = 10000
pGeomColInfo.GeometryType = GEO_GEOMETRY_POINT
Set newfeacls = pDatabase.CreateFeatureClass(feaclsname, pfields, pGeomColInfo, pSpatialRef)
If Not (newfeacls Is Nothing) Then
MsgBox "创建点地物类成功！"
Else
MsgBox "创建点地物类失败!"
End If
Exit Sub
del:
MsgBox "创建点地物类失败"
End Sub
Private Sub Deletenewfeacls(name As String)
On Error GoTo del
Dim newfeacls As FeatureClass
Set newfeacls = pDatabase.openFeatureClass(name)
Dim dr As IDataRoom
Set dr = newfeacls
dr.Delete
Set dr = Nothing
Set newfeacls = Nothing
Exit Sub
del:
Exit Sub
End Sub
Public Sub ShowAllFeature()
Dim fcols As Fields
Dim fcol As Field
Dim colnum As Long
Dim i As Long
Dim j As Long
' Dim blob_id As Long
Dim rowid As Long
Dim feacursor As New FeatureCursor
Dim fea As IFeature
Dim strcols As String
Dim strVals As String
Dim feaval As Variant
Dim b_blob As Boolean
b_blob = False
Set feacursor = newfeacls.Search(Nothing)
Set fea = feacursor.NextRow
' If Not (fea Is Nothing) Then
Set fcols = newfeacls.Fields
colnum = fcols.Count
strcols = ""
strVals = ""
Me.MSFlexGrid1.Cols = colnum + 1
j = 0
Dim a() As Long
For i = 0 To colnum - 1
Set fcol = fcols.Field(i)
MSFlexGrid1.Col = i + 1
MSFlexGrid1.Row = 0
MSFlexGrid1.Text = "" + fcol.name
If fcol.Type = GEO_BLOB_TYPE Then
j = j + 1
End If
' strcols = strcols + fcol.name + "
Next
j = j - 1
If j >= 0 Then
ReDim a(j) As Long
End If
Dim k As Long
k = 0
Dim strname As String
For i = 0 To colnum - 1
Set fcol = fcols.Field(i)
strname = fcol.name
If fcol.Type = GEO_BLOB_TYPE Then
a(k) = i
k = k + 1
End If
Next
rowid = newfeacls.FeatureCount(Nothing) '得到属性字段的个数
MSFlexGrid1.Rows = rowid + 1
rowid = 1
k = 0
' Set fea = feacursor.NextRow
Do While Not (fea Is Nothing)
'strVals = strVals & rowid & " "
MSFlexGrid1.Col = 0
MSFlexGrid1.Row = rowid
MSFlexGrid1.Text = "" & rowid
For i = 0 To colnum - 1
MSFlexGrid1.Col = i + 1
MSFlexGrid1.Row = rowid
If j < 0 Then
feaval = fea.Value(i)
MSFlexGrid1.Text = "" & feaval
Else
For k = 0 To j
If i = a(k) Then
b_blob = True
Exit For
' Else
'strVals = strVals + "blob,"
' MSFlexGrid1.Text = "[blob]"
End If
Next
If b_blob = False Then
feaval = fea.Value(i)
MSFlexGrid1.Text = "" & feaval
Else
MSFlexGrid1.Text = "长二进制数据"
End If
b_blob = False
End If
Next
' strVals = strVals + Chr(13)
rowid = rowid + 1
Set fea = Nothing
Set fea = feacursor.NextRow
' feaval = Nothing
Loop
' MSFlexGrid1.Cols = colnum + 1
' MSFlexGrid1.Rows = rowid + 1
'TextnewfeaclsTable.Text = strcols + Chr(13) + strVals
Set feacursor = Nothing
Set fcols = Nothing
Set fcol = Nothing
Set fea = Nothing
Show
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -