H
hubo8888
Unregistered / Unconfirmed
GUEST, unregistred user!
请教高手ARC OBJECT中如何将图层导出成CAD,DWG望答复
H
hubo8888
Unregistered / Unconfirmed
GUEST, unregistred user!
请教高手ARC OBJECT中如何将图层导出成CAD,DWG望答复
吕
吕雪松
Unregistered / Unconfirmed
GUEST, unregistred user!
调用ArcCatalog的接口。GxLayerExport,GxFile
H
hubo8888
Unregistered / Unconfirmed
GUEST, unregistred user!
接受答案了.
H
hubo8888
Unregistered / Unconfirmed
GUEST, unregistred user!
谢谢回复,能不能给一个调用的例子，未能发现GxLayerExport接口
吕
吕雪松
Unregistered / Unconfirmed
GUEST, unregistred user!
给你一个VB版的代码，希望对你有帮助
GxInterchangeObject
GxInterchangeObject.cls
Option Explicit
Implements esriCatalog.IGxObject
Implements esriCatalog.IGxObjectUI
Implements esriCatalog.IGxObjectEdit
Implements esriCatalog.IGxObjectProperties
Implements esriGeodatabase.IMetadata
Implements esriGeodatabase.IMetadataEdit
' Type required for GetVersionX API call.
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
' Win32 API calls to get OS information.
Private Declare Function GetVersionExA Lib "kernel32"
(lpVersionInformation As OSVERSIONINFO) As Integer
Private Declare Function GetComputerName Lib "kernel32"
Alias "GetComputerNameA"
(ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function GetLocaleInfo Lib "kernel32"
Alias "GetLocaleInfoA"
(ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String, ByVal cchData As Long) As Long
' To get the system lang information
Private Const LOCALE_SISO639LANGNAME As Long = &H59
Private Const LOCALE_USER_DEFAULT = &H400
' To determine running process.
Private Declare Function GetModuleHandle Lib "kernel32"
Alias "GetModuleHandleA"
(ByVal lpModuleName As String) As Long
Private m_pParent As esriCatalog.IGxObject
Private m_pCatalog As esriCatalog.IGxCatalog
Private m_pCtxMenu As esriFramework.ICommandBar
Private m_pFileSystemObject As Object
Private m_pBitmapSmall As IPictureDisp
Private m_pBitmapLarge As IPictureDisp
Private m_sFullName As String
Private m_sName As String
Private m_sBaseName As String
Private m_bExists As Boolean
Private m_bReadOnly As Boolean
' Error Codes
Private Const S_FALSE = &H1
Private Const E_FAIL = &H80004005
Private Const E_INVALIDARG = &H80070057
Private Sub Class_Initialize()
' Set up the file system object and the icons.
Set m_pFileSystemObject = CreateObject("Scripting.FileSystemObject"
Set m_pBitmapLarge = LoadResPicture(101, 0)
Set m_pBitmapSmall = LoadResPicture(102, 0)
End Sub
Private Property Get IGxObject_Name() As String
IGxObject_Name = m_sName
End Property
Friend Property Let Name(sName As String)
'do
file name proceessing here since this code executes before attach
' Not required butdo
ne for optimization
If sName <> ""
then
If Not (m_pFileSystemObject Is Nothing) then
If (UCase(m_pFileSystemObject.GetExtensionName(sName)) = "E00" then
m_sFullName = sName ' Full name of object
m_sName = m_pFileSystemObject.GetFileName(sName) ' No path with ext
m_sBaseName = m_pFileSystemObject.GetBaseName(sName) ' No path no ext
End If
End If
End If
End Property
Private Property Get IGxObject_FullName() As String
' Full file path with extension.
IGxObject_FullName = m_sFullName
End Property
Private Property Get IGxObject_BaseName() As String
' No file path or extension.
IGxObject_BaseName = m_sBaseName
End Property
Private Property Get IGxObject_Category() As String
' Used Catalog's Contents View.
IGxObject_Category = "Interchange (.e00) File"
End Property
Private Property Get IGxObject_Parent() As esriCatalog.IGxObject
' Parent GxObject.
Set IGxObject_Parent = m_pParent
End Property
Private Property Get IGxObject_ClassID() As esriSystem.IUID
' ClassID of this GxObject.
Dim pUID As New esriSystem.UID
pUID.value = "GxInterchangeVB.GxInterchangeObject"
If Not pUID Is Nothing then
Set IGxObject_ClassID = pUID
End If
End Property
Private Property Get IGxObject_InternalObjectName() As esriSystem.IName
' Note: using IFileName insterad of IName::Namestring
Dim pName As esriSystem.IFileName
Set pName = New esriSystem.FileName
pName.Path = m_sFullName
Set IGxObject_InternalObjectName = pName
End Property
Private Property Get IGxObject_IsValid() As Boolean
If Not (m_pParent Is Nothing) then
If Not (m_pCatalog Is Nothing) then
IGxObject_IsValid = True
End If
End If
End Property
Private Sub IGxObject_Attach(ByVal Parent As esriCatalog.IGxObject, ByVal pCatalog As esriCatalog.IGxCatalog)
' Attaches this GxObject to it's Parent.
Set m_pParent = Parent
Set m_pCatalog = pCatalog
End Sub
Private Sub IGxObject_Detach()
' Detaches the object and cleans up refernces
Set m_pParent = Nothing
Set m_pCatalog = Nothing
End Sub
Private Sub IGxObject_Refresh()
'Not required here since is is no view to refresh with this class.
End Sub
Private Property Get IGxObjectUI_SmallImage() As esriSystem.OLE_HANDLE
' Not used since this sample uses the default icon
IGxObjectUI_SmallImage = m_pBitmapSmall
End Property
Private Property Get IGxObjectUI_SmallSelectedImage() As esriSystem.OLE_HANDLE
' Not used since this sample uses the default icon
IGxObjectUI_SmallSelectedImage = m_pBitmapSmall
End Property
Private Property Get IGxObjectUI_LargeImage() As esriSystem.OLE_HANDLE
' Not used since this sample uses the default icon
IGxObjectUI_LargeImage = m_pBitmapLarge
End Property
Private Property Get IGxObjectUI_LargeSelectedImage() As esriSystem.OLE_HANDLE
' Not used since this sample uses the default icon
IGxObjectUI_LargeSelectedImage = m_pBitmapLarge
End Property
Private Property Get IGxObjectUI_ContextMenu() As esriSystem.IUID
If m_pCtxMenu Is Nothing then
' Check the application we are running in.
Dim lErr As Long, lHandle As Long, sName As String
Dim pApp As esriFramework.IApplication
sName = "ArcCatalog.EXE"
lHandle = GetModuleHandle(sName)
If lHandle <> 0 then
' We're in ArcCatalog and can therefore get the Application.
Set pApp = New esriFramework.AppRef
else
Exit Property
End If
' Find the command bars collection.
Dim pCmdBars As esriFramework.ICommandBars
Set pCmdBars = pApp.Document.CommandBars
' Create a new context menu for this GxObject.
Set m_pCtxMenu = pCmdBars.Create("InterchangeMenu", esriSystemUI.esriCmdBarType.esriCmdBarTypeShortcutMenu)
' Add required Menu items to the context menu.
Dim pUID As esriSystem.IUID
Set pUID = New esriSystem.UID
pUID.value = "{C637B93D-0FA5-11D3-9F4F-00C04F6BC69E}"
' CopyMenuItem
Dim pCmdItem As esriFramework.ICommandItem
Set pCmdItem = m_pCtxMenu.Add(pUID)
pUID.value = "{25C0E6C1-CD06-11D2-9F40-00C04F6BC626}"
' DeleteMenuItem
Set pCmdItem = m_pCtxMenu.Add(pUID)
pUID.value = "{25C0E6C3-CD06-11D2-9F40-00C04F6BC626}"
' RenameMenuItem
Set pCmdItem = m_pCtxMenu.Add(pUID)
' Add the custom command to use the Import geoprocessing tool.
pUID.value = "{1CD666C0-BFB1-4010-A17C-86D424B3C9ED}"
Set pCmdItem = m_pCtxMenu.Add(pUID)
pCmdItem.Group = True
pUID.value = "{20724105-BAB8-11D1-9ABA-080009EC734B}"
' PropertiesMenuItem
Set pCmdItem = m_pCtxMenu.Add(pUID)
pCmdItem.Group = True
End If
' Now display the new context menu
If Not m_pCtxMenu Is Nothing then
m_pCtxMenu.Popup
' Report the chosen item
Dim pSelected_CmdItem As esriFramework.ICommandItem
Set pSelected_CmdItem = m_pCtxMenu
Set IGxObjectUI_ContextMenu = pSelected_CmdItem.ID
End If
End Property
Private Property Get IGxObjectUI_NewMenu() As esriSystem.IUID
' GxIntechangeObjectdo
es not have a NewMenu.
End Property
' IGxObjectEdit members.
Private Function IGxObjectEdit_CanRename() As Boolean
CheckAttributes
IGxObjectEdit_CanRename = m_bExists And Not (m_bReadOnly) 'True
End Function
Private Sub IGxObjectEdit_Rename(ByVal newShortName As String)
CheckAttributes
If m_bExists And Not m_bReadOnly then
If Not m_pFileSystemObject Is Nothing then
' Check for the correct extension, or add it to the new filename
Dim sTemp As String
If InStr(1, UCase(newShortName), "E00" = (Len(newShortName) - 2) then
sTemp = m_pParent.FullName &
"/"
&
newShortName
else
sTemp = m_pParent.FullName &
"/"
&
newShortName &
".e00"
End If
' Method requires filename that has no path with ext
If Not (m_pFileSystemObject.FileExists(sTemp)) then
m_pFileSystemObject.CopyFile m_sFullName, sTemp
m_pFileSystemObject.DeleteFile (m_sFullName)
'do
n't forget to rename the metadata if it is present.
If m_pFileSystemObject.FileExists(m_sFullName &
".xml" then
m_pFileSystemObject.CopyFile m_sFullName &
".xml", sTemp &
".xml"
m_pFileSystemObject.DeleteFile m_sFullName &
".xml"
End If
' Rename the current object
Me.Name = sTemp
End If
End If
End If
End Sub
Private Function IGxObjectEdit_CanDelete() As Boolean
CheckAttributes
IGxObjectEdit_CanDelete = m_bExists And Not (m_bReadOnly) 'True
End Function
Private Sub IGxObjectEdit_Delete()
' This method uses the FileSystemObject to delete the file
CheckAttributes
If m_bExists And Not m_bReadOnly then
If Not m_pFileSystemObject Is Nothing then
m_pFileSystemObject.DeleteFile (m_sFullName)
'do
n't forget to delete the metadata if it is present.
If m_pFileSystemObject.FileExists(m_sFullName &
".xml" then
m_pFileSystemObject.DeleteFile m_sFullName &
".xml"
End If
Dim pContainer As esriCatalog.IGxObjectContainer
Set pContainer = m_pParent
pContainer.DeleteChild Me
End If
End If
End Sub
Private Sub IGxObjectEdit_EditProperties(ByVal hParent As esriSystem.OLE_HANDLE)
' This display the generic file properties window
Dim pGxFile As esriCatalog.IGxFile
Set pGxFile = New esriCatalog.GxFile
pGxFile.Path = m_sFullName
Dim pGxObjEdit As esriCatalog.IGxObjectEdit
Set pGxObjEdit = pGxFile
pGxObjEdit.EditProperties hParent
End Sub
Private Function IGxObjectEdit_CanCopy() As Boolean
CheckAttributes
IGxObjectEdit_CanCopy = m_bExists
End Function
Private Sub CheckAttributes()
If Not m_pFileSystemObject Is Nothing then
m_bExists = m_pFileSystemObject.FileExists(m_sFullName)
If m_bExists then
Dim file As Object
Set file = m_pFileSystemObject.GetFile(m_sFullName)
If file.Attributes And 1 then
m_bReadOnly = True
else
m_bReadOnly = False
End If
End If
End If
End Sub
' IGxObjectProperties members
Private Sub IGxObjectProperties_GetPropByIndex(ByVal index As Long, pName As String, pValue As Variant)
If (index > 5) Or (index < 0) then
Err.Raise E_INVALIDARG
else
Select Case index
Case 0
pName = "ESRI_GxObject_Name"
Case 1
pName = "ESRI_GxObject_Type"
Case 2
pName = "ESRI_GxObject_FileSize"
Case 3
pName = "ESRI_GxObject_FileTime"
Case 4
pName = "ESRI_GxObject_FileMode"
Case else
Err.Raise E_INVALIDARG
Exit Sub
End Select
pValue = IGxObjectProperties_GetProperty(pName)
End If
End Sub
Private Function IGxObjectProperties_GetProperty(ByVal Name As String) As Variant
' Identify the property and return the correct value.
Select Case Name
Case "ESRI_GxObject_Name"
IGxObjectProperties_GetProperty = IGxObject_Name
Case "ESRI_GxObject_Type"
IGxObjectProperties_GetProperty = IGxObject_Category
Case else
Dim file As Object
Set file = m_pFileSystemObject.GetFile(m_sFullName)
Select Case Name
Case "ESRI_GxObject_FileSize"
' FGDC Standard expectS file size written in MB.
IGxObjectProperties_GetProperty = Format(file.Size / 1048576, "0.000"
Case "ESRI_GxObject_FileTime"
' Format of filetime is standard.
IGxObjectProperties_GetProperty = file.DateLastModified 'Format(file.DateLastModified, "Long Date"
Case "ESRI_GxObject_FileMode"
IGxObjectProperties_GetProperty = "R/W"
If file.Attributes And 1 then
IGxObjectProperties_GetProperty = "R"
Case else
Err.Raise E_INVALIDARG
Exit Function
End Select
End Select
End Function
Private Property Get IGxObjectProperties_PropertyCount() As Long
' A GxInterchangeObject has 5 supported properties.
IGxObjectProperties_PropertyCount = 5
End Property
Private Sub IGxObjectProperties_SetProperty(ByVal Name As String, ByVal value As Variant)
' A GxInterchageObject has no properties which can be set by clients
Err.Raise E_FAIL
End Sub
' IMetadata properties.
Private Property Let IMetadata_Metadata(ByVal RHS As esriSystem.IPropertySet)
' To allow the Metadata to be set, you can make use of the GxMetadata class,
' which represents an XML file.
' First check if the file already exists.
Dim sFilename As String
sFilename = m_sFullName &
".xml"
If Not ExistsMetadata(sFilename) then
' If the metadata filedo
es not already exist, create it now.
Dim newFile As Object
Set newFile = m_pFileSystemObject.CreateTextFile(sFilename, True)
newFile.Close
End If
' First create a GxMetadata object, representing the XML file of metadata.
Dim pGxFile As esriCatalog.IGxFile
Set pGxFile = New esriCatalog.GxMetadata
pGxFile.Path = sFilename
' Save the metadata
Dim pMetadata As esriGeodatabase.IMetadata
Set pMetadata = pGxFile
pMetadata.Metadata = RHS
End Property
Private Property Get IMetadata_Metadata() As esriSystem.IPropertySet
' Return the property set of the Metadata.
Dim pProp As esriSystem.IPropertySet
' Check if the metadata already exists,
If ExistsMetadata(m_sFullName &
".xml" then
' Get the metadata via the GxObject.
' First, create a new metadatafactory.
Dim pGxObjectFactory As esriCatalog.IGxObjectFactoryMetadata
Set pGxObjectFactory = New esriCatalog.GxMetadataFactory
Dim pGxObject As esriCatalog.IGxObject
Set pGxObject = pGxObjectFactory.GetGxObjectFromMetadata(m_sFullName &
".xml"
Dim pMetadata As esriGeodatabase.IMetadata
Set pMetadata = pGxObject
Set pProp = pMetadata.Metadata
else
' If the metadatado
es not exist already, create a new property set.
Set pProp = New esriGeodatabase.XmlPropertySet
End If
Set IMetadata_Metadata = pProp
End Property
Private Sub IMetadata_Synchronize(ByVal Action As esriGeodatabase.esriMetadataSyncAction, ByVal Interval As Long)
' Need to get the current metadata and QI to IXMLPropertySet.
Dim pXMLPropertySet As esriGeodatabase.IXmlPropertySet2
Set pXMLPropertySet = IMetadata_Metadata
' Create a new FGDCSynchronizationHelper, and get ISynchronizationHelper.
Dim pSynchronizationHelper As esriGeodatabase.ISynchronizationHelper
Set pSynchronizationHelper = New esriGeodatabase.FGDCSynchronizationHelper
' Decide whether or not to Synchronize.
Dim bSynchronize As Boolean
bSynchronize = False
pSynchronizationHelper.StartSynchronization pXMLPropertySet, Action, Interval, bSynchronize
' If synchronization was successful.
If Not bSynchronize then
Err.Raise S_FALSE
else
' Get the Name and NativeForm (Type) of the dataset
Dim sDataSetName As String, sNativeForm As String
sDataSetName = IGxObject_Name
sNativeForm = IGxObject_Category
' Build a string representing the UNC path for DataSetLocation
Dim lFullName As Long, lSlash As Long
lFullName = Len(m_sFullName)
lSlash = InStr(m_sFullName, "/"
Dim sDataSetLocation As String
sDataSetLocation = "//"
&
ComputerName() &
Mid(m_sFullName, lSlash, lFullName)
' Get the Environment. Generally the Boilerplate information added to most
' GxObjects will include both OS and ArcGIS software version for Environment.
' For the GxInterchangeFile we just get the OS.
Dim sEnvironment As String
sEnvironment = GetVersion()
' Get the system language, returned as ISO 2 characters
Dim sLangBuffer As String * 100
GetLocaleInfo LOCALE_USER_DEFAULT, LOCALE_SISO639LANGNAME, sLangBuffer, 99
' Get the Object size
Dim sSize As String
sSize = IGxObjectProperties_GetProperty("ESRI_GxObject_FileSize"
' Also create a new MetadataSynchronizer. This is a singleton - as well
' as being a synchronizer for basic information, it also acts as the
' synchronization manager.
Dim pMetadataSynchronizer As esriGeodatabase.IMetadataSynchronizer
Set pMetadataSynchronizer = New esriGeodatabase.MetadataSynchronizer
' Call the Update method for each bit of metadata.
' Put the name in the "DatasetName"
metadata element using pXMLPropertySet
pMetadataSynchronizer.Update pXMLPropertySet, "DatasetName", sDataSetName
' Put the Type in the "NativeType"
metadata element using pXMLPropertySet
pMetadataSynchronizer.Update pXMLPropertySet, "NativeForm", sNativeForm
' Put the Location in the correct metadata element using pXMLPropertySet
pMetadataSynchronizer.Update pXMLPropertySet, "DatasetLocation", sDataSetLocation
' Put the operating system information in the "Environment"
metadata element using pXMLPropertySet.
' This would generally include the ArcGIS version too.
pMetadataSynchronizer.Update pXMLPropertySet, "Environment", sEnvironment
'put the Language in the correct metadata element using pXMLPropertySet
pMetadataSynchronizer.Update pXMLPropertySet, "Language", sLangBuffer
' Put the Object Size in the "DatasetSize"
metadata element using pXMLPropertySet
pMetadataSynchronizer.Update pXMLPropertySet, "DatasetSize", sSize
' If IXmlPropertySet::IsNew is True, set the SyncOnce element to False at
' the end of your Synchronize method to indicate the metadata has been
' synchronized.
If pXMLPropertySet.IsNew then
pXMLPropertySet.SetPropertyX "Esri/SyncOnce", "FALSE", esriXPTText, _
esriXSPAAddOrReplace, False
End If
pSynchronizationHelper.FinishSynchronization pXMLPropertySet
'Write out the metadata using the Let Method from IMetadata.Metadata
IMetadata_Metadata = pXMLPropertySet
End If
End Sub
Private Property Get IMetadataEdit_CanEditMetadata() As Boolean
IMetadataEdit_CanEditMetadata = False
' Return true if the file is editable.
If ExistsMetadata(m_sFullName) then
Dim file As Object
Set file = m_pFileSystemObject.GetFile(m_sFullName)
If Not file.Attributes = 1 then
IMetadataEdit_CanEditMetadata = True
End If
End If
End Property
Private Function CanEditMetadata(m_sFullName As String)
If ExistsMetadata(m_sFullName) then
Dim file As Object
Set file = m_pFileSystemObject.GetFile(m_sFullName)
If Not file.Attributes = 1 then
CanEditMetadata = True
else
CanEditMetadata = False
End If
End If
End Function
Private Function ExistsMetadata(m_sName_XML As String)
Set m_pFileSystemObject = CreateObject("Scripting.FileSystemObject"
ExistsMetadata = m_pFileSystemObject.FileExists(m_sName_XML)
End Function
Public Function ComputerName() As String
' Returns the name of the local computer.
Dim buffer As String * 512, Length As Long
Length = Len(buffer)
If GetComputerName(buffer, Length) then
' this API returns non-zero if successful,
' and modifies the length argument
ComputerName = Left(buffer, Length)
End If
End Function
Public Function GetVersion() As String
' Returns the version of the OS
Dim osinfo As OSVERSIONINFO
osinfo.dwOSVersionInfoSize = 148
osinfo.szCSDVersion = Space$(128)
Dim retvalue As Integer
retvalue = GetVersionExA(osinfo)
'Get the Build Number
Dim BuildNum As Integer
Dim strBuildNum As String
BuildNum = osinfo.dwBuildNumber
If Not BuildNum then
strBuildNum = "(Build "
&
CStr(BuildNum) &
""
else
strBuildNum = ""
End If
'Get the Version
Dim intMajor As Integer, intMinor As Integer
intMajor = osinfo.dwMajorVersion
intMinor = osinfo.dwMinorVersion
Dim strMajor As String, strMinor As String
If Not intMajor then
strMajor = "Version "
&
CStr(intMajor) &
"."
If Not intMinor then
strMinor = CStr(intMinor)
Dim strVersion As String
strVersion = strMajor &
strMinor
Dim strServicePack As String
strServicePack = Trim(osinfo.szCSDVersion)
With osinfo
Select Case .dwPlatformId
' This is for Win32_windows
Case 1
Select Case .dwMinorVersion
Case 0
GetVersion = "Windows 95 "
&
strVersion &
"
"
&
strBuildNum &
"
"
&
strServicePack &
";"
&
vbNewLine
Case 10
GetVersion = "Windows 98 "
&
strVersion &
"
"
&
strBuildNum &
"
"
&
strServicePack &
";"
&
vbNewLine
Case 90
GetVersion = "Windows Millennium "
&
strVersion &
"
"
&
strBuildNum &
"
"
&
strServicePack &
";"
&
vbNewLine
End Select
'THis is for NT
Case 2
Select Case .dwMajorVersion
Case 3
GetVersion = "Windows NT 3.51 "
&
strVersion &
"
"
&
strBuildNum &
"
"
&
strServicePack &
";"
&
vbNewLine
Case 4
GetVersion = "Windows NT 4.0 "
&
strVersion &
"
"
&
strBuildNum &
"
"
&
strServicePack &
";"
&
vbNewLine
Case 5
If .dwMinorVersion = 0 then
GetVersion = "Windows 2000 "
&
strVersion &
"
"
&
strBuildNum &
"
"
&
strServicePack &
";"
&
vbNewLine
else
GetVersion = "Windows XP "
&
strVersion &
"
"
&
strBuildNum &
"
"
&
strServicePack &
";"
&
vbNewLine
End If
End Select
Case else
GetVersion = "Failed"
End Select
End With
End Function
GxInterchangeObject
GxInterchangeObject.cls
Option Explicit
Implements esriCatalog.IGxObject
Implements esriCatalog.IGxObjectUI
Implements esriCatalog.IGxObjectEdit
Implements esriCatalog.IGxObjectProperties
Implements esriGeodatabase.IMetadata
Implements esriGeodatabase.IMetadataEdit
' Type required for GetVersionX API call.
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
' Win32 API calls to get OS information.
Private Declare Function GetVersionExA Lib "kernel32"
(lpVersionInformation As OSVERSIONINFO) As Integer
Private Declare Function GetComputerName Lib "kernel32"
Alias "GetComputerNameA"
(ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function GetLocaleInfo Lib "kernel32"
Alias "GetLocaleInfoA"
(ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String, ByVal cchData As Long) As Long
' To get the system lang information
Private Const LOCALE_SISO639LANGNAME As Long = &H59
Private Const LOCALE_USER_DEFAULT = &H400
' To determine running process.
Private Declare Function GetModuleHandle Lib "kernel32"
Alias "GetModuleHandleA"
(ByVal lpModuleName As String) As Long
Private m_pParent As esriCatalog.IGxObject
Private m_pCatalog As esriCatalog.IGxCatalog
Private m_pCtxMenu As esriFramework.ICommandBar
Private m_pFileSystemObject As Object
Private m_pBitmapSmall As IPictureDisp
Private m_pBitmapLarge As IPictureDisp
Private m_sFullName As String
Private m_sName As String
Private m_sBaseName As String
Private m_bExists As Boolean
Private m_bReadOnly As Boolean
' Error Codes
Private Const S_FALSE = &H1
Private Const E_FAIL = &H80004005
Private Const E_INVALIDARG = &H80070057
Private Sub Class_Initialize()
' Set up the file system object and the icons.
Set m_pFileSystemObject = CreateObject("Scripting.FileSystemObject"
Set m_pBitmapLarge = LoadResPicture(101, 0)
Set m_pBitmapSmall = LoadResPicture(102, 0)
End Sub
Private Property Get IGxObject_Name() As String
IGxObject_Name = m_sName
End Property
Friend Property Let Name(sName As String)
'do
file name proceessing here since this code executes before attach
' Not required butdo
ne for optimization
If sName <> ""
then
If Not (m_pFileSystemObject Is Nothing) then
If (UCase(m_pFileSystemObject.GetExtensionName(sName)) = "E00"
thenm_sFullName = sName ' Full name of object
m_sName = m_pFileSystemObject.GetFileName(sName) ' No path with ext
m_sBaseName = m_pFileSystemObject.GetBaseName(sName) ' No path no ext
End If
End If
End If
End Property
Private Property Get IGxObject_FullName() As String
' Full file path with extension.
IGxObject_FullName = m_sFullName
End Property
Private Property Get IGxObject_BaseName() As String
' No file path or extension.
IGxObject_BaseName = m_sBaseName
End Property
Private Property Get IGxObject_Category() As String
' Used Catalog's Contents View.
IGxObject_Category = "Interchange (.e00) File"
End Property
Private Property Get IGxObject_Parent() As esriCatalog.IGxObject
' Parent GxObject.
Set IGxObject_Parent = m_pParent
End Property
Private Property Get IGxObject_ClassID() As esriSystem.IUID
' ClassID of this GxObject.
Dim pUID As New esriSystem.UID
pUID.value = "GxInterchangeVB.GxInterchangeObject"
If Not pUID Is Nothing then
Set IGxObject_ClassID = pUID
End If
End Property
Private Property Get IGxObject_InternalObjectName() As esriSystem.IName
' Note: using IFileName insterad of IName::Namestring
Dim pName As esriSystem.IFileName
Set pName = New esriSystem.FileName
pName.Path = m_sFullName
Set IGxObject_InternalObjectName = pName
End Property
Private Property Get IGxObject_IsValid() As Boolean
If Not (m_pParent Is Nothing) then
If Not (m_pCatalog Is Nothing) then
IGxObject_IsValid = True
End If
End If
End Property
Private Sub IGxObject_Attach(ByVal Parent As esriCatalog.IGxObject, ByVal pCatalog As esriCatalog.IGxCatalog)
' Attaches this GxObject to it's Parent.
Set m_pParent = Parent
Set m_pCatalog = pCatalog
End Sub
Private Sub IGxObject_Detach()
' Detaches the object and cleans up refernces
Set m_pParent = Nothing
Set m_pCatalog = Nothing
End Sub
Private Sub IGxObject_Refresh()
'Not required here since is is no view to refresh with this class.
End Sub
Private Property Get IGxObjectUI_SmallImage() As esriSystem.OLE_HANDLE
' Not used since this sample uses the default icon
IGxObjectUI_SmallImage = m_pBitmapSmall
End Property
Private Property Get IGxObjectUI_SmallSelectedImage() As esriSystem.OLE_HANDLE
' Not used since this sample uses the default icon
IGxObjectUI_SmallSelectedImage = m_pBitmapSmall
End Property
Private Property Get IGxObjectUI_LargeImage() As esriSystem.OLE_HANDLE
' Not used since this sample uses the default icon
IGxObjectUI_LargeImage = m_pBitmapLarge
End Property
Private Property Get IGxObjectUI_LargeSelectedImage() As esriSystem.OLE_HANDLE
' Not used since this sample uses the default icon
IGxObjectUI_LargeSelectedImage = m_pBitmapLarge
End Property
Private Property Get IGxObjectUI_ContextMenu() As esriSystem.IUID
If m_pCtxMenu Is Nothing then
' Check the application we are running in.
Dim lErr As Long, lHandle As Long, sName As String
Dim pApp As esriFramework.IApplication
sName = "ArcCatalog.EXE"
lHandle = GetModuleHandle(sName)
If lHandle <> 0 then
' We're in ArcCatalog and can therefore get the Application.
Set pApp = New esriFramework.AppRef
else
Exit Property
End If
' Find the command bars collection.
Dim pCmdBars As esriFramework.ICommandBars
Set pCmdBars = pApp.Document.CommandBars
' Create a new context menu for this GxObject.
Set m_pCtxMenu = pCmdBars.Create("InterchangeMenu", esriSystemUI.esriCmdBarType.esriCmdBarTypeShortcutMenu)
' Add required Menu items to the context menu.
Dim pUID As esriSystem.IUID
Set pUID = New esriSystem.UID
pUID.value = "{C637B93D-0FA5-11D3-9F4F-00C04F6BC69E}"
' CopyMenuItem
Dim pCmdItem As esriFramework.ICommandItem
Set pCmdItem = m_pCtxMenu.Add(pUID)
pUID.value = "{25C0E6C1-CD06-11D2-9F40-00C04F6BC626}"
' DeleteMenuItem
Set pCmdItem = m_pCtxMenu.Add(pUID)
pUID.value = "{25C0E6C3-CD06-11D2-9F40-00C04F6BC626}"
' RenameMenuItem
Set pCmdItem = m_pCtxMenu.Add(pUID)
' Add the custom command to use the Import geoprocessing tool.
pUID.value = "{1CD666C0-BFB1-4010-A17C-86D424B3C9ED}"
Set pCmdItem = m_pCtxMenu.Add(pUID)
pCmdItem.Group = True
pUID.value = "{20724105-BAB8-11D1-9ABA-080009EC734B}"
' PropertiesMenuItem
Set pCmdItem = m_pCtxMenu.Add(pUID)
pCmdItem.Group = True
End If
' Now display the new context menu
If Not m_pCtxMenu Is Nothing then
m_pCtxMenu.Popup
' Report the chosen item
Dim pSelected_CmdItem As esriFramework.ICommandItem
Set pSelected_CmdItem = m_pCtxMenu
Set IGxObjectUI_ContextMenu = pSelected_CmdItem.ID
End If
End Property
Private Property Get IGxObjectUI_NewMenu() As esriSystem.IUID
' GxIntechangeObjectdo
es not have a NewMenu.
End Property
' IGxObjectEdit members.
Private Function IGxObjectEdit_CanRename() As Boolean
CheckAttributes
IGxObjectEdit_CanRename = m_bExists And Not (m_bReadOnly) 'True
End Function
Private Sub IGxObjectEdit_Rename(ByVal newShortName As String)
CheckAttributes
If m_bExists And Not m_bReadOnly then
If Not m_pFileSystemObject Is Nothing then
' Check for the correct extension, or add it to the new filename
Dim sTemp As String
If InStr(1, UCase(newShortName), "E00"
= (Len(newShortName) - 2) thensTemp = m_pParent.FullName &
"/"
&
newShortName
else
sTemp = m_pParent.FullName &
"/"
&
newShortName &
".e00"
End If
' Method requires filename that has no path with ext
If Not (m_pFileSystemObject.FileExists(sTemp)) then
m_pFileSystemObject.CopyFile m_sFullName, sTemp
m_pFileSystemObject.DeleteFile (m_sFullName)
'do
n't forget to rename the metadata if it is present.
If m_pFileSystemObject.FileExists(m_sFullName &
".xml"
thenm_pFileSystemObject.CopyFile m_sFullName &
".xml", sTemp &
".xml"
m_pFileSystemObject.DeleteFile m_sFullName &
".xml"
End If
' Rename the current object
Me.Name = sTemp
End If
End If
End If
End Sub
Private Function IGxObjectEdit_CanDelete() As Boolean
CheckAttributes
IGxObjectEdit_CanDelete = m_bExists And Not (m_bReadOnly) 'True
End Function
Private Sub IGxObjectEdit_Delete()
' This method uses the FileSystemObject to delete the file
CheckAttributes
If m_bExists And Not m_bReadOnly then
If Not m_pFileSystemObject Is Nothing then
m_pFileSystemObject.DeleteFile (m_sFullName)
'do
n't forget to delete the metadata if it is present.
If m_pFileSystemObject.FileExists(m_sFullName &
".xml"
thenm_pFileSystemObject.DeleteFile m_sFullName &
".xml"
End If
Dim pContainer As esriCatalog.IGxObjectContainer
Set pContainer = m_pParent
pContainer.DeleteChild Me
End If
End If
End Sub
Private Sub IGxObjectEdit_EditProperties(ByVal hParent As esriSystem.OLE_HANDLE)
' This display the generic file properties window
Dim pGxFile As esriCatalog.IGxFile
Set pGxFile = New esriCatalog.GxFile
pGxFile.Path = m_sFullName
Dim pGxObjEdit As esriCatalog.IGxObjectEdit
Set pGxObjEdit = pGxFile
pGxObjEdit.EditProperties hParent
End Sub
Private Function IGxObjectEdit_CanCopy() As Boolean
CheckAttributes
IGxObjectEdit_CanCopy = m_bExists
End Function
Private Sub CheckAttributes()
If Not m_pFileSystemObject Is Nothing then
m_bExists = m_pFileSystemObject.FileExists(m_sFullName)
If m_bExists then
Dim file As Object
Set file = m_pFileSystemObject.GetFile(m_sFullName)
If file.Attributes And 1 then
m_bReadOnly = True
else
m_bReadOnly = False
End If
End If
End If
End Sub
' IGxObjectProperties members
Private Sub IGxObjectProperties_GetPropByIndex(ByVal index As Long, pName As String, pValue As Variant)
If (index > 5) Or (index < 0) then
Err.Raise E_INVALIDARG
else
Select Case index
Case 0
pName = "ESRI_GxObject_Name"
Case 1
pName = "ESRI_GxObject_Type"
Case 2
pName = "ESRI_GxObject_FileSize"
Case 3
pName = "ESRI_GxObject_FileTime"
Case 4
pName = "ESRI_GxObject_FileMode"
Case else
Err.Raise E_INVALIDARG
Exit Sub
End Select
pValue = IGxObjectProperties_GetProperty(pName)
End If
End Sub
Private Function IGxObjectProperties_GetProperty(ByVal Name As String) As Variant
' Identify the property and return the correct value.
Select Case Name
Case "ESRI_GxObject_Name"
IGxObjectProperties_GetProperty = IGxObject_Name
Case "ESRI_GxObject_Type"
IGxObjectProperties_GetProperty = IGxObject_Category
Case else
Dim file As Object
Set file = m_pFileSystemObject.GetFile(m_sFullName)
Select Case Name
Case "ESRI_GxObject_FileSize"
' FGDC Standard expectS file size written in MB.
IGxObjectProperties_GetProperty = Format(file.Size / 1048576, "0.000"
Case "ESRI_GxObject_FileTime"
' Format of filetime is standard.
IGxObjectProperties_GetProperty = file.DateLastModified 'Format(file.DateLastModified, "Long Date"
Case "ESRI_GxObject_FileMode"
IGxObjectProperties_GetProperty = "R/W"
If file.Attributes And 1 then
IGxObjectProperties_GetProperty = "R"
Case else
Err.Raise E_INVALIDARG
Exit Function
End Select
End Select
End Function
Private Property Get IGxObjectProperties_PropertyCount() As Long
' A GxInterchangeObject has 5 supported properties.
IGxObjectProperties_PropertyCount = 5
End Property
Private Sub IGxObjectProperties_SetProperty(ByVal Name As String, ByVal value As Variant)
' A GxInterchageObject has no properties which can be set by clients
Err.Raise E_FAIL
End Sub
' IMetadata properties.
Private Property Let IMetadata_Metadata(ByVal RHS As esriSystem.IPropertySet)
' To allow the Metadata to be set, you can make use of the GxMetadata class,
' which represents an XML file.
' First check if the file already exists.
Dim sFilename As String
sFilename = m_sFullName &
".xml"
If Not ExistsMetadata(sFilename) then
' If the metadata filedo
es not already exist, create it now.
Dim newFile As Object
Set newFile = m_pFileSystemObject.CreateTextFile(sFilename, True)
newFile.Close
End If
' First create a GxMetadata object, representing the XML file of metadata.
Dim pGxFile As esriCatalog.IGxFile
Set pGxFile = New esriCatalog.GxMetadata
pGxFile.Path = sFilename
' Save the metadata
Dim pMetadata As esriGeodatabase.IMetadata
Set pMetadata = pGxFile
pMetadata.Metadata = RHS
End Property
Private Property Get IMetadata_Metadata() As esriSystem.IPropertySet
' Return the property set of the Metadata.
Dim pProp As esriSystem.IPropertySet
' Check if the metadata already exists,
If ExistsMetadata(m_sFullName &
".xml"
then' Get the metadata via the GxObject.
' First, create a new metadatafactory.
Dim pGxObjectFactory As esriCatalog.IGxObjectFactoryMetadata
Set pGxObjectFactory = New esriCatalog.GxMetadataFactory
Dim pGxObject As esriCatalog.IGxObject
Set pGxObject = pGxObjectFactory.GetGxObjectFromMetadata(m_sFullName &
".xml"
Dim pMetadata As esriGeodatabase.IMetadata
Set pMetadata = pGxObject
Set pProp = pMetadata.Metadata
else
' If the metadatado
es not exist already, create a new property set.
Set pProp = New esriGeodatabase.XmlPropertySet
End If
Set IMetadata_Metadata = pProp
End Property
Private Sub IMetadata_Synchronize(ByVal Action As esriGeodatabase.esriMetadataSyncAction, ByVal Interval As Long)
' Need to get the current metadata and QI to IXMLPropertySet.
Dim pXMLPropertySet As esriGeodatabase.IXmlPropertySet2
Set pXMLPropertySet = IMetadata_Metadata
' Create a new FGDCSynchronizationHelper, and get ISynchronizationHelper.
Dim pSynchronizationHelper As esriGeodatabase.ISynchronizationHelper
Set pSynchronizationHelper = New esriGeodatabase.FGDCSynchronizationHelper
' Decide whether or not to Synchronize.
Dim bSynchronize As Boolean
bSynchronize = False
pSynchronizationHelper.StartSynchronization pXMLPropertySet, Action, Interval, bSynchronize
' If synchronization was successful.
If Not bSynchronize then
Err.Raise S_FALSE
else
' Get the Name and NativeForm (Type) of the dataset
Dim sDataSetName As String, sNativeForm As String
sDataSetName = IGxObject_Name
sNativeForm = IGxObject_Category
' Build a string representing the UNC path for DataSetLocation
Dim lFullName As Long, lSlash As Long
lFullName = Len(m_sFullName)
lSlash = InStr(m_sFullName, "/"
Dim sDataSetLocation As String
sDataSetLocation = "//"
&
ComputerName() &
Mid(m_sFullName, lSlash, lFullName)
' Get the Environment. Generally the Boilerplate information added to most
' GxObjects will include both OS and ArcGIS software version for Environment.
' For the GxInterchangeFile we just get the OS.
Dim sEnvironment As String
sEnvironment = GetVersion()
' Get the system language, returned as ISO 2 characters
Dim sLangBuffer As String * 100
GetLocaleInfo LOCALE_USER_DEFAULT, LOCALE_SISO639LANGNAME, sLangBuffer, 99
' Get the Object size
Dim sSize As String
sSize = IGxObjectProperties_GetProperty("ESRI_GxObject_FileSize"
' Also create a new MetadataSynchronizer. This is a singleton - as well
' as being a synchronizer for basic information, it also acts as the
' synchronization manager.
Dim pMetadataSynchronizer As esriGeodatabase.IMetadataSynchronizer
Set pMetadataSynchronizer = New esriGeodatabase.MetadataSynchronizer
' Call the Update method for each bit of metadata.
' Put the name in the "DatasetName"
metadata element using pXMLPropertySet
pMetadataSynchronizer.Update pXMLPropertySet, "DatasetName", sDataSetName
' Put the Type in the "NativeType"
metadata element using pXMLPropertySet
pMetadataSynchronizer.Update pXMLPropertySet, "NativeForm", sNativeForm
' Put the Location in the correct metadata element using pXMLPropertySet
pMetadataSynchronizer.Update pXMLPropertySet, "DatasetLocation", sDataSetLocation
' Put the operating system information in the "Environment"
metadata element using pXMLPropertySet.
' This would generally include the ArcGIS version too.
pMetadataSynchronizer.Update pXMLPropertySet, "Environment", sEnvironment
'put the Language in the correct metadata element using pXMLPropertySet
pMetadataSynchronizer.Update pXMLPropertySet, "Language", sLangBuffer
' Put the Object Size in the "DatasetSize"
metadata element using pXMLPropertySet
pMetadataSynchronizer.Update pXMLPropertySet, "DatasetSize", sSize
' If IXmlPropertySet::IsNew is True, set the SyncOnce element to False at
' the end of your Synchronize method to indicate the metadata has been
' synchronized.
If pXMLPropertySet.IsNew then
pXMLPropertySet.SetPropertyX "Esri/SyncOnce", "FALSE", esriXPTText, _
esriXSPAAddOrReplace, False
End If
pSynchronizationHelper.FinishSynchronization pXMLPropertySet
'Write out the metadata using the Let Method from IMetadata.Metadata
IMetadata_Metadata = pXMLPropertySet
End If
End Sub
Private Property Get IMetadataEdit_CanEditMetadata() As Boolean
IMetadataEdit_CanEditMetadata = False
' Return true if the file is editable.
If ExistsMetadata(m_sFullName) then
Dim file As Object
Set file = m_pFileSystemObject.GetFile(m_sFullName)
If Not file.Attributes = 1 then
IMetadataEdit_CanEditMetadata = True
End If
End If
End Property
Private Function CanEditMetadata(m_sFullName As String)
If ExistsMetadata(m_sFullName) then
Dim file As Object
Set file = m_pFileSystemObject.GetFile(m_sFullName)
If Not file.Attributes = 1 then
CanEditMetadata = True
else
CanEditMetadata = False
End If
End If
End Function
Private Function ExistsMetadata(m_sName_XML As String)
Set m_pFileSystemObject = CreateObject("Scripting.FileSystemObject"
ExistsMetadata = m_pFileSystemObject.FileExists(m_sName_XML)
End Function
Public Function ComputerName() As String
' Returns the name of the local computer.
Dim buffer As String * 512, Length As Long
Length = Len(buffer)
If GetComputerName(buffer, Length) then
' this API returns non-zero if successful,
' and modifies the length argument
ComputerName = Left(buffer, Length)
End If
End Function
Public Function GetVersion() As String
' Returns the version of the OS
Dim osinfo As OSVERSIONINFO
osinfo.dwOSVersionInfoSize = 148
osinfo.szCSDVersion = Space$(128)
Dim retvalue As Integer
retvalue = GetVersionExA(osinfo)
'Get the Build Number
Dim BuildNum As Integer
Dim strBuildNum As String
BuildNum = osinfo.dwBuildNumber
If Not BuildNum then
strBuildNum = "(Build "
&
CStr(BuildNum) &
"
"else
strBuildNum = ""
End If
'Get the Version
Dim intMajor As Integer, intMinor As Integer
intMajor = osinfo.dwMajorVersion
intMinor = osinfo.dwMinorVersion
Dim strMajor As String, strMinor As String
If Not intMajor then
strMajor = "Version "
&
CStr(intMajor) &
"."
If Not intMinor then
strMinor = CStr(intMinor)
Dim strVersion As String
strVersion = strMajor &
strMinor
Dim strServicePack As String
strServicePack = Trim(osinfo.szCSDVersion)
With osinfo
Select Case .dwPlatformId
' This is for Win32_windows
Case 1
Select Case .dwMinorVersion
Case 0
GetVersion = "Windows 95 "
&
strVersion &
"
"
&
strBuildNum &
"
"
&
strServicePack &
";"
&
vbNewLine
Case 10
GetVersion = "Windows 98 "
&
strVersion &
"
"
&
strBuildNum &
"
"
&
strServicePack &
";"
&
vbNewLine
Case 90
GetVersion = "Windows Millennium "
&
strVersion &
"
"
&
strBuildNum &
"
"
&
strServicePack &
";"
&
vbNewLine
End Select
'THis is for NT
Case 2
Select Case .dwMajorVersion
Case 3
GetVersion = "Windows NT 3.51 "
&
strVersion &
"
"
&
strBuildNum &
"
"
&
strServicePack &
";"
&
vbNewLine
Case 4
GetVersion = "Windows NT 4.0 "
&
strVersion &
"
"
&
strBuildNum &
"
"
&
strServicePack &
";"
&
vbNewLine
Case 5
If .dwMinorVersion = 0 then
GetVersion = "Windows 2000 "
&
strVersion &
"
"
&
strBuildNum &
"
"
&
strServicePack &
";"
&
vbNewLine
else
GetVersion = "Windows XP "
&
strVersion &
"
"
&
strBuildNum &
"
"
&
strServicePack &
";"
&
vbNewLine
End If
End Select
Case else
GetVersion = "Failed"
End Select
End With
End Function
