📄 shapefiletosde.frm
字号:
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "Comdlg32.ocx"
Begin VB.Form frmShapefiletoSDE
BorderStyle = 1 'Fixed Single
Caption = "Shapefile文件数据到SDE"
ClientHeight = 7215
ClientLeft = 45
ClientTop = 435
ClientWidth = 7920
BeginProperty Font
Name = "宋体"
Size = 11.25
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "ShapefiletoSDE.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 7215
ScaleWidth = 7920
StartUpPosition = 2 '屏幕中心
Begin MSComDlg.CommonDialog cdgbrouse
Left = 4680
Top = 120
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.CommandButton cmdexit
Caption = "取消(&C)"
Height = 495
Left = 4800
TabIndex = 18
Top = 6600
Width = 1935
End
Begin VB.CommandButton cmdoutput
Caption = "确定(&O)"
Height = 495
Left = 1080
TabIndex = 17
Top = 6600
Width = 2175
End
Begin VB.Frame Frame2
Caption = "数据库设置"
Height = 2775
Left = 240
TabIndex = 3
Top = 3600
Width = 7455
Begin VB.TextBox txtversion
Height = 375
Left = 4913
TabIndex = 16
Text = "sde.yfzh"
Top = 1680
Width = 1575
End
Begin VB.TextBox txtuser
Height = 375
Left = 4913
TabIndex = 15
Text = "sde"
Top = 1080
Width = 1575
End
Begin VB.TextBox txtservice
Height = 375
Left = 4913
TabIndex = 14
Text = "esri_sde"
Top = 480
Width = 1575
End
Begin VB.TextBox txtpassword
Height = 375
Left = 1433
TabIndex = 13
Text = "sde"
Top = 1680
Width = 1575
End
Begin VB.TextBox txtdatabase
Height = 375
Left = 1433
TabIndex = 12
Top = 1080
Width = 1575
End
Begin VB.TextBox txtserver
Height = 375
Left = 1433
TabIndex = 11
Text = "yfzh"
Top = 480
Width = 1575
End
Begin VB.CommandButton cmdconnect
Caption = "测试连接(&T)"
Height = 375
Left = 5280
TabIndex = 10
Top = 2280
Width = 1815
End
Begin VB.Label Label6
Caption = "版本"
Height = 375
Left = 4080
TabIndex = 9
Top = 1680
Width = 855
End
Begin VB.Label Label5
Caption = "用户"
Height = 375
Left = 4080
TabIndex = 8
Top = 1080
Width = 615
End
Begin VB.Label Label4
Caption = "服务"
Height = 375
Left = 4080
TabIndex = 7
Top = 480
Width = 1095
End
Begin VB.Label Label3
Caption = "密码"
Height = 255
Left = 480
TabIndex = 6
Top = 1680
Width = 735
End
Begin VB.Label Label2
Caption = "数据库"
Height = 375
Left = 480
TabIndex = 5
Top = 1080
Width = 735
End
Begin VB.Label Label1
Caption = "服务器"
Height = 375
Left = 480
TabIndex = 4
Top = 480
Width = 855
End
End
Begin VB.Frame Frame1
Caption = "选择欲导出的数据"
Height = 3135
Left = 240
TabIndex = 0
Top = 240
Width = 7455
Begin VB.CommandButton cmdbrouse
Caption = "添加数据(&A)"
Height = 495
Left = 5880
TabIndex = 2
Top = 360
Width = 1455
End
Begin VB.ListBox lstlayers
Height = 2355
Left = 240
Style = 1 'Checkbox
TabIndex = 1
Top = 360
Width = 5535
End
End
End
Attribute VB_Name = "frmShapefiletoSDE"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim pproperty As IPropertySet
Public Property Let Application(ByRef pApp As IApplication)
Set m_pApp = pApp
End Property
Private Sub cmdbrouse_Click()
Adddata
End Sub
Private Sub cmdconnect_Click()
On Error GoTo connectError
Set pproperty = New PropertySet
With pproperty
.SetProperty "server", txtserver.Text
.SetProperty "instance", txtservice.Text
.SetProperty "user", txtuser.Text
.SetProperty "database", txtdatabase.Text
.SetProperty "password", txtpassword.Text
.SetProperty "version", txtversion.Text
End With
cmdoutput.Enabled = sdeConnect(pproperty)
Exit Sub
connectError:
MsgBox Err.Number + " " + Err.Description, vbInformation, "Shapefile入库"
End Sub
Private Sub cmdexit_Click()
Unload Me
End Sub
Private Sub cmdoutput_Click()
On Error GoTo errortip:
Dim lnum As Integer
Dim strpath As String
Dim strfile As String
Dim pwsfact As IWorkspaceFactory
Dim pWorkspace As IFeatureWorkspace
Dim pfeatureclass As IFeatureClass
For lnum = 0 To lstlayers.ListCount - 1
If lstlayers.Selected(lnum) Then
Dim strlistitem As String
strlistitem = lstlayers.List(lnum)
Dim shapename As String
If Not islayer(strlistitem) Then '调用islayer判断是当前文档中的图层还是浏览添加的shapefile
strpath = GetName(lstlayers.List(lnum), 0)
strfile = GetName(lstlayers.List(lnum), 1)
Set pwsfact = New ShapefileWorkspaceFactory
Set pWorkspace = pwsfact.OpenFromFile(strpath, 0)
shapename = Left(strfile, Len(strfile) - 4)
Set pfeatureclass = pWorkspace.OpenFeatureClass(shapename)
Else
Dim player As IFeatureLayer
Set player = pmap.Layer(layerpos(strlistitem)) '调用layerpos找到该层
shapename = strlistitem
Set pfeatureclass = player.FeatureClass
End If
Dim pshapegeodata As IGeoDataset
Set pshapegeodata = pfeatureclass
Dim pdataset As IDataset
Set pdataset = pfeatureclass
Dim pinfcname As IFeatureClassName
Set pinfcname = pdataset.FullName
Dim poutfact As IWorkspaceFactory
Set poutfact = New SdeWorkspaceFactory
Dim powset As IPropertySet
Set powset = New PropertySet '进行连接属性的设置
Set powset = pproperty
Dim poutws As IWorkspace
Set poutws = poutfact.Open(powset, 0)
Set pdataset = poutws
Dim poutwsname As IName
Set poutwsname = pdataset.FullName
' MsgBox "指定的工作空间成功创建", vbOKOnly, "转化提示"
Dim poutfcname As IFeatureClassName
Set poutfcname = New FeatureClassName
Dim poutdataset As IDatasetName
Set poutdataset = poutfcname
poutdataset.Name = shapename
Set poutdataset.WorkspaceName = poutwsname
Dim penumdataset As IEnumDataset
Set penumdataset = poutws.Datasets(esriDTFeatureDataset)
Dim dataset As IDataset
Set dataset = penumdataset.Next
Dim fdsn As String
' fdsn = "xxxxx" '进行自定义
Dim has As Integer
Do While Not dataset Is Nothing
If dataset.Name = "SDE." + fdsn Then
has = 1
Exit Do
End If
Set dataset = penumdataset.Next
Loop
Dim psr As ISpatialReference
Dim pgds As IGeoDataset
Set pgds = pfeatureclass
Set psr = pgds.SpatialReference '获得参考系统
Dim pfdset As IFeatureDataset
Dim poutdatasetname As IFeatureDatasetName
Dim pfeatureworkspace As IFeatureWorkspace
Set pfeatureworkspace = poutws
If has = 0 Then
If fdsn <> "" Then
Set pfdset = pfeatureworkspace.CreateFeatureDataset(fdsn, psr) '参考系选择
Set poutdatasetname = pfdset.FullName
' MsgBox "指定featuredataset成功创建!", vbOKOnly, "转化提示"
Else
Set poutdatasetname = Nothing
'MsgBox "生成featureclass不包含于featuredataset内!", vbOKOnly, "转化提示"
End If
Else
Set pfdset = pfeatureworkspace.OpenFeatureDataset(fdsn)
Set poutdatasetname = pfdset.FullName
' MsgBox "指定featuredataset成功打开!", vbOKOnly, "转化提示"
End If
Dim pfieldcheck As IFieldChecker
Set pfieldcheck = New FieldChecker
pfieldcheck.InputWorkspace = pWorkspace
Dim pfields As IFields
Set pfields = pfeatureclass.Fields
Dim poutfields As IFields
Set pfieldcheck.ValidateWorkspace = poutws
Dim penumfielderror As IEnumFieldError
pfieldcheck.Validate pfields, penumfielderror, poutfields '进行输出字段的设定
If Not penumfielderror Is Nothing Then
Dim pfielderror As IFieldError
Set pfielderror = penumfielderror.Next
Do While Not pfielderror Is Nothing
Dim serror As String
Dim pInField As IField
Dim pOutField As IField
Set pInField = pfields.Field(pfielderror.FieldIndex)
Set pOutField = poutfields.Field(pfielderror.FieldIndex)
serror = serror + pOutField.Name & vbTab & "原因: " & pInField.Name & " " & GetFieldError(pfielderror.FieldError) + vbCr
Set pfielderror = penumfielderror.Next
Loop
'MsgBox "导入 " + pfeatureclass.AliasName + ":" + vbCr + serror, vbOKOnly, "字段错误检查"
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -