' Copyright 2008 ESRI
'
' All rights reserved under the copyright laws of the United States
' and applicable international laws, treaties, and conventions.
'
' You may freely redistribute and use this sample code, with or
' without modification, provided you include the original copyright
' notice and use restrictions.
'
' See use restrictions at <your ArcGIS install location>/developerkit/userestrictions.txt.
Option Explicit
'-----------------
' Public Contants
'-----------------
Public Const COMMAND_CATEGORY As String = "Geodatabase Designer"
Public Const HELP_FOLDER As String = "HELP"
Public Const HELP_FILE As String = "HELP.htm"
Public Const GUID_FEATURECLASS_CLSID As Variant = "{52353152-891A-11D0-BEC6-00805F7C4268}"
Public Const GUID_TABLE_CLSID As Variant = "{7A566981-C114-11D2-8A28-006097AFF44E}"
Public Const GUID_ANNOTATION_CLSID As Variant = "{E3676993-C682-11D2-8A2A-006097AFF44E}"
Public Const GUID_ANNOTATION_EXTCLSID As Variant = "{24429589-D711-11D2-9F41-00C04F6BC6A5}"
Public Const GUID_DIMENSION_CLSID As Variant = "{496764FC-E0C9-11D3-80CE-00C04F601565}"
Public Const GUID_DIMENSION_EXTCLSID As Variant = "{48F935E2-DA66-11D3-80CE-00C04F601565}"
Public Const GUID_SIMPLEJUNCTION_CLSID As Variant = "{CEE8D6B8-55FE-11D1-AE55-0000F80372B4}"
Public Const GUID_SIMPLEEDGE_CLSID As Variant = "{E7031C90-55FE-11D1-AE55-0000F80372B4}"
Public Const GUID_COMPLEXEDGE_CLSID As Variant = "{A30E8A2A-C50B-11D1-AEA9-0000F80372B4}"
Public Const ENUMERATOR_FIELDTYPE As String = "Small Integer, Integer, Single, Double, String, Date, OID, Geometry, Blob"
Public Const ENUMERATOR_MERGEPOLICY As String = "0, Sum Values, Area Weigthed, Default Value"
Public Const ENUMERATOR_SPLITPOLICY As String = "0, Geometry Ratio, Duplicate, Default Value"
Public Const ENUMERATOR_DOMAINTYPE As String = "0, Range, Coded Value, String"
Public Const ENUMERATOR_NETWORKCLASSANCILLARYROLE As String = "None, Source/Sink"
Public Const ENUMERATOR_FEATURETYPE As String = "0, Simple Feature, 2, 3, 4, 5, 6, Simple Junction, Simple Edge, Complex Junction, Complex Edge, Annotation, Coverage Annotation, Dimension"
'------------------
' Public Variables
'------------------
Public mGNExportFeatureClass As Boolean
Public mGNExportJunctionConnRule As Boolean
Public mGNExportEdgeConnRule As Boolean
Public mGNExportWeights As Boolean
Public mGNImportSnapping As Double ' -1 = None | 0 = Minimum | >0 = Other
Public mGNImportPreserveEnabledValue As Boolean
Public mGNImportClearConnRule As Boolean
Public mDMExportOCAssocation As Boolean
Public mXLReformatPrettyPrint As Boolean
Public mOCExportFieldIndex As Boolean
Public mOCImportFieldIndex As Boolean
'-------------------
' Private Constants
'-------------------
Private Const SW_SHOWNORMAL As Long = 1 ' Used by ShellExecute Windows API
Private Const MODULE_NAME As String = "modCommon.bas" ' Error Handler
'----------------------
' Windows Declarations
'----------------------
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenFileName As OPENFILENAME) As Long
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenFileName As OPENFILENAME) As Long
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
'-------------------
' Custom Data Types
'-------------------
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
'-------------------
' Windows API Calls
'-------------------
Private Function ShowOpen() As String
On Error GoTo ErrorHandler
'
Dim pOpenFileName As OPENFILENAME
' Set the structure size
pOpenFileName.lStructSize = Len(pOpenFileName)
' Set the application's instance
pOpenFileName.hInstance = App.hInstance
' Set the filet
pOpenFileName.lpstrFilter = "XML (*.xml)" & Chr$(0) & "*.xml" & Chr$(0) & _
"All files (*.*)" & Chr$(0) & "*.*" & Chr$(0)
' Create a buffer
pOpenFileName.lpstrFile = Space$(254)
' Set the maximum number of chars
pOpenFileName.nMaxFile = 255
' Create a buffer
pOpenFileName.lpstrFileTitle = Space$(254)
' Set the maximum number of chars
pOpenFileName.nMaxFileTitle = 255
' Set the dialog title
pOpenFileName.lpstrTitle = "Open XML file..."
' no extra flags
pOpenFileName.flags = 0
' Show the 'Open File'-dialog
If GetOpenFileName(pOpenFileName) Then
ShowOpen = Trim(pOpenFileName.lpstrFile)
Else
ShowOpen = ""
End If
'
Exit Function
ErrorHandler:
Call HandleError(False, "ShowOpen " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Function
Private Function ShowSave() As String
On Error GoTo ErrorHandler
'
Dim pOpenFileName As OPENFILENAME
' Set the structure size
pOpenFileName.lStructSize = Len(pOpenFileName)
' Set the application's instance
pOpenFileName.hInstance = App.hInstance
' Set the file filter
pOpenFileName.lpstrFilter = "XML (*.xml)" & Chr$(0) & "*.xml" & Chr$(0) & _
"All files (*.*)" & Chr$(0) & "*.*" & Chr$(0)
' Create a buffer
pOpenFileName.lpstrFile = Space$(254)
' Set the maximum number of chars
pOpenFileName.nMaxFile = 255
' Create a buffer
pOpenFileName.lpstrFileTitle = Space$(254)
' Set the maximum number of chars
pOpenFileName.nMaxFileTitle = 255
' Set the dialog title
pOpenFileName.lpstrTitle = "Save XML file As..."
' Set flags
' cdlOFNPathMustExist &H800
' cdlOFNOverwritePrompt &H2
pOpenFileName.flags = &H2 Or &H800
' Specify the default extension (used when no ext is specified).
pOpenFileName.lpstrDefExt = ".xml"
' Show the 'Save File'-dialog
If GetSaveFileName(pOpenFileName) Then
ShowSave = Trim(pOpenFileName.lpstrFile)
Else
ShowSave = ""
End If
'
Exit Function
ErrorHandler:
Call HandleError(False, "ShowSave " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Function
Public Function GetXMLDocument() As MSXML2.DOMDocument
On Error GoTo ErrorHandler
'
Dim pXMLFileName As String
Dim pDOMDocument As MSXML2.DOMDocument
'----------------------------------------------------------------
' Use Microsoft Common Dialog to prompt user for source XML file
'----------------------------------------------------------------
pXMLFileName = modCommon.ShowOpen
If pXMLFileName = "" Then
MsgBox "No File Selected", vbInformation, App.FileDescription
Exit Function
End If
'-------------------
' Open XML Document
'-------------------
Set pDOMDocument = New MSXML2.DOMDocument
pDOMDocument.async = False
pDOMDocument.validateOnParse = True
Call pDOMDocument.Load(pXMLFileName) ' Returns FALSE if FAIL. Check if Raise Error?
Call pDOMDocument.setProperty("SelectionLanguage", "XPath")
'--------------------------------------------
' Return reference to XML Document to client
'--------------------------------------------
Set GetXMLDocument = pDOMDocument
'
Exit Function
ErrorHandler:
Call HandleError(False, "GetXMLDocument " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Function
Public Function NewXMLDocument() As MSXML2.DOMDocument
On Error GoTo ErrorHandler
'------------------------------------------
' Returns to the client a NEW XML document
'------------------------------------------
Dim pDOMDocument As MSXML2.DOMDocument
Set pDOMDocument = New MSXML2.DOMDocument
Call pDOMDocument.setProperty("SelectionLanguage", "XPath")
'
Set NewXMLDocument = pDOMDocument
'
Exit Function
ErrorHandler:
Call HandleError(False, "NewXMLDocument " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Function
Public Sub PutXMLDocument(ByRef pDOMDocument As MSXML2.DOMDocument)
On Error GoTo ErrorHandler
'---------------------------
' Create a new XML document
'---------------------------
Dim pXMLFileName As String
'
pXMLFileName = modCommon.ShowSave
If pXMLFileName = "" Then
MsgBox "No File Selected", vbInformation, App.FileDescription
Exit Sub
End If
'
Call pDOMDocument.save(pXMLFileName)
Set pDOMDocument = Nothing
'
If mXLReformatPrettyPrint Then
Call MakePrettyPrint(pXMLFileName, 4)
End If
'
Exit Sub
ErrorHandler:
Call HandleError(False, "PutXMLDocument " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Public Function GetCurrentUserName() As String
On Error GoTo ErrorHandler
'
Dim strUserName As String
'
strUserName = String(100, Chr(0))
Call GetUserName(strUserName, 100)
GetCurrentUserName = Left(strUserName, InStr(strUserName, Chr(0)) - 1)
'
Exit Function
ErrorHandler:
Call HandleError(False, "GetCurrentUserName " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Function
Public Function GetPCName() As String
On Error GoTo ErrorHandler
'
Dim strComputer As String
'
strComputer = String(255, Chr(0))
Call GetComputerName(strComputer, 255)
GetPCName = Left(strComputer, InStr(1, strComputer, Chr(0)) - 1)
'
Exit Function
ErrorHandler:
Call HandleError(False, "GetPCName " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Function
'----------------------
' GEODATABASE ROUTINES
'----------------------
Public Function GetGeodatabaseVersion(ByRef pWorkspace As esriGeoDatabase.IWorkspace) As String
On Error GoTo ErrorHandler
'
Dim pGeodatabaseRelease As esriGeoDatabase.IGeodatabaseRelease
'
Set pGeodatabaseRelease = pWorkspace
GetGeodatabaseVersion = pGeodatabaseRelease.MajorVersion & "." & pGeodatabaseRelease.MinorVersion & "." & pGeodatabaseRelease.BugfixVersion
'
Exit Function
ErrorHandler:
Call HandleError(False, "GetGeodatabaseVersion " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Function
Public Function GetConnectionProperties(ByRef pWorkspace As esriGeoDatabase.IWorkspace) As VBA.Collection
On Error GoTo ErrorHandler
'
Dim pCollection As VBA.Collection
Dim pPropertySet As esriSystem.IPropertySet
Dim pIndex As Long
Dim pNames As Variant
Dim pValues As Variant
'
Set pCollection = New VBA.Collection
Set pPropertySet = pWorkspace.ConnectionProperties
pPropertySet.GetAllProperties pNames, pValues
For pIndex = 0 To UBound(pNames) Step 1
If UCase(pNames(pIndex)) <> "PASSWORD" And _
UCase(pNames(pIndex)) <> "PROVIDERCLSID" Then
pCollection.Add pNames(pIndex), pValues(pIndex)
End If
Next pIndex
'
Exit Function
ErrorHandler:
Call HandleError(False, "GetConnectionProperties " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Function
Public Function GetDataset(ByRef pDataset As esriGeoDatabase.IDataset) As IDataset
On Error GoTo ErrorHandler
'
Set GetDataset = pDataset
'
Exit Function
ErrorHandler:
Call HandleError(False, "GetDataset " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Function
Public Function GetGeodatabaseFlavor(ByRef pWorkspace As esriGeoDatabase.IWorkspace) As String
On Error GoTo ErrorHandler
'---------------------------------------------------
' This function will return the Geodatabase's RDBMS
'---------------------------------------------------
Const pKeywordOracle As String = "ACCESS"
Const pKeywordSQLServer As String = "AUTHORIZATION"
Const pKeywordInformix As String = "?"
Const pKeywordDB2 As String = "?"
'
Select Case pWorkspace.Type
Case esriFileSystemWorkspace
GetGeodatabaseFlavor = "Invalid"
Case esriLocalDatabaseWorkspace
GetGeodatabaseFlavor = "Access"
Case esriRemoteDatabaseWorkspace
'--------------------------------------
' Select RDBMS based on reserved words
'--------------------------------------
Dim pSQLSyntax As esriGeoDatabase.ISQLSyntax
Dim pEnumBSTR As esriSystem.IEnumBSTR
Dim pKeyword As String
Dim pTable As esriGeoDatabase.ITable
'
Set pSQLSyntax = pWorkspace
Set pEnumBSTR = pSQLSyntax.GetKeywords
pKeyword = pEnumBSTR.Next
GetGeodatabaseFlavor = "Unknown"
Do Until pKeyword = ""
Select Case pKeyword
Case pKeywordOracle
GetGeodatabaseFlavor = "Oracle"
Case pKeywordSQLServer
GetGeodatabaseFlavor = "SQLServer"
Case pKeywordInformix
GetGeodatabaseFlavor = "Informix"
Case pKeywordDB2
GetGeodatabaseFlavor = "DB2"
End Select
pKeyword = pEnumBSTR.Next
Loop
End Select
'
Exit Function
ErrorHandler:
Call HandleError(False, "GetGeodatabaseFlavor " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Function
'---------------------------
' FileSystemObject Routines
'---------------------------
Public Function AppendInstallationPath(ByRef pFileName As String) As String
On Error GoTo ErrorHandler
'
Dim pFSO As Scripting.FileSystemObject
Set pFSO = New Scripting.FileSystemObject
'
AppendInstallationPath = pFSO.BuildPath(App.Path, pFileName)
'
Exit Function
ErrorHandler:
Call HandleError(False, "AppendInstallationPath " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Function
Public Sub SubmitFileToOS(ByRef pFileName As String)
On Error GoTo ErrorHandler
'
Call ShellExecute(0, "open", pFileName, vbNullString, "", SW_SHOWNORMAL)
'
Exit Sub
ErrorHandler:
Call HandleError(False, "SubmitFileToOS " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Public Sub WriteFile(ByRef pFileName As String, ByRef pLine As String)
'------------------------------------------------------
' Write line to a text file.
' Used to write the HTML document and Error Reporting.
'------------------------------------------------------
If Len(pLine) > 0 Then
Dim pFSO As Scripting.FileSystemObject
Dim pTextStream As Scripting.TextStream
'
Set pFSO = New Scripting.FileSystemObject
'---------------------------------------
' Write the submitted line to the File.
'----------------------------------------
Set pTextStream = pFSO.OpenTextFile(pFileName, _
Scripting.ForAppending, _
True, _
Scripting.TristateFalse)
pTextStream.WriteLine pLine
pTextStream.Close
End If
End Sub
'----------------------------
' Geodatabase Designer Calls
'----------------------------
Public Function QuoteSwap(ByRef pLineIn As String) As String
On Error GoTo ErrorHandler
'------------------------------------
' Swap single quote for double quote
'------------------------------------
QuoteSwap = Replace(pLineIn, Chr(39), Chr(34), 1, -1, vbTextCompare)
'
Exit Function
ErrorHandler:
Call HandleError(False, "QuoteSwap " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Function
Public Sub AddNodeAttribute(ByRef pXMLDOMNode As MSXML2.IXMLDOMNode, _
ByRef pName As String, _
ByRef pValue As String)
On Error GoTo ErrorHandler
'
Dim pXMLDOMAttribute As MSXML2.IXMLDOMAttribute
'
Set pXMLDOMAttribute = pXMLDOMNode.Attributes.setNamedItem(pXMLDOMNode.ownerDocument.createAttribute(pName))
pXMLDOMAttribute.Text = pValue
'
Exit Sub
ErrorHandler:
Call HandleError(False, "AddNodeAttribute " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Public Sub WriteGeodatabaseDesignerHeader(ByRef pDOMDocument As MSXML2.DOMDocument, _
ByRef pWorkspace As esriGeoDatabase.IWorkspace)
On Error GoTo ErrorHandler
'
Const pXSLFolderName As String = "XSL"
Const pXSLFileName As String = "Geodatabase Designer.xsl"
'
Dim pXMLDOMNodeXML As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeGeodatabaseDesigner As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeMetadata As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeMetadataChild As MSXML2.IXMLDOMNode
Dim pXMLDOMNodeConnectionProperty As MSXML2.IXMLDOMNode
'
Dim pFSO As Scripting.FileSystemObject
'
Dim pPropertySet As esriSystem.IPropertySet
Dim pNames As Variant
Dim pValues As Variant
Dim pIndex As Long
Dim pXSLPathName As String
'------------------------------
' Create an in-memory XML file
'------------------------------
Set pDOMDocument = New MSXML2.DOMDocument
'--------------------------------------------------------------------
' Add the "Processing Instruction Header"
' <?xml version="1.0" encoding='UTF-8'?>
' <?xml-stylesheet type="text/xsl" href="Geodatabase Designer.xsl"?>
'--------------------------------------------------------------------
Set pXMLDOMNodeXML = pDOMDocument.createProcessingInstruction("xml", QuoteSwap("version='1.0' encoding='UTF-8'"))
Set pXMLDOMNodeXML = pDOMDocument.appendChild(pXMLDOMNodeXML)
Set pFSO = New FileSystemObject
pXSLPathName = pFSO.BuildPath(pFSO.GetFolder(App.Path).ParentFolder.Path, pXSLFolderName)
pXSLPathName = pFSO.BuildPath(pXSLPathName, pXSLFileName)
Set pXMLDOMNodeXML = pDOMDocument.createProcessingInstruction("xml-stylesheet", QuoteSwap("type='text/xsl' href='" & pXSLPathName & "'"))
Set pXMLDOMNodeXML = pDOMDocument.appendChild(pXMLDOMNodeXML)
'--------------------------------------------
' Add "GeodatabaseDesigner" Node (+ version)
' <geodatabasedesigner version="1.0">
'--------------------------------------------
Set pXMLDOMNodeGeodatabaseDesigner = pDOMDocument.createNode(MSXML2.NODE_ELEMENT, "geodatabaseDesigner", "")
Set pXMLDOMNodeGeodatabaseDesigner = pDOMDocument.appendChild(pXMLDOMNodeGeodatabaseDesigner)
Call modCommon.AddNodeAttribute(pXMLDOMNodeGeodatabaseDesigner, "version", CStr(App.Major) & "." & CStr(App.Minor))
'-------------------------------------------------
' Add "Metadata" node under "GeodatabaseDesigner"
' <metadata>
'-------------------------------------------------
Set pXMLDOMNodeMetadata = pDOMDocument.createNode(MSXML2.NODE_ELEMENT, "metadata", "")
Set pXMLDOMNodeMetadata = pXMLDOMNodeGeodatabaseDesigner.appendChild(pXMLDOMNodeMetadata)
'------------------------------------------------------------
' Add "CreationDate" node under "Metadata"
' <creationDate year="" month="" day="" hour="" second="" />
'------------------------------------------------------------
Set pXMLDOMNodeMetadataChild = pDOMDocument.createNode(MSXML2.NODE_ELEMENT, "creationDate", "")
Set pXMLDOMNodeMetadataChild = pXMLDOMNodeMetadata.appendChild(pXMLDOMNodeMetadataChild)
Call modCommon.AddNodeAttribute(pXMLDOMNodeMetadataChild, "year", CStr(Year(Date)))
Call modCommon.AddNodeAttribute(pXMLDOMNodeMetadataChild, "month", PadZero(CStr(Month(Date)), 2))
Call modCommon.AddNodeAttribute(pXMLDOMNodeMetadataChild, "day", PadZero(CStr(Day(Date)), 2))
Call modCommon.AddNodeAttribute(pXMLDOMNodeMetadataChild, "hour", PadZero(CStr(Hour(Time)), 2))
Call modCommon.AddNodeAttribute(pXMLDOMNodeMetadataChild, "minute", PadZero(CStr(Minute(Time)), 2))
Call modCommon.AddNodeAttribute(pXMLDOMNodeMetadataChild, "second", PadZero(CStr(Second(Time)), 2))
'--------------------------------------
' Add "Creator" under "Metadata"
' <creator user="" computer="" />
'--------------------------------------
Set pXMLDOMNodeMetadataChild = pDOMDocument.createNode(MSXML2.NODE_ELEMENT, "creator", "")
Set pXMLDOMNodeMetadataChild = pXMLDOMNodeMetadata.appendChild(pXMLDOMNodeMetadataChild)
Call modCommon.AddNodeAttribute(pXMLDOMNodeMetadataChild, "user", modCommon.GetCurrentUserName)
Call modCommon.AddNodeAttribute(pXMLDOMNodeMetadataChild, "computer", modCommon.GetPCName)
'------------------------------------------------------------
' Add "Geodatabase" under "Metadata"
' <geodatabase esriWorkspaceType="" flavor="" version="" />
'-------------------------------------------------------------
Set pXMLDOMNodeMetadataChild = pDOMDocument.createNode(MSXML2.NODE_ELEMENT, "geodatabase", "")
Set pXMLDOMNodeMetadataChild = pXMLDOMNodeMetadata.appendChild(pXMLDOMNodeMetadataChild)
Call modCommon.AddNodeAttribute(pXMLDOMNodeMetadataChild, "esriWorkspaceType", CStr(pWorkspace.Type))
Call modCommon.AddNodeAttribute(pXMLDOMNodeMetadataChild, "flavor", GetGeodatabaseFlavor(pWorkspace))
Call modCommon.AddNodeAttribute(pXMLDOMNodeMetadataChild, "version", GetGeodatabaseVersion(pWorkspace))
'------------------------------------------------------
' Add "ConnectionProperties" under "Metadata"
' <connectionProperty parameter1="" parameter2="" />
'------------------------------------------------------
Set pPropertySet = pWorkspace.ConnectionProperties
pPropertySet.GetAllProperties pNames, pValues
For pIndex = 0 To UBound(pNames) Step 1
If UCase(pNames(pIndex)) <> "PASSWORD" And _
UCase(pNames(pIndex)) <> "PROVIDERCLSID" Then
'-------------------------------------------------------------------
' Add Connection Parameters to "ConnectionProperties" as Attributes
'-------------------------------------------------------------------
Set pXMLDOMNodeConnectionProperty = pDOMDocument.createNode(MSXML2.NODE_ELEMENT, "connectionProperty", "")
Set pXMLDOMNodeConnectionProperty = pXMLDOMNodeMetadataChild.appendChild(pXMLDOMNodeConnectionProperty)
Call modCommon.AddNodeAttribute(pXMLDOMNodeConnectionProperty, "name", CStr(pNames(pIndex)))
Call modCommon.AddNodeAttribute(pXMLDOMNodeConnectionProperty, "value", CStr(pValues(pIndex)))
End If
Next pIndex
'
Exit Sub
ErrorHandler:
Call HandleError(False, "WriteGeodatabaseDesignerHeader " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
'===============
' FORM ROUTINES
'===============
Public Sub EnableFrame(ByRef pFrame As VB.Frame, _
ByRef pState As Boolean)
On Error GoTo ErrorHandler
'-----------------------------------------------------------
' Enables or Disables all the controls in the parsed FRAME.
'-----------------------------------------------------------
Dim pControl As VB.Control
Dim pObject As Object
Dim pFrameTest As VB.Frame
Dim pForm As VB.Form
'
pFrame.Enabled = pState
Set pForm = pFrame.Parent
'
For Each pControl In pForm.Controls
If Not (TypeOf pControl Is MSComctlLib.ImageList) Then
Set pObject = pControl.Container
If TypeOf pObject Is VB.Frame Then
Set pFrameTest = pObject
If pFrameTest.Name = pFrame.Name Then
If TypeOf pControl Is VB.Frame Then
Call EnableFrame(pControl, pState)
Else
pControl.Enabled = pFrame.Enabled
End If
End If
End If
End If
Next
'
Exit Sub
ErrorHandler:
Call HandleError(False, "EnableFrame " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
'---------------------------------------
' Format XML Document to "Pretty Print"
'---------------------------------------
Private Sub MakePrettyPrint(ByRef pXMLFile As String, _
Optional ByRef pIndentation As Long = 4)
On Error GoTo ErrorHandler
'
Dim pLevel As Long
Dim pIndex As Long
Dim pLine As String
Dim pXML As Variant
Dim pFSO As Scripting.FileSystemObject
Dim pTextStream As Scripting.TextStream
'
Set pFSO = New Scripting.FileSystemObject
Set pTextStream = pFSO.OpenTextFile(pXMLFile, _
Scripting.ForReading, _
True, _
Scripting.TristateFalse)
pXML = Split(pTextStream.ReadAll, ">", -1)
Call pTextStream.Close
Set pTextStream = Nothing
Set pTextStream = pFSO.OpenTextFile(pXMLFile, _
Scripting.ForWriting, _
True, _
Scripting.TristateUseDefault)
pLevel = 0
For pIndex = LBound(pXML, 1) To UBound(pXML, 1) Step 1
pLine = CStr(pXML(pIndex))
pLine = Replace(pLine, Chr(13), "")
pLine = Replace(pLine, Chr(10), "")
If Len(pLine) > 2 Then
Select Case Mid(pLine, 1, 2)
Case "<?"
If pIndex = LBound(pXML, 1) Then
pLevel = 0
Else
pLevel = pLevel + 1
End If
Case "</"
pLevel = pLevel + 0
Case Else
pLevel = pLevel + 1
End Select
'
Call pTextStream.WriteLine(Space(pLevel * pIndentation) & pLine & ">")
'
Select Case Mid(pLine, 1, 2)
Case "<?"
pLevel = pLevel - 1
Case "</"
pLevel = pLevel - 1
Case Else
If Mid(pLine, Len(pLine)) = "/" Then
pLevel = pLevel - 1
End If
End Select
End If
Next pIndex
'
Call pTextStream.Close
'
Set pTextStream = Nothing
Set pFSO = Nothing
'
Exit Sub
ErrorHandler:
Call HandleError(False, "MakePrettyPrint " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub
Private Function PadZero(ByRef pLine As String, _
ByRef pLength As Long) As String
On Error GoTo ErrorHandler
'
PadZero = String(CLng(pLength - Len(pLine)), "0") & pLine
'
Exit Function
ErrorHandler:
Call HandleError(False, "PadZero " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Function
Public Sub LaunchHelp()
On Error GoTo ErrorHandler
'
Dim pFSO As Scripting.FileSystemObject
Dim pFolder As Scripting.Folder
Dim pHelpLocation As String
'
Set pFSO = New Scripting.FileSystemObject
'
Set pFolder = pFSO.GetFolder(App.Path)
Set pFolder = pFolder.ParentFolder
'
If pFSO.FolderExists(pFSO.BuildPath(pFolder.Path, HELP_FOLDER)) Then
Set pFolder = pFSO.GetFolder(pFSO.BuildPath(pFolder.Path, HELP_FOLDER))
'
If pFSO.FileExists(pFSO.BuildPath(pFolder.Path, HELP_FILE)) Then
Call modCommon.SubmitFileToOS(pFSO.BuildPath(pFolder.Path, HELP_FILE))
Else
Call MsgBox("Error: Help file is missing from:" & vbCrLf & _
App.Path & "\" & HELP_FOLDER & " \ " & HELP_FILE)
End If
Else
Call MsgBox("Error: Help file is missing from:" & vbCrLf & _
App.Path & "\" & HELP_FOLDER & " \ " & HELP_FILE)
End If
'
Exit Sub
ErrorHandler:
Call HandleError(False, "LaunchHelp " & MODULE_NAME & " (" & CStr(Erl) & ")", Err.Number, Err.Source, Err.Description)
End Sub