|
'Code updated September 2nd 2009 'reason: allow for fgdb creation from new 9.3 SGID structure '
This e-mail address is being protected from spam bots, you need JavaScript enabled to view it
'These VBA functions are used to clip and export the feature classes on the SGID SDE database server
'into zipped the file geodatabase and shapefile products available from AGRC's FTP site. To use the
'script, make a selection of feature classes or feature datasets in the ArcCatalog Contents view
'(usually the right side of ArcCatalog). Then run the CreateOutputFromArcCatalogSelection() VBA sub
'procedure.
Private m_deleteColl As Collection
Private m_pSDEFWS As IFeatureWorkspace
Private m_pSDEWSFactory As IWorkspaceFactory
Private m_GP 'As Object
Private m_CoClipFC As IFeatureClass
Private m_outputLocation As String
Private m_sourceMetadata As IMetadata
Private Sub CreateOutputFromArcCatalogSelection()
Set m_GP = CreateObject("esriGeoprocessing.GPDispatch.1")
Set m_deleteColl = New Collection
m_outputLocation = "d:\temp\"
m_GP.RefreshCatalog m_outputLocation
Open m_outputLocation & "sdeexp_logfile_" & Format(Now, "yymmddhhmm") & ".txt" For Output As #1
Open m_outputLocation & "sdeexp_errfile_" & Format(Now, "yymmddhhmm") & ".txt" For Output As #2
If Not m_GP.Exists(m_outputLocation & "NAD83\") Then
m_GP.CreateFolder m_outputLocation, "NAD83"
End If
m_outputLocation = m_outputLocation & "NAD83"
m_GP.ScratchWorkspace = m_outputLocation
Call openSDEWS
Set m_CoClipFC = m_pSDEFWS.OpenFeatureClass("SGID93.Boundaries.Counties")
Dim pGxApp As IGxApplication
Dim pSelGxObject As IGxObject
Dim pGxSel As IGxSelection
Dim pEnumGxObjSel As IEnumGxObject
Set pGxApp = Application
Set pGxSel = pGxApp.Selection
Set pEnumGxObjSel = pGxSel.SelectedObjects
pEnumGxObjSel.Reset
Set pSelGxObject = pEnumGxObjSel.Next
Do Until pSelGxObject Is Nothing
If pSelGxObject.Category = "SDE Feature Class" Then
CreateOutputFromFeatureClassGxObject pSelGxObject
ElseIf pSelGxObject.Category = "SDE Feature Dataset" Then
Dim pGxObjContainer As IGxObjectContainer
Dim pEnumGxObj As IEnumGxObject
Dim pCurrGxObject As IGxObject
Set pGxObjContainer = pSelGxObject
If pGxObjContainer.HasChildren Then
Set pEnumGxObj = pGxObjContainer.Children
If Not pEnumGxObj Is Nothing Then
Set pCurrGxObject = pEnumGxObj.Next
Do Until pCurrGxObject Is Nothing
If pCurrGxObject.Category = "SDE Feature Class" Then
Debug.Print pCurrGxObject.FullName
Print #1, "----------------------------------"
Print #1, pCurrGxObject.FullName
CreateOutputFromFeatureClassGxObject pCurrGxObject
End If
Set pCurrGxObject = pEnumGxObj.Next
Loop
End If
End If
End If
Set pSelGxObject = pEnumGxObjSel.Next
Loop
Close #1
Close #2
End Sub
Private Sub CreateOutputFromFeatureClassGxObject(pInGxObject As IGxObject)
Dim pGXDataset As IGxDataset
Dim pDataset As IDataset
Dim pFC As IFeatureClass
Dim pCoClipFC As IFeatureClass
Dim pCofcursor As IFeatureCursor
Dim pcofeature As IFeature
Dim pCoShape As IPolygon
Dim pCoShapeTopOp As ITopologicalOperator
Dim countyName As String
Dim pDatasetName As IDatasetName
Dim pSQLPrivilege As ISQLPrivilege
Set pGXDataset = pInGxObject
Set pDatasetName = pGXDataset.datasetname
'Set pSQLPrivilege = pDatasetName 'QI
'If pSQLPrivilege.SQLPrivileges / 2 <> CInt(pSQLPrivilege.SQLPrivileges / 2) And _
pSQLPrivilege.SQLPrivileges > 0 Then
Set pDataset = pGXDataset.Dataset
Set pFC = pDataset 'QI
Debug.Print " **** Starting Statewide: " & pDataset.name & " (" & Now & ")"
Print #1, " **** Starting Statewide: " & pDataset.name & " (" & Now & ")"
CreateFileBasedOutputFromFC pFC, m_outputLocation, Nothing, "statewide"
Set pCofcursor = m_CoClipFC.Search(Nothing, True)
Set pcofeature = pCofcursor.NextFeature
Do Until pcofeature Is Nothing
countyName = UCase(Replace(pcofeature.Value(m_CoClipFC.FindField("NAME")), " ", ""))
Debug.Print " **** Starting " & countyName & " County: " & pDataset.name & " (" & Now & ")"
Print #1, " **** Starting " & countyName & " County: " & pDataset.name & " (" & Now & ")"
Set pCoShape = pcofeature.ShapeCopy
Set pCoShapeTopOp = pCoShape 'QI
pCoShapeTopOp.Simplify
CreateFileBasedOutputFromFC pFC, m_outputLocation, pCoShape, countyName
Set pcofeature = pCofcursor.NextFeature
Loop
Dim emptyGDBPath As Variant
Set m_pSDEFWS = Nothing
Set m_pSDEWSFactory = Nothing
For Each emptyGDBPath In m_deleteColl
Debug.Print " Delete " & emptyGDBPath
Print #1, " Deleting, no features in " & emptyGDBPath
Kill emptyGDBPath & "\*"
RmDir emptyGDBPath
Next
Set m_deleteColl = New Collection
'Else
'Debug.Print "NO SELECT RIGHT: " & pgxDataset.datasetname.name
'End If
End Sub
Public Sub openSDEWS()
Dim pCOWS As IWorkspace
Dim pPropSet As IPropertySet
Set pPropSet = New PropertySet
With pPropSet
.SetProperty "Server", "direct connect"
.SetProperty "Instance", "sde:sqlserver:mspd2.sqldc.dts.utah.gov\AGRC"
.SetProperty "user", "agrc"
.SetProperty "database", "SGID93"
.SetProperty "password", "agrc"
.SetProperty "version", "sde.default"
End With
Set m_pSDEWSFactory = New SdeWorkspaceFactory
Set m_pSDEFWS = m_pSDEWSFactory.Open(pPropSet, 0)
End Sub
Public Function createFileGDBWorkspace(location As String, name As String) _
As IWorkspaceName
On Error GoTo EH
Set createFileGDBWorkspace = Nothing
' create the FileGDB Workspace factory
Dim pWorkspaceFactory As IWorkspaceFactory
'Set pWorkspaceFactory = New AccessWorkspaceFactory
Set pWorkspaceFactory = New FileGDBWorkspaceFactory
Dim pWorkspaceName As IWorkspaceName
Set pWorkspaceName = pWorkspaceFactory.Create(location, name, Nothing, 0)
Set createFileGDBWorkspace = pWorkspaceName
Exit Function
EH:
MsgBox Err.Number, vbInformation, "createFileGDBWorkspace"
End Function
Private Function pGDBExists(mypath As String) As Boolean
Dim pGPValue As IGPValue
Set pGPValue = New DEWorkspace
pGPValue.SetAsText mypath
Dim pDEUtil As IDEUtilities
Set pDEUtil = New DEUtilities
pGDBExists = pDEUtil.Exists(pGPValue)
End Function
Private Function CreateNew_FC_ForExistingFC(pInFC As IFeatureClass, pFeatureWorkspace As IFeatureWorkspace) As IFeatureClass 'must be sde feature class
Dim fcname As String
Dim fDSname As String
Dim mypath As String
Dim pInFCDataset As IDataset
Dim pInFields As IFields
Dim pClone As IClone
Dim pNewField As IField
Dim pNewFieldEdit As IFieldEdit
Dim pNewFields As IFields
Dim pNewFieldsEdit As IFieldsEdit
Dim pUID As IUID
Set pInFCDataset = pInFC 'qi
fcname = Replace(pInFCDataset.name, ".", "_")
'Get editiable, non shape field count
Dim i As Integer
Dim fCnt As Integer
fCnt = 0
For i = 0 To pInFC.Fields.FieldCount - 1
If pInFC.Fields.Field(i).Editable And pInFC.Fields.Field(i).Type <> esriFieldTypeGeometry And UCase(Left(pInFC.Fields.Field(i).name, 8)) <> "OBJECTID" Then
If InStr(pInFC.Fields.Field(i).name, ".") = 0 Then
fCnt = fCnt + 1
End If
End If
Next i
Set pNewFields = New Fields
Set pNewFieldsEdit = pNewFields
pNewFieldsEdit.FieldCount = fCnt + 2 'for geometry field and ObjectID
Set pNewField = New Field
Set pNewFieldEdit = pNewField
With pNewFieldEdit
.name = "OBJECTID"
.Type = esriFieldTypeOID
End With
Set pNewFieldsEdit.Field(0) = pNewField
Dim shpFieldName As String
shpFieldName = pInFC.ShapeFieldName
Dim pOldShapeField As IField
Set pOldShapeField = pInFC.Fields.Field(pInFC.FindField(shpFieldName))
Dim pOldGeometryDef As IGeometryDef
Dim pNewGeometryDef As IGeometryDef
Dim pNewGeometryDefEdit As IGeometryDefEdit
Set pOldGeometryDef = pOldShapeField.GeometryDef
Set pNewGeometryDef = New GeometryDef
Set pNewGeometryDefEdit = pNewGeometryDef
With pNewGeometryDefEdit
Set .SpatialReference = pOldGeometryDef.SpatialReference
.GeometryType = pOldGeometryDef.GeometryType
.GridCount = 2
.GridSize(0) = calcSpatialIndex(pInFC)
.GridSize(1) = calcSpatialIndex(pInFC) * 3
.HasM = pOldGeometryDef.HasM
.HasZ = pOldGeometryDef.HasZ
End With
Set pNewField = New Field
Set pNewFieldEdit = pNewField
With pNewFieldEdit
.name = shpFieldName
.Type = pOldShapeField.Type
Set .GeometryDef = pNewGeometryDef
End With
Set pNewFieldsEdit.Field(1) = pNewField
Dim addCnt As Integer
addCnt = 0
For i = 0 To pInFC.Fields.FieldCount - 1
If pInFC.Fields.Field(i).Editable And pInFC.Fields.Field(i).Type <> esriFieldTypeGeometry _
And UCase(Left(pInFC.Fields.Field(i).name, 8)) <> "OBJECTID" And InStr(pInFC.Fields.Field(i).name, ".") = 0 Then
If Left(pInFC.Fields.Field(i).name, 10) = "TOTAL_CUM_" Then
Set pNewField = New Field
Set pNewFieldEdit = pNewField
With pNewFieldEdit
.name = "TCUM_" & Replace(pInFC.Fields.Field(i).name, "TOTAL_CUM_", "")
.Type = pInFC.Fields.Field(i).Type
End With
Else
Set pClone = pInFC.Fields.Field(i)
Set pNewField = New Field
Set pNewField = pClone.Clone
End If
Set pNewFieldsEdit.Field(addCnt + 2) = pNewField
addCnt = addCnt + 1
End If
Next i
Set pUID = New UID
pUID.Value = "esriGeoDatabase.Feature"
Set CreateNew_FC_ForExistingFC = pFeatureWorkspace.CreateFeatureClass(fcname, pNewFields, pUID, Nothing, esriFTSimple, "SHAPE", "")
Dim targetMetadata As IMetadata
Dim xmlPropSet As IXmlPropertySet
Set m_sourceMetadata = pInFC 'QI
Set targetMetadata = CreateNew_FC_ForExistingFC 'QI
Set xmlPropSet = m_sourceMetadata.Metadata
targetMetadata.Metadata = xmlPropSet
End Function
Public Function CreateNew_GDB_ForExistingFC(pInFC As IFeatureClass, ByVal inLocation As String, inFolderName As String) As IFeatureWorkspace
Dim fcname As String
Dim fDSname As String
Dim mypath As String
Dim bWorkspExist As Boolean
Dim pGDBWSF As IWorkspaceFactory
Dim pInFCDataset As IDataset
Dim parseFCName() As String
Set pInFCDataset = pInFC
parseFCName = Split(pInFCDataset.name, ".")
fcname = parseFCName(2)
'fDSname = Right(pInFC.FeatureDataset.name, (Len(pInFC.FeatureDataset.name) - InStrRev(pInFC.FeatureDataset.name, ".")))
fDSname = parseFCName(1)
If Not m_GP.Exists(inLocation & "\" & fDSname & "\") Then
m_GP.CreateFolder inLocation, fDSname
End If
If Not m_GP.Exists(inLocation & "\" & fDSname & "\" & fcname & "\") Then
m_GP.CreateFolder inLocation & "\" & fDSname, fcname
End If
If inFolderName = "statewide" Then
If Not m_GP.Exists(inLocation & "\" & fDSname & "\" & fcname & "\" & "statewide" & "\") Then
m_GP.CreateFolder inLocation & "\" & fDSname & "\" & fcname, "statewide"
End If
If Not m_GP.Exists(inLocation & "\" & fDSname & "\" & fcname & "\" & "statewide" & "\geodatabase\") Then
m_GP.CreateFolder inLocation & "\" & fDSname & "\" & fcname & "\" & "statewide", "geodatabase"
End If
If Not m_GP.Exists(inLocation & "\" & fDSname & "\" & fcname & "\" & "statewide" & "\shapefile\") Then
'CreateFolder inLocation & "\" & fDSname & "\" & fCname & "\" & "statewide" & "\shapefile\"
m_GP.CreateFolder inLocation & "\" & fDSname & "\" & fcname & "\" & "statewide", "shapefile"
End If
inLocation = inLocation & "\" & fDSname & "\" & fcname & "\" & "statewide" & "\geodatabase\"
'mypath = inLocation & fCname & ".mdb"
mypath = inLocation & Replace(pInFCDataset.name, ".", "_") & ".gdb"
Else
If Not m_GP.Exists(inLocation & "\" & fDSname & "\" & fcname & "\" & "county" & "\") Then
m_GP.CreateFolder inLocation & "\" & fDSname & "\" & fcname, "county"
End If
If Not m_GP.Exists(inLocation & "\" & fDSname & "\" & fcname & "\" & "county" & "\" & inFolderName & "\") Then
m_GP.CreateFolder inLocation & "\" & fDSname & "\" & fcname & "\" & "county", inFolderName
End If
If Not m_GP.Exists(inLocation & "\" & fDSname & "\" & fcname & "\" & "county" & "\" & inFolderName & "\geodatabase\") Then
m_GP.CreateFolder inLocation & "\" & fDSname & "\" & fcname & "\" & "county" & "\" & inFolderName, "geodatabase"
End If
If Not m_GP.Exists(inLocation & "\" & fDSname & "\" & fcname & "\" & "county" & "\" & inFolderName & "\shapefile\") Then
m_GP.CreateFolder inLocation & "\" & fDSname & "\" & fcname & "\" & "county" & "\" & inFolderName, "shapefile"
End If
inLocation = inLocation & "\" & fDSname & "\" & fcname & "\" & "county" & "\" & inFolderName & "\geodatabase\"
'mypath = inLocation & fCname & ".mdb"
mypath = inLocation & Replace(pInFCDataset.name, ".", "_") & ".gdb"
End If
bWorkspExist = pGDBExists(mypath)
If bWorkspExist = False Then
Call createFileGDBWorkspace(inLocation, Replace(pInFCDataset.name, ".", "_"))
'Set pGDBWSF = New AccessWorkspaceFactory
Set pGDBWSF = New FileGDBWorkspaceFactory
Set CreateNew_GDB_ForExistingFC = pGDBWSF.OpenFromFile(mypath, 0)
Else
Set CreateNew_GDB_ForExistingFC = Nothing
End If
End Function
Public Function CreateNew_FDS_ForExistingFC(pInFC As IFeatureClass, pInGDB As IFeatureWorkspace) As IFeatureDataset
Dim fDSname As String
Dim pInGeoDataset As IGeoDataset
Dim pInFCDataset As IDataset
Dim pFDS As IFeatureDataset
Set pInFCDataset = pInFC
Set pInGeoDataset = pInFCDataset
Set pFDS = pInFC.FeatureDataset
fDSname = Mid(pFDS.name, InStrRev(pFDS.name, ".") + 1)
Set CreateNew_FDS_ForExistingFC = pInGDB.CreateFeatureDataset(fDSname, pInGeoDataset.SpatialReference)
End Function
Public Sub CreateNew_Domains_ForExistingFC(pInFC As IFeatureClass, pEmptyGDB As IFeatureWorkspace)
Dim pInFields As IFields
Dim pInField As IField
Dim pWorkspaceDomains As IWorkspaceDomains
Dim pNewDomain As IDomain
Dim pClone As IClone
Dim f As Integer
Set pWorkspaceDomains = pEmptyGDB 'qi
Set pInFields = pInFC.Fields
For f = 0 To pInFields.FieldCount - 1
Set pInField = pInFields.Field(f)
'Debug.Print pInField.name
If Not pInField.Domain Is Nothing Then
'Debug.Print " d- " & pInField.Domain.name & " (" & pInField.Domain.Type & ")"
If pWorkspaceDomains.DomainByName(pInField.Domain.name) Is Nothing Then
Set pClone = pInField.Domain
Set pNewDomain = pClone.Clone
pWorkspaceDomains.AddDomain pNewDomain
End If
End If
Next f
End Sub
Public Sub CreateFileBasedOutputFromFC(pInFC As IFeatureClass, inLoc As String, pClipItem As Variant, inFolderName As String)
Dim pGDB As IFeatureWorkspace
Dim pFDS As IFeatureDataset
Dim pNewFC As IFeatureClass
Dim pNewDataset As IDataset
Dim pInDataset As IDataset
Dim parseFCName() As String
Set pGDB = CreateNew_GDB_ForExistingFC(pInFC, inLoc, inFolderName)
'Set pFDS = CreateNew_FDS_ForExistingFC(pInFC, pGDB)
CreateNew_Domains_ForExistingFC pInFC, pGDB
Set pNewFC = CreateNew_FC_ForExistingFC(pInFC, pGDB)
PopulateFeatureClass_ForExistingFeatureClass pInFC, pNewFC, pClipItem
Call SetFileBasedMetadataDates(pNewFC)
Set pNewDataset = pNewFC 'qi'
Dim newFCPathStr As String
Dim newFDSNameStr As String
Dim newFCNameStr As String
Dim newshppathstr As String
Dim featureCount As Long
featureCount = pNewFC.featureCount(Nothing)
Set pInDataset = pInFC
parseFCName = Split(pInDataset.name, ".")
newFCPathStr = pNewDataset.Workspace.pathName
newFDSNameStr = parseFCName(1)
newFCNameStr = pNewDataset.name
Set pNewFC = Nothing
Set pNewDataset = Nothing
Set pFDS = Nothing
Set pGDB = Nothing
If featureCount > 0 Then
'Zip Files
Dim retVal
'Zip GDB
'gdbFullNameStr = pTarDataset.Workspace.pathName & "\" & pTarFC.FeatureDataset.name & "\" & pTarDataset.name
newshppathstr = Replace(newFCPathStr & "\" & newFDSNameStr & "\", "\geodatabase\", "\shapefile\")
newshppathstr = Left(newshppathstr, InStrRev(newshppathstr, "shapefile") + 9)
'-m = move -a = add
'retval = Shell("C:\Program Files\WinZip\winzip32 -min -a -r " & Replace(newFCPathStr, ".gdb", ".zip") & " " & Replace(newFCPathStr, newFCNameStr & ".gdb", ""))
retVal = Shell("C:\Program Files\7zip\7za.exe a " & Replace(newFCPathStr, ".gdb", ".zip") & " " & Replace(newFCPathStr, newFCNameStr & ".gdb", ""))
Debug.Print " zipped: " & newFCPathStr
Print #1, " zipped: " & newFCPathStr
'Zip SHP
'retval = Shell("C:\Program Files\WinZip\winzip32 -min -a " & newSHPPathStr & newFCNameStr & ".zip " & _
newSHPPathStr & newFCNameStr & ".shp" & " " & _
newSHPPathStr & newFCNameStr & ".shx" & " " & _
newSHPPathStr & newFCNameStr & ".dbf" & " " & _
newSHPPathStr & newFCNameStr & ".prj" & " " & _
newSHPPathStr & newFCNameStr & ".shp.xml")
'newSHPPathStr & newFCNameStr & ".sbn" & " " &
'newSHPPathStr & newFCNameStr & ".sbx" & " " &
retVal = Shell("C:\Program Files\7zip\7za.exe a " & newshppathstr & newFCNameStr & ".zip " & _
newshppathstr & newFCNameStr & ".shp" & " " & _
newshppathstr & newFCNameStr & ".shx" & " " & _
newshppathstr & newFCNameStr & ".dbf" & " " & _
newshppathstr & newFCNameStr & ".prj" & " " & _
newshppathstr & newFCNameStr & ".shp.xml")
'newSHPPathStr & newFCNameStr & ".sbn" & " " &
'newSHPPathStr & newFCNameStr & ".sbx" & " " &
Debug.Print " zipped: " & newshppathstr & newFCNameStr & ".*"
Print #1, " zipped: " & newshppathstr & newFCNameStr & ".*"
End If
End Sub
Public Sub PopulateFeatureClass_ForExistingFeatureClass(pSrcFC As IFeatureClass, pTarFC As IFeatureClass, pClipItem As Variant)
On Error GoTo ErrorHandler
Dim pSrcFeatureCursor As IFeatureCursor
Dim pSrcFeature As IFeature
Dim pSrcMetadata As IMetadata
Dim pSrcFields As IFields
Dim pSrcField As IField
Dim pIntGeometry As IGeometry
Dim pTopOp As ITopologicalOperator
'Dim pSrcDataset As IDataset
Dim pSrcShape As IGeometry
Dim pTarDataset As IDataset
Dim gdbFullNameStr As String
Dim shpfolderstr As String
Dim pDataset As IDataset
Dim pWS As IWorkspace
Dim pathName As String
Dim pTarFeatureCursor As IFeatureCursor
Dim pTarFeatureBuffer As IFeatureBuffer
Dim count As Long
Dim totalCount As Long
Dim f As Integer
Dim tarFieldIndex As Integer
Dim pSF As ISpatialFilter
Dim pLeftOverSelSet As ISelectionSet
Set pSF = Nothing
If Not pClipItem Is Nothing Then
If TypeOf pClipItem Is IPolygon Then
Set pSF = New SpatialFilter
Set pSF.Geometry = pClipItem
Set pTopOp = New Polygon
pSF.SpatialRel = esriSpatialRelIntersects
Set pLeftOverSelSet = pSrcFC.Select(pSF, esriSelectionTypeHybrid, esriSelectionOptionNormal, Nothing)
If pLeftOverSelSet.count > 0 Then
Print #2, " - " & pLeftOverSelSet.count & " = sde select"
End If
pSF.SpatialRel = esriSpatialRelContains
End If
End If
Set pSrcFeatureCursor = pSrcFC.Search(pSF, True)
Set pSrcFeature = pSrcFeatureCursor.NextFeature
Set pSrcFields = pSrcFC.Fields
Set pTarFeatureCursor = pTarFC.Insert(True)
count = 0
totalCount = 0
Do Until pSrcFeature Is Nothing
totalCount = totalCount + 1
Debug.Print pSrcFeature.OID
Set pTarFeatureBuffer = pTarFC.CreateFeatureBuffer ' makes new feature record
Set pTarFeatureBuffer.Shape = pSrcFeature.Shape
If Not pTarFeatureBuffer.Shape.IsEmpty Then
For f = 0 To pSrcFields.FieldCount - 1
Set pSrcField = pSrcFields.Field(f)
If pSrcField.Editable And pSrcField.Type <> esriFieldTypeGeometry And UCase(Left(pSrcField.name, 8)) <> "OBJECTID" Then
tarFieldIndex = pTarFC.FindField(pSrcField.name)
If tarFieldIndex < 0 Then
tarFieldIndex = pTarFC.FindField(Left(pSrcField.name, 10))
End If
If tarFieldIndex < 0 Then
If Left(pSrcField.name, 10) = "TOTAL_CUM_" Then
tarFieldIndex = pTarFC.FindField("TCUM_" & Replace(pSrcField.name, "TOTAL_CUM_", ""))
End If
End If
If tarFieldIndex >= 0 Then
pTarFeatureBuffer.Value(tarFieldIndex) = pSrcFeature.Value(f)
End If
'Debug.Print "-- " & pSDEFCField.name
Else
'Debug.Print "IGNORED " & pSDEFCField.name
End If
Next f
Dim pArea As IArea
'Set pArea = pTarFeatureBuffer.Shape
'Debug.Print pSrcFeature.OID & " " & pArea.Area
pTarFeatureCursor.InsertFeature pTarFeatureBuffer
count = count + 1
If count >= 200 Then
pTarFeatureCursor.Flush
count = 0
Debug.Print "***Flush " & totalCount & " " & Now
End If
End If
If Not pClipItem Is Nothing Then
If TypeOf pClipItem Is IPolygon Then
pLeftOverSelSet.RemoveList 1, pSrcFeature.OID
End If
End If
Set pSrcFeature = pSrcFeatureCursor.NextFeature
Loop
If count > 0 Then
pTarFeatureCursor.Flush
count = 0
End If
If Not pLeftOverSelSet Is Nothing Then
pLeftOverSelSet.Search Nothing, True, pSrcFeatureCursor
Set pSrcFeature = pSrcFeatureCursor.NextFeature
Set pTarFeatureCursor = pTarFC.Insert(True)
Do Until pSrcFeature Is Nothing
totalCount = totalCount + 1
Debug.Print pSrcFeature.OID
Set pTarFeatureBuffer = pTarFC.CreateFeatureBuffer ' makes new feature record
If pTopOp Is Nothing Then
Set pTarFeatureBuffer.Shape = pSrcFeature.ShapeCopy
Else
Dim starttime As Date
Set pSrcShape = pSrcFeature.ShapeCopy 'qi
Set pTopOp = pSrcShape
'Debug.Print " " & pSrcFeature.OID
pTopOp.Simplify
Set pIntGeometry = pTopOp.Intersect(pClipItem, pSrcShape.Dimension)
If Not pIntGeometry Is Nothing Then
If pIntGeometry.GeometryType = pTarFC.ShapeType Then
Set pTarFeatureBuffer.Shape = pIntGeometry
End If
End If
End If
If Not pTarFeatureBuffer.Shape.IsEmpty Then
For f = 0 To pSrcFields.FieldCount - 1
Set pSrcField = pSrcFields.Field(f)
If pSrcField.Editable And pSrcField.Type <> esriFieldTypeGeometry And UCase(Left(pSrcField.name, 8)) <> "OBJECTID" Then
tarFieldIndex = pTarFC.FindField(pSrcField.name)
If tarFieldIndex < 0 Then
tarFieldIndex = pTarFC.FindField(Left(pSrcField.name, 10))
End If
If tarFieldIndex < 0 Then
If Left(pSrcField.name, 10) = "TOTAL_CUM_" Then
tarFieldIndex = pTarFC.FindField("TCUM_" & Replace(pSrcField.name, "TOTAL_CUM_", ""))
End If
End If
If tarFieldIndex >= 0 Then
pTarFeatureBuffer.Value(tarFieldIndex) = pSrcFeature.Value(f)
End If
Else
'Debug.Print "IGNORED " & pSDEFCField.name
End If
Next f
pTarFeatureCursor.InsertFeature pTarFeatureBuffer
count = count + 1
If count >= 200 Then
pTarFeatureCursor.Flush
count = 0
'Debug.Print "***Flush " & totalCount & " " & Now
End If
End If
Set pSrcFeature = pSrcFeatureCursor.NextFeature
Loop
If count > 0 Then
pTarFeatureCursor.Flush
count = 0
End If
End If
If totalCount = 0 Then
Set pDataset = pTarFC
Set pWS = pDataset.Workspace
pathName = pWS.pathName
m_deleteColl.Add pathName
Else
Dim shapeTypeStr As String
If pTarFC.ShapeType = esriGeometryPolyline Then
shapeTypeStr = "POLYLINE"
ElseIf pTarFC.ShapeType = esriGeometryPolygon Then
shapeTypeStr = "POLYGON"
ElseIf pTarFC.ShapeType = esriGeometryPoint Then
shapeTypeStr = "POINT"
ElseIf pTarFC.ShapeType = esriGeometryMultipoint Then
shapeTypeStr = "MULTIPOINT"
End If
'export to shapefile here
Set pTarDataset = pTarFC 'qi
Print #2, " - " & pTarFC.featureCount(Nothing) & " = fbp"
Print #2, " - " & pTarDataset.Workspace.pathName & " " & pSrcFC.featureCount(Nothing)
Print #2, " ----------------------------------------"
gdbFullNameStr = pTarDataset.Workspace.pathName & "\" & pTarDataset.name
shpfolderstr = Replace(pTarDataset.Workspace.pathName & "\", "\geodatabase\", "\shapefile\")
shpfolderstr = Left(shpfolderstr, InStrRev(shpfolderstr, "shapefile") + 9)
'Debug.Print shpfolderstr
m_GP.RefreshCatalog pTarDataset.Workspace.pathName
'm_GP.FeatureClassToShapefile_conversion gdbFullNameStr, shpfolderstr
m_GP.CreateFeatureClass_Management shpfolderstr, pTarDataset.name & ".shp", shapeTypeStr, gdbFullNameStr, "DISABLED", "DISABLED", """PROJCS['NAD_1983_UTM_Zone_12N',GEOGCS['GCS_North_American_1983',DATUM['D_North_American_1983',SPHEROID['GRS_1980',6378137.0,298.257222101]],PRIMEM['Greenwich',0.0],UNIT['Degree',0.0174532925199433]],PROJECTION['Transverse_Mercator'],PARAMETER['False_Easting',500000.0],PARAMETER['False_Northing',0.0],PARAMETER['Central_Meridian',-111.0],PARAMETER['Scale_Factor',0.9996],PARAMETER['Latitude_Of_Origin',0.0],UNIT['Meter',1.0]];-5120900 -9998100 100;0 1;0 1;0.1;0.1;0.1;IsHighPrecision""", "#", "0", "0", "0"
'Open shapefile where new features will be written to
'For simplicity, sample does not contain code to create a new shapefile
Dim newShpFC As IFeatureClass
Dim pInsertFeatureCursor As IFeatureCursor
Dim pInsertFeatureBuffer As IFeatureBuffer
Dim pFGDBFeatureCursor As IFeatureCursor
Dim pFGDBFeature As IFeature
Dim shpFeatureCount As Long
Dim shpMetadata As IMetadata
Dim xmlPropSet As IPropertySet
Set newShpFC = OpenShapefileFeatureClass(shpfolderstr, pTarDataset.name)
If Not newShpFC Is Nothing Then
Set pSrcMetadata = pSrcFC 'QI
Set shpMetadata = newShpFC
Set xmlPropSet = pSrcMetadata.Metadata
shpMetadata.Metadata = xmlPropSet
Set pInsertFeatureCursor = newShpFC.Insert(True)
Set pInsertFeatureBuffer = newShpFC.CreateFeatureBuffer
'Loop through all the features in InFeatureClass
Set pFGDBFeatureCursor = pTarFC.Search(Nothing, True)
Set pFGDBFeature = pFGDBFeatureCursor.NextFeature
Do While Not pFGDBFeature Is Nothing
'Add the original feature's geometry to the feature buffer
Set pInsertFeatureBuffer.Shape = pFGDBFeature.Shape
'Add all the original feature's fields to the feature buffer
PopulateShapeFileFeatureAttributes pInsertFeatureBuffer, pFGDBFeature
'Insert the feature into the cursor
pInsertFeatureCursor.InsertFeature pInsertFeatureBuffer
shpFeatureCount = shpFeatureCount + 1
If shpFeatureCount = 1000 Then
pInsertFeatureCursor.Flush
Debug.Print "flush " & pFGDBFeature.OID
shpFeatureCount = 0
End If
Set pFGDBFeature = pFGDBFeatureCursor.NextFeature
Loop
pInsertFeatureCursor.Flush 'Flush the cursor one last time
End If
End If
Set pSrcFeatureCursor = Nothing
Set pSrcFeature = Nothing
Set pSrcFields = Nothing
Set pSrcField = Nothing
Set pIntGeometry = Nothing
Set pSF = Nothing
Set pTopOp = Nothing
Set pSF = Nothing
Set pSrcShape = Nothing
'Set pTarDataset = Nothing
'Set pDataset = Nothing
Set pWS = Nothing
Set pTarFeatureCursor = Nothing
Set pTarFeatureBuffer = Nothing
Exit Sub
ErrorHandler:
'Debug.Print "ERROR: Src OID = " & pSrcFeature.OID & " #" & Err.Description
Resume Next
End Sub
Public Function calcSpatialIndex(inFC As IFeatureClass) As Long
Dim pFCursor As IFeatureCursor
Dim pfeature As IFeature
Dim dblTotal As Double
Dim iFCount As Long Dim pGeometry as IGeometry
Set pFCursor = inFC.Search(Nothing, False)
Set pfeature = pFCursor.NextFeature
dblTotal = 0
iFCount = 1
Do Until pfeature Is Nothing
Set pGeometry = pfeature.Shape If Not pGeometry is nothing Then
dblTotal = dblTotal + ((pfeature.Extent.Height + pfeature.Extent.Width) / 2)
'Set pFeature = pFCursor.NextFeature
iFCount = iFCount + 1
End If
Set pfeature = pFCursor.NextFeature
Loop
calcSpatialIndex = CLng(((dblTotal / iFCount) * 3) / 1000) * 1000
End Function
Public Sub makeDownloadTables93()
'LOAD DATA LOCAL INFILE "C:/Documents and Settings/Dennis/Desktop/menagerie/pet.txt" INTO TABLE PET;
Open "C:\temp\sgidtest\sgid93_category.txt" For Output As #1
Open "C:\temp\sgidtest\sgid93_layer.txt" For Output As #2
Open "C:\temp\sgidtest\sgid93_product.txt" For Output As #3
Open "C:\temp\sgidtest\sgid93_extent.txt" For Output As #4
Dim parseFCName() As String
Dim pCofcursor As IFeatureCursor
Dim pcofeature As IFeature
Dim countyName As String
Dim ftpPath As String
ftpPath = "J:/ftp/pub"
'ftpPath = "ftp://ftp.agrc.state.ut.us"
Call openSDEWS
Set m_CoClipFC = m_pSDEFWS.OpenFeatureClass("SGID93.Boundaries.Counties")
Dim extentArray(29) As String
extentArray(0) = "statewide"
Dim pTablesort As ITableSort
Set pTablesort = New TableSort
Set pTablesort.Table = m_CoClipFC
pTablesort.Fields = "NAME"
pTablesort.Sort Nothing
Set pCofcursor = pTablesort.Rows
Set pcofeature = pCofcursor.NextFeature
Dim extentCount As Integer
extentCount = 1
Do Until pcofeature Is Nothing
countyName = UCase(Replace(pcofeature.Value(m_CoClipFC.FindField("NAME")), " ", ""))
extentArray(extentCount) = countyName
extentCount = extentCount + 1
Set pcofeature = pCofcursor.NextFeature
Loop
Dim catID As Long
Dim layID As Long
Dim prodID As Long
Dim extID As Long
'Print #1, "CATID" & Chr(9) & "CATFDS" & Chr(9) & "CATNAME"
'Print #2, "LAYID" & Chr(9) & "CATID" & Chr(9) & "LAYNAME" & Chr(9) & "LAYSCALE"
'Print #3, "PRODID" & Chr(9) & "LAYID" & Chr(9) & "EXTID" & Chr(9) & "PRODTYPE" & Chr(9) & "PRODSIZE"
'Print #4, "EXTID" & Chr(9) & "EXTNAME"
For extID = 0 To 29
Print #4, CInt(extID) & Chr(9) & extentArray(extID)
Next extID
Dim pGxApp As IGxApplication
Dim pSelGxObject As IGxObject
Dim pGxSel As IGxSelection
Dim pEnumGxObjSel As IEnumGxObject
Dim catName, prevCatName As String
Dim scaleName As String
Dim layName As String
Set pGxApp = Application
Set pGxSel = pGxApp.Selection
Set pEnumGxObjSel = pGxSel.SelectedObjects
pEnumGxObjSel.Reset
Set pSelGxObject = pEnumGxObjSel.Next
Dim fccnt As Long
prevCatName = "*******"
catID = -1
Do Until pSelGxObject Is Nothing
If pSelGxObject.Category = "SDE Feature Class" Then
parseFCName = Split(pSelGxObject.BaseName, ".")
catName = parseFCName(1)
If prevCatName <> catName Then
catID = catID + 1
Debug.Print catName
Print #1, CStr(catID) & Chr(9) & "" & Chr(9) & catName '(FDS)
End If
Dim pGxObjContainer As IGxObjectContainer
Dim pEnumGxObj As IEnumGxObject
Dim pCurrGxObject As IGxObject
Dim fileSize As String
Debug.Print ".." & pSelGxObject.BaseName
Dim pCurrGxDataset As IGxDataset
Dim pCurrSDEFC As IFeatureClass
Dim pCurrSDEDS As IDataset
Set pCurrGxDataset = pSelGxObject
Set pCurrSDEDS = pCurrGxDataset.Dataset
Set pCurrSDEFC = pCurrSDEDS
'Print #2, CStr(layID) & Chr(9) & CStr(catID) & Chr(9) & Right(pCurrGxObject.BaseName, _
' Len(pCurrGxObject.BaseName) - InStrRev(pCurrGxObject.BaseName, ".")) & _
' Chr(9) & Mid(pCurrGxObject.BaseName, 6, 4) & _
' Chr(9) & pCurrSDEFC.ShapeType
Print #2, CStr(layID) & Chr(9) & CStr(catID) & Chr(9) & parseFCName(2) & _
Chr(9) & "" & _
Chr(9) & pCurrSDEFC.ShapeType
For extID = 0 To 29
If extID = 0 Then
'SHP
fileSize = checkFileSize(ftpPath & "/SGID93_Vector/NAD83/" & catName & "/" & Replace(parseFCName(2), ".", "_") _
& "/" & extentArray(extID) & "/shapefile/" & Replace(pSelGxObject.BaseName, ".", "_") & ".zip")
If fileSize <> "" Then
Print #3, CStr(prodID) & Chr(9) & CStr(layID) & Chr(9) & CStr(extID) & Chr(9) & "SHP" & Chr(9) & fileSize
prodID = prodID + 1
End If
'GDB
fileSize = checkFileSize(ftpPath & "/SGID93_Vector/NAD83/" & catName & "/" & Replace(parseFCName(2), ".", "_") _
& "/" & extentArray(extID) & "/geodatabase/" & Replace(pSelGxObject.BaseName, ".", "_") & ".zip")
If fileSize <> "" Then
Print #3, CStr(prodID) & Chr(9) & CStr(layID) & Chr(9) & CStr(extID) & Chr(9) & "GDB" & Chr(9) & fileSize
prodID = prodID + 1
End If
ElseIf extID > 0 And extID < 30 Then
'SHP
fileSize = checkFileSize(ftpPath & "/SGID93_Vector/NAD83/" & catName & "/" & Replace(parseFCName(2), ".", "_") _
& "/county/" & extentArray(extID) & "/shapefile/" & Replace(pSelGxObject.BaseName, ".", "_") & ".zip")
If fileSize <> "" Then
Print #3, CStr(prodID) & Chr(9) & CStr(layID) & Chr(9) & CStr(extID) & Chr(9) & "SHP" & Chr(9) & fileSize
prodID = prodID + 1
End If
'GDB
fileSize = checkFileSize(ftpPath & "/SGID93_Vector/NAD83/" & catName & "/" & Replace(parseFCName(2), ".", "_") _
& "/county/" & extentArray(extID) & "/geodatabase/" & Replace(pSelGxObject.BaseName, ".", "_") & ".zip")
If fileSize <> "" Then
Print #3, CStr(prodID) & Chr(9) & CStr(layID) & Chr(9) & CStr(extID) & Chr(9) & "GDB" & Chr(9) & fileSize
prodID = prodID + 1
End If
End If
Next extID
layID = layID + 1
prevCatName = catName
End If
Set pSelGxObject = pEnumGxObjSel.Next
Loop
Close #1
Close #2
Close #3
Close #4
End Sub
Public Function checkFileSize(inFilePath As String) As String
Dim fso
Dim f
Dim fileSize As Long
'Debug.Print checkFileSize
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.fileexists(inFilePath) Then
Set f = fso.GetFile(inFilePath)
fileSize = f.size / 1000
If (fileSize < 1) Then
checkFileSize = "~1K"
ElseIf (fileSize < 1000) Then
checkFileSize = CStr(CInt(fileSize)) + "K"
End If
If ((fileSize >= 1000) And (fileSize < 1000000)) Then
checkFileSize = CStr(CLng(fileSize / 1000)) + "MB"
End If
If (fileSize >= 1000000) Then
checkFileSize = CStr(CLng(fileSize / 1000000)) + "GB"
End If
End If
End Function
Public Function OpenShapefileFeatureClass(strWorkspace As String, strFeatureClass As String) As IFeatureClass
On Error GoTo ErrorHandler
Dim pShpWorkspaceName As IWorkspaceName
Dim pDatasetName As IDatasetName
Dim pName As IName
'Create the workspace name object
Set pShpWorkspaceName = New WorkspaceName
pShpWorkspaceName.pathName = strWorkspace
pShpWorkspaceName.WorkspaceFactoryProgID = "esriDataSourcesFile.shapefileworkspacefactory.1"
'Create the feature class name object
Set pDatasetName = New FeatureClassName
pDatasetName.name = strFeatureClass
Set pDatasetName.WorkspaceName = pShpWorkspaceName
'Open the feature class
Set pName = pDatasetName
Set OpenShapefileFeatureClass = pName.Open
Exit Function
ErrorHandler:
Set OpenShapefileFeatureClass = Nothing
End Function
Private Sub PopulateShapeFileFeatureAttributes(pFeatureBuffer As IFeatureBuffer, pfeature As IFeature)
Dim pRowBuffer As IRowBuffer
Dim pNewFields As IFields 'fields on target feature class
Dim pNewField As IField
Dim pFields As IFields 'fields on original feature class
Dim pField As IField
Dim FieldCount As Integer
Dim NewFieldIndex As Long
'Copy the attributes of the orig feature the new feature
Set pRowBuffer = pFeatureBuffer
Set pNewFields = pRowBuffer.Fields
Set pFields = pfeature.Fields
For FieldCount = 0 To pFields.FieldCount - 1
Set pField = pFields.Field(FieldCount)
If pField.Type = esriFieldTypeGUID Or pField.Type = esriFieldTypeGlobalID Then
If Not IsNull(pfeature.Value(FieldCount)) Then
pFeatureBuffer.Value(pFeatureBuffer.Fields.FindField(Left(pField.name, 10))) = pfeature.Value(FieldCount)
Else
pFeatureBuffer.Value(pFeatureBuffer.Fields.FindField(Left(pField.name, 10))) = ""
End If
ElseIf pField.name = "SHAPE_Length" Then
Dim pTempCurve As ICurve
If Not IsNull(pfeature.Value(FieldCount)) Then
Set pTempCurve = pfeature.Shape
pFeatureBuffer.Value(pFeatureBuffer.Fields.FindField("SHAPE_Leng")) = pTempCurve.Length
Else
pFeatureBuffer.Value(pFeatureBuffer.Fields.FindField("SHAPE_Leng")) = 0
End If
ElseIf pField.name = "SHAPE_Area" Then
Dim pTempArea As IArea
If Not IsNull(pfeature.Value(FieldCount)) Then
Set pTempArea = pfeature.Shape
pFeatureBuffer.Value(pFeatureBuffer.Fields.FindField("SHAPE_Area")) = pTempArea.Area
Else
pFeatureBuffer.Value(pFeatureBuffer.Fields.FindField("SHAPE_Area")) = 0
End If
ElseIf Not pField.Type = esriFieldTypeGeometry And Not pField.Type = esriFieldTypeOID _
And pField.Editable Then
'NewFieldIndex = pNewFields.Field(FieldCount)
'If Not NewFieldIndex = -1 Then
If Not IsNull(pfeature.Value(FieldCount)) Then
If pField.name = "DATE" Then
pFeatureBuffer.Value(pFeatureBuffer.Fields.FindField(Left(pField.name & "_", 10))) = CStr(pfeature.Value(FieldCount))
Else
pFeatureBuffer.Value(pFeatureBuffer.Fields.FindField(Left(pField.name, 10))) = CStr(pfeature.Value(FieldCount))
End If
Else
If pFeatureBuffer.Fields.Field(FieldCount).Type = esriFieldTypeDate Then
pFeatureBuffer.Value(pFeatureBuffer.Fields.FindField(Left(pField.name, 10))) = CDate("Jan 1, 100")
ElseIf pFeatureBuffer.Fields.Field(FieldCount).Type = esriFieldTypeDouble Or _
pFeatureBuffer.Fields.Field(FieldCount).Type = esriFieldTypeInteger Or _
pFeatureBuffer.Fields.Field(FieldCount).Type = esriFieldTypeSingle Or _
pFeatureBuffer.Fields.Field(FieldCount).Type = esriFieldTypeSmallInteger Then
pFeatureBuffer.Value(pFeatureBuffer.Fields.FindField(Left(pField.name, 10))) = 0
Else
pFeatureBuffer.Value(pFeatureBuffer.Fields.FindField(Left(pField.name, 10))) = ""
End If
End If
'Debug.Print FieldCount & pFeature.Fields.Field(FieldCount).name & " " & pFeatureBuffer.Value(pfeaturebuffer.fields.findfield(left(pfield.name),10))
'End If
End If
Next FieldCount
End Sub Public Sub SetFileBasedMetadataDates(inFC As IFeatureClass)
'declare variables
Dim pMetadata As IMetadata
Dim pMetadataPropertySet As IPropertySet
Dim pMetadataXMLPropertySet2 As IXmlPropertySet2
Dim sgidurl As String
Dim sgiddisclaimer As String
Set pMetadata = inFC 'Query Interface so we can get the name property of the featureclassname object Set pMetadata = pFCName 'Query Interface so we can get the metadata property set
'Query Interface so we can get the name property of the featureclassname object Set pMetadata = pFCName 'Query Interface so we can get the metadata property set
'get metadata property set
Set pMetadataPropertySet = pMetadata.Metadata
Set pMetadataXMLPropertySet2 = pMetadataPropertySet ' QI
'sgidURL = "http://gis.utah.gov/sgid-vector-download/utah-sgid-vector-gis-data-layer-download-index?fc=AssociationOfGovernments&scale=U024"
sgidurl = "http://gis.utah.gov/sgid-vector-download/utah-sgid-vector-gis-data-layer-download-index"
pMetadataXMLPropertySet2.SetPropertyX "idinfo/citation/citeinfo/onlink", _
sgidurl, esriXPTLink, esriXSPAAddOrReplace, False
sgiddisclaimer = "The Utah Automated Geographic Reference Center has adopted the following spatial data disclaimer to be explicitedly included or referenced in all geospatial data, mapping products, and services created or hosted at AGRC including the contents of State Geographic Information Database (SGID)." & vbNewLine & vbNewLine & _
"'This product is for informational purposes and may not have been prepared for, or be suitable for legal, engineering, or surveying purposes. Users of this information should review or consult the primary data and information sources to ascertain the usability of the information. AGRC provides these data in good faith and shall in no event be liable for any incorrect results, any lost profits and special, indirect or consequential damages to any party, arising out of or in connection with the use or the inability to use the data hereon or the services provided. AGRC shall not be held liable for any third party's interpretation of data provided by AGRC. AGRC provides these data and services as a convenience to the public. Furthermore, AGRC reserves the right to change or revise published data and/or these services at any time.'" & vbNewLine & vbNewLine & _
"Furthermore, it is the official policy of the AGRC:" & vbNewLine & vbNewLine & _
" - that the adopted disclaimer be used on all hard copy maps produced from geospatial data, and that the date and source of the data be included on the map;" & vbNewLine & vbNewLine & _
" - that spatial data producers be allowed to extend the adopted disclaimer with additional language further defining the limits of their liability;" & vbNewLine & vbNewLine & _
" - that a more robust disclaimer may be used in conjunction with any and all geospatial data published on the Internet, on a separate page preceding access to the data, with an accept/reject option for users;" & vbNewLine & vbNewLine & _
" - that standardized metadata be included with any distribution of all geospatial data; and" & vbNewLine & vbNewLine & _
" - that the disclaimer above may be used as a blanket disclaimer for documents containing a number of small maps." & vbNewLine
pMetadataXMLPropertySet2.SetPropertyX "idinfo/useconst", _
sgiddisclaimer, esriXPTText, esriXSPAAddOrReplace, False
pMetadataXMLPropertySet2.SetPropertyX "distinfo/distrib/cntinfo/cntaddr/addrtype", "physical", esriXPTText, esriXSPAAddOrReplace, False
pMetadataXMLPropertySet2.SetPropertyX "distinfo/distrib/cntinfo/cntaddr/address", "1 State Office Building, Room 5130", esriXPTText, esriXSPAAddOrReplace, False
pMetadataXMLPropertySet2.SetPropertyX "distinfo/distrib/cntinfo/cntaddr/city", "Salt Lake City", esriXPTText, esriXSPAAddOrReplace, False
pMetadataXMLPropertySet2.SetPropertyX "distinfo/distrib/cntinfo/cntaddr/state", "UT", esriXPTText, esriXSPAAddOrReplace, False
pMetadataXMLPropertySet2.SetPropertyX "distinfo/distrib/cntinfo/cntaddr/postal", "84114", esriXPTText, esriXSPAAddOrReplace, False
pMetadataXMLPropertySet2.SetPropertyX "distinfo/distrib/cntinfo/cntaddr/country", "USA", esriXPTText, esriXSPAAddOrReplace, False
pMetadataXMLPropertySet2.SetPropertyX "distinfo/distrib/cntinfo/cntvoice", "801.538.3665", esriXPTText, esriXSPAAddOrReplace, False
pMetadataXMLPropertySet2.SetPropertyX "distinfo/distrib/cntinfo/cntfax", "801.538.3317", esriXPTText, esriXSPAAddOrReplace, False
pMetadataXMLPropertySet2.SetPropertyX "distinfo/distrib/cntinfo/cntemail", "
This e-mail address is being protected from spam bots, you need JavaScript enabled to view it
e-mail address is being protected from spam bots, you need JavaScript enabled to view it ", esriXPTText, esriXSPAAddOrReplace, False
pMetadataXMLPropertySet2.SetPropertyX "distinfo/distrib/cntinfo/cntorgp/cntorg", "Utah Automated Geographic Reference Center (AGRC)", esriXPTText, esriXSPAAddOrReplace, False
pMetadataXMLPropertySet2.SetPropertyX "distinfo/distrib/cntinfo/cntorgp/cntper", "", esriXPTText, esriXSPAAddOrReplace, False
pMetadataXMLPropertySet2.SetPropertyX "distinfo/distrib/cntinfo/hours", "Mon - Thurs 7am - 6pm, Closed Fridays", esriXPTText, esriXSPAAddOrReplace, False
Dim currDateStr As String
currDateStr = Format(Now, "yyyyMMdd")
pMetadataXMLPropertySet2.SetPropertyX "idinfo/citation/citeinfo/pubdate", _
currDateStr, esriXPTText, esriXSPAAddOrReplace, False
pMetadataXMLPropertySet2.SetPropertyX "idinfo/timeperd/timeinfo/sngdate/caldate", _
currDateStr, esriXPTText, esriXSPAAddOrReplace, False
pMetadataXMLPropertySet2.SetPropertyX "idinfo/status/update", _
"Periodically", esriXPTText, esriXSPAAddOrReplace, False
pMetadataXMLPropertySet2.SetPropertyX "metainfo/metd", _
currDateStr, esriXPTText, esriXSPAAddOrReplace, False
pMetadataXMLPropertySet2.DeleteProperty "metainfo/metd/metc/cntinfo/hours"
pMetadataXMLPropertySet2.DeleteProperty "idinfo/ptcontac/cntinfo/hours"
'example for using a custom thumbnail, picture must prexist on drive space...maybe export it from ArcMap?
'pMetadataPropertySet.SetPropertyX "Binary/Thumbnail/Data", _
LoadPicture("C:/muni.gif"), esriXPTPicture, esriXSPAAddOrReplace, False
pMetadata.Metadata = pMetadataPropertySet
End Sub |
