Sub TestSrc()
Dim pMxDocument As IMxDocument
Dim pMap As IMap
Dim pEnumLayer As IEnumLayer
Dim pLayer As ILayer
Dim pftLayer As IGeoFeatureLayer
Dim pId As New UID
Dim pdatasetname As IDatasetName
Dim pwkName As IWorkspaceName
Dim pDataset As IDataset
Set pMxDocument = Application.Document
Set pMap = pMxDocument.FocusMap
pId = "{E156D7E5-22AF-11D3-9F99-00C04F6BC78E}"
Set pEnumLayer = pMap.Layers(pId, True)
pEnumLayer.Reset
Dim Names(9) As Variant
Dim Values(9) As Variant

Set pLayer = pEnumLayer.Next
Do While Not pLayer Is Nothing
Set pftLayer = pLayer
Set pDataset = pftLayer.FeatureClass
Set pdatasetname = pDataset.FullName
Debug.Print pdatasetname.Name
Dim varNames As Variant, varValues As Variant
Dim pPropertySet As IPropertySet
Set pPropertySet = pDataset.PropertySet
pPropertySet.GetAllProperties varNames, varValues
Dim i As Long
For i = 0 To pPropertySet.count - 1
Debug.Print varNames(i) & " = " & varValues(i)
Next

Set pwkName = pdatasetname.WorkspaceName
'Dim pPropertySet As IPropertySet
'Set pPropertySet = pwkName.ConnectionProperties



' pPropertySet.GetAllProperties varNames, varValues
' Dim i As Long
' For i = 0 To pPropertySet.Count - 1
' Debug.Print varNames(i) & " = " & varValues(i)
' Next




' Debug.Print pwkName.PathName
' Debug.Print pwkName.BrowseName
Set pLayer = pEnumLayer.Next
Loop





End Sub



Sub FindRelatedRecord()


'hook the current map
Dim pDoc As IMxDocument
Dim pMap As IStandaloneTableCollection
Dim pMapView As IMap
Dim pStdAloneTbl As IStandaloneTable
Dim pTableSel As ITableSelection
Dim pQueryFilt As IQueryFilter
Dim pSelSet As ISelectionSet

Set pDoc = Application.Document
Set pMap = pDoc.FocusMap
Set pMapView = pDoc.FocusMap

For i = 0 To pMap.StandaloneTableCount - 1
Set pStdAloneTbl = pMap.StandaloneTable(i)
If pStdAloneTbl.Name = "WATER.WATTACHMENT" Then Exit For
Next i
Set pTableSel = pStdAloneTbl
Dim ptable As ITable
Set ptable = pStdAloneTbl
Dim pdisTable As IDisplayTable
Set pdisTable = ptable


Dim pEnumRelClass As IEnumRelationshipClass
Dim pRelClass As IRelationshipClass

Dim pObjectClass As IObjectClass
Dim pDSet As IDataset
Set pObjectClass = pdisTable.DisplayTable
Set pEnumRelClass = pObjectClass.RelationshipClasses(esriRelRoleAny)
Set pRelClass = pEnumRelClass.Next
Do While Not pRelClass Is Nothing
Set pDSet = pRelClass
If pDSet.Name = "WATER.WLateralLine_Has_WAttachment" Then Exit Do
Set pRelClass = pEnumRelClass.Next
Loop





Set pQueryFilt = New QueryFilter
pQueryFilt.WhereClause = "FilePath like '%WorkOrders%'"

' Perform the selection
pTableSel.SelectRows pQueryFilt, esriSelectionResultNew, False

' Report how many rows were selected
Set pSelSet = pTableSel.SelectionSet
Dim pEnumID As IEnumIDs
Set pEnumID = pSelSet.IDs
'Debug.Print pSelSet.count & " rows selected in " & pStdAloneTbl.Name
Dim pRow As IRow
Dim pDesRow As IRow
Dim pOutSet As ISet



pEnumID.Reset
Dim id As Long
id = pEnumID.Next
Dim count As Long
count = 1
Dim output As String
Open "C:\LateralWorkOrder.txt" For Output As #1

Do While Not id = -1

Set pRow = ptable.GetRow(id)
'Debug.Print pRow.Value(1)
output = count & "," & pRow.Value(1)
Set pOutSet = pRelClass.GetObjectsRelatedToObject(pRow)
Dim pfields As IFields

If pOutSet.count <> 0 Then
Set pDesRow = pOutSet.Next
Set pfields = pDesRow.Fields
output = output & "," & pDesRow.Value(pfields.FindField("DistrictMap"))
output = output & "," & pDesRow.Value(pfields.FindField("InstallDate"))
output = output & "," & pDesRow.Value(pfields.FindField("WorkOrderID"))
output = output & "," & pDesRow.Value(pfields.FindField("PWP_FILENUMBER"))
output = output & "," & pDesRow.Value(pfields.FindField("PWP_SERVICENUMBER"))
'output = output & "," & pDesRow.Value(pfields.FindField("BUILDINGNUMBER")) & " " & pDesRow.Value(pfields.FindField("STREETNAME")) & " " & pDesRow.Value(pfields.FindField("STREETTYPE"))
output = output & "," & pDesRow.Value(pfields.FindField("LOC_OFFSET")) & " " & pDesRow.Value(pfields.FindField("LOC_STREETNAME")) & " " & pDesRow.Value(pfields.FindField("LOC_STREETTYPE"))
Debug.Print output
Write #1, output


' Debug.Print pRow.Value(1) & "," & pDesRow.Value(pfields.FindField("DistrictMap")) & "," & pDesRow.Value(4) & "," & pDesRow.Value(7) & "," & pDesRow.Value(13) & "," & pDesRow.Value(26) & "," & pDesRow.Value(30) & " " & pDesRow.Value(31) & "," & pDesRow.Value(40)
count = count + 1

End If

id = pEnumID.Next
Loop

Debug.Print "completed"
Close #1

End Sub

Sub FindRelatedRecord2()


'hook the current map
Dim pDoc As IMxDocument
Dim pMap As IStandaloneTableCollection
Dim pMapView As IMap
Dim pStdAloneTbl As IStandaloneTable
Dim pTableSel As ITableSelection
Dim pQueryFilt As IQueryFilter
Dim pSelSet As ISelectionSet

Set pDoc = Application.Document
Set pMap = pDoc.FocusMap
Set pMapView = pDoc.FocusMap

For i = 0 To pMap.StandaloneTableCount - 1
Set pStdAloneTbl = pMap.StandaloneTable(i)
If pStdAloneTbl.Name = "WATER.WATTACHMENT" Then Exit For
Next i
Set pTableSel = pStdAloneTbl
Dim ptable As ITable
Set ptable = pStdAloneTbl
Dim pdisTable As IDisplayTable
Set pdisTable = ptable


Dim pEnumRelClass As IEnumRelationshipClass
Dim pRelClass As IRelationshipClass

Dim pObjectClass As IObjectClass
Dim pDSet As IDataset
Set pObjectClass = pdisTable.DisplayTable
Set pEnumRelClass = pObjectClass.RelationshipClasses(esriRelRoleAny)
Set pRelClass = pEnumRelClass.Next
Do While Not pRelClass Is Nothing
Set pDSet = pRelClass
If pDSet.Name = "WATER.WEasement_Has_WAttachment" Then Exit Do
'Debug.Print pDSet.Name
Set pRelClass = pEnumRelClass.Next
Loop





Set pQueryFilt = New QueryFilter
pQueryFilt.WhereClause = "FilePath like '%Easements%'"

' Perform the selection
pTableSel.SelectRows pQueryFilt, esriSelectionResultNew, False

' Report how many rows were selected
Set pSelSet = pTableSel.SelectionSet
Dim pEnumID As IEnumIDs
Set pEnumID = pSelSet.IDs
'Debug.Print pSelSet.count & " rows selected in " & pStdAloneTbl.Name
Dim pRow As IRow
Dim pDesRow As IRow
Dim pOutSet As ISet



pEnumID.Reset
Dim id As Long
id = pEnumID.Next
Dim count As Long
count = 1
Dim output As String
Open "C:\Easements.txt" For Output As #1

Do While Not id = -1

Set pRow = ptable.GetRow(id)
'Debug.Print pRow.Value(1)
output = count & "," & pRow.Value(1)
Set pOutSet = pRelClass.GetObjectsRelatedToObject(pRow)
Dim pfields As IFields

If pOutSet.count <> 0 Then
Set pDesRow = pOutSet.Next
Set pfields = pDesRow.Fields
output = output & "," & pDesRow.Value(pfields.FindField("DistrictMap"))
output = output & "," & pDesRow.Value(pfields.FindField("FacilityID"))
output = output & "," & pDesRow.Value(pfields.FindField("Description"))
' output = output & "," & pDesRow.Value(pfields.FindField("PWP_FILENUMBER"))
' output = output & "," & pDesRow.Value(pfields.FindField("PWP_SERVICENUMBER"))
' output = output & "," & pDesRow.Value(pfields.FindField("BUILDINGNUMBER")) & " " & pDesRow.Value(pfields.FindField("STREETNAME")) & " " & pDesRow.Value(pfields.FindField("STREETTYPE"))
Debug.Print output
Write #1, output
count = count + 1


' Debug.Print pRow.Value(1) & "," & pDesRow.Value(pfields.FindField("DistrictMap")) & "," & pDesRow.Value(4) & "," & pDesRow.Value(7) & "," & pDesRow.Value(13) & "," & pDesRow.Value(26) & "," & pDesRow.Value(30) & " " & pDesRow.Value(31) & "," & pDesRow.Value(40)

End If

id = pEnumID.Next
Loop

Debug.Print "completed"
Close #1

End Sub

Sub dump()

'Get the set of the selected rows
Dim pInSet As ISet
Dim pCursor As ICursor
Dim pRow As IRow
Set pInSet = New esriSystem.Set
pFrSelSet.Search Nothing, False, pCursor
Set pRow = pCursor.NextRow
Do While Not pRow Is Nothing
pInSet.Add pRow
Set pRow = pCursor.NextRow
Loop
pInSet.Reset

'find the selected relationship class in the map
Dim pRCColl As esriCarto.IRelationshipClassCollection
Dim pEnumRel As esriGeoDatabase.IEnumRelationshipClass
Dim pRelClass As esriGeoDatabase.IRelationshipClass
Dim pDSet As esriGeoDatabase.IDataset
Set pRCColl = pMap
Set pEnumRel = pRCColl.FindRelationshipClasses(pFromDispTab.DisplayTable, esriRelRoleAny)
Dim FoundRelClass As Boolean
FoundRelClass = False
If Not pEnumRel Is Nothing Then
Set pRelClass = pEnumRel.Next
Do While Not pRelClass Is Nothing
Set pDSet = pRelClass
If pDSet.Name = strRelateName Then 'hit the correct relate
FoundRelClass = True
Exit Do
End If
Set pRelClass = pEnumRel.Next
Loop
End If

'if selected relationship class was not found in the map,
'then look for it in a geodatabase
If Not FoundRelClass = True Then
Dim pEnumRelClass As esriGeoDatabase.IEnumRelationshipClass
Dim pObjectClass As esriGeoDatabase.IObjectClass
Set pObjectClass = pFromDispTab.DisplayTable
Set pEnumRelClass = pObjectClass.RelationshipClasses(esriRelRoleAny)
Set pRelClass = pEnumRelClass.Next
Do While Not pRelClass Is Nothing
Set pDSet = pRelClass
If pDSet.Name = strRelateName Then 'hit the correct relate
FoundRelClass = True
Exit Do
End If
Set pRelClass = pEnumRelClass.Next
Loop
End If

'if the relationship was still not found, then give up
If Not FoundRelClass = True Then
MsgBox "The relationship class was not found"
Set GetRelSelection = Nothing
Exit Sub
End If

' Get the set of related rows and build an OID list
Dim pOutSet As esriSystem.ISet
Dim pOIDList() As Long
Dim intOIDIndex As Integer
Dim intCount As Integer
Set pOutSet = pRelClass.GetObjectsRelatedToObjectSet(pInSet)
If pOutSet.count <> 0 Then
Set pRow = pOutSet.Next
ReDim pOIDList(pOutSet.count - 1)
intOIDIndex = pRow.Fields.FindField(pToDispTab.DisplayTable.OIDFieldName)
intCount = 0
Do While Not pRow Is Nothing
pOIDList(intCount) = pRow.Value(intOIDIndex)
Set pRow = pOutSet.Next
intCount = intCount + 1
Loop
End If

' make a selectionset and add the OID's from the OID list
Dim pOutSelSet As esriGeoDatabase.ISelectionSet
Dim lngOID As Long
Set pOutSelSet = pToDispTab.DisplayTable.Select(Nothing, esriSelectionTypeHybrid, _
esriSelectionOptionEmpty, Nothing)
If pOutSet.count <> 0 Then
For lngOID = 0 To pOutSet.count - 1
pOutSelSet.Add (pOIDList(lngOID))
Next
End If

Set GetRelSelection = pOutSelSet

End Sub

Sub FindRelatedRecordWorkOrder()


'hook the current map
Dim pDoc As IMxDocument
Dim pMap As IStandaloneTableCollection
Dim pMapView As IMap
Dim pStdAloneTbl As IStandaloneTable
Dim pTableSel As ITableSelection
Dim pQueryFilt As IQueryFilter
Dim pSelSet As ISelectionSet

Set pDoc = Application.Document
Set pMap = pDoc.FocusMap
Set pMapView = pDoc.FocusMap

For i = 0 To pMap.StandaloneTableCount - 1
Set pStdAloneTbl = pMap.StandaloneTable(i)
If pStdAloneTbl.Name = "WATER.WATTACHMENT" Then Exit For
Next i
Set pTableSel = pStdAloneTbl
Dim ptable As ITable
Set ptable = pStdAloneTbl
Dim pdisTable As IDisplayTable
Set pdisTable = ptable


Dim pEnumRelClass As IEnumRelationshipClass
Dim pRelClass As IRelationshipClass

Dim pObjectClass As IObjectClass
Dim pDSet As IDataset
Set pObjectClass = pdisTable.DisplayTable
Set pEnumRelClass = pObjectClass.RelationshipClasses(esriRelRoleAny)
Set pRelClass = pEnumRelClass.Next
Do While Not pRelClass Is Nothing
Set pDSet = pRelClass
If pDSet.Name = "WATER.WGravityMain_Has_WAttachment" Then Exit Do
Debug.Print pDSet.Name
Set pRelClass = pEnumRelClass.Next
Loop





Set pQueryFilt = New QueryFilter
pQueryFilt.WhereClause = "FilePath like '%WorkOrders%'"

' Perform the selection
pTableSel.SelectRows pQueryFilt, esriSelectionResultNew, False

' Report how many rows were selected
Set pSelSet = pTableSel.SelectionSet
Dim pEnumID As IEnumIDs
Set pEnumID = pSelSet.IDs
'Debug.Print pSelSet.count & " rows selected in " & pStdAloneTbl.Name
Dim pRow As IRow
Dim pDesRow As IRow
Dim pOutSet As ISet



pEnumID.Reset
Dim id As Long
id = pEnumID.Next
Dim count As Long
count = 1
Dim output As String
Open "C:\GravityWorkOrders.txt" For Output As #1

Do While Not id = -1

Set pRow = ptable.GetRow(id)
'Debug.Print pRow.Value(1)
output = count & "," & pRow.Value(1)
Set pOutSet = pRelClass.GetObjectsRelatedToObject(pRow)
Dim pfields As IFields

If pOutSet.count <> 0 Then
Set pDesRow = pOutSet.Next
Set pfields = pDesRow.Fields
output = output & "," & pDesRow.Value(pfields.FindField("DistrictMap"))
output = output & "," & pDesRow.Value(pfields.FindField("InstallDate"))
output = output & "," & pDesRow.Value(pfields.FindField("WorkOrderID"))
output = output & "," & pDesRow.Value(pfields.FindField("PWP_FILENUMBER"))
' output = output & "," & pDesRow.Value(pfields.FindField("LiningWorkOrderID"))
output = output & "," & pDesRow.Value(pfields.FindField("Loc_OFFSET")) '& " " & pDesRow.Value(pfields.FindField("LOC_STREETNAME")) & " " & pDesRow.Value(pfields.FindField("LOC_STREETTYPE"))
Debug.Print output
Write #1, output

count = count + 1

' Debug.Print pRow.Value(1) & "," & pDesRow.Value(pfields.FindField("DistrictMap")) & "," & pDesRow.Value(4) & "," & pDesRow.Value(7) & "," & pDesRow.Value(13) & "," & pDesRow.Value(26) & "," & pDesRow.Value(30) & " " & pDesRow.Value(31) & "," & pDesRow.Value(40)

End If

id = pEnumID.Next
Loop

Debug.Print "completed"
Close #1

End Sub

export import symbology

Attribute VB_Name = "ExportSymbols"
Public Sub ExportSyms()
'This routine was written for testing in VBA
   Dim mxd As IMxDocument
  
   'If you put this code in the "ThisDocument" object in VBA then
   'change the following variable assignment to "Me". If you keep
   'this code in a separate module, then leave the following line
   'as is.
   Set mxd = ThisDocument 'Me
   Call SaveRenderer(mxd.SelectedLayer, "C:\roads.agl")
End Sub
Public Sub RestoreSyms()
'This routine was written for testing in VBA
   Dim mxd As IMxDocument
  
   'If you put this code in the "ThisDocument" object in VBA then
   'change the following variable assignment to "Me". If you keep
   'this code in a separate module, then leave the following line
   'as is.
   Set mxd = Me
   Call LoadRenderer(mxd.SelectedLayer, mxd, "C:\roads.agl")
End Sub
Private Sub SaveRenderer(oGeoLayer As IGeoFeatureLayer, sFileName As String)
'This routine should work in either VBA or VB6
On Error GoTo eh
   Dim oMemBlob As IMemoryBlobStream
   Dim oObjectStream As IObjectStream
   Dim oPropSet As IPropertySet
   Dim oPersistStream As IPersistStream
  
'Set up the objects to persist the symbology
   Set oMemBlob = New MemoryBlobStream
   Set oObjectStream = New ObjectStream
   Set oObjectStream.Stream = oMemBlob
   Set oPropSet = New PropertySet
   Set oPersistStream = oPropSet
  
'Persist the layer's symbology
   oPropSet.SetProperty "Symbology", oGeoLayer.Renderer 'persist the renderer to the PropertySet
   oPersistStream.Save oObjectStream, False 'Save the persist stream to the blob via the object stream
   oMemBlob.SaveToFile sFileName 'write the blob to a file
   Exit Sub
eh:
   MsgBox "There was an error exporting the symbology: " & Err.Number & "::" & Err.Description, vbCritical, "Export Error!"
End Sub

Private Sub LoadRenderer(oGeoLayer As IGeoFeatureLayer, oMxd As IMxDocument, sFileName As String)
'This routine should work in either VBA or VB6
On Error GoTo eh
   Dim oMemBlob As IMemoryBlobStream
   Dim oObjectStream As IObjectStream
   Dim oPropSet As IPropertySet
   Dim oPersistStream As IPersistStream

'Set up the objects to depersist the symbology
   Set oMemBlob = New MemoryBlobStream
   Set oObjectStream = New ObjectStream
   Set oObjectStream.Stream = oMemBlob
   Set oPropSet = New PropertySet
   Set oPersistStream = oPropSet
  
'Get the symbology from the file
   oMemBlob.LoadFromFile sFileName 'read the file into the blob
   oPersistStream.Load oObjectStream 'load the persist stream
   Set oGeoLayer.Renderer = oPropSet.GetProperty("Symbology") 'depersist the renderer and assign it
   oMxd.ActiveView.Refresh 'refresh the map
   oMxd.CurrentContentsView.Refresh oMxd.SelectedItem 'refresh the TOC
   Exit Sub
eh:
   MsgBox "There was an error restoring the symbology: " & Err.Number & "::" & Err.Description, vbCritical, "Import Error!"

End Sub

copy render symbology

Sub CopyRenderer()
Dim pMxDoc As IMxDocument
Dim pMap As IMap
Set pMxDoc = Application.Document
Set pMap = pMxDoc.FocusMap

Dim pLayer1 As IGeoFeatureLayer
Dim pLayer2 As IGeoFeatureLayer

Set pLayer1 = pMap.layer(0)
Set pLayer2 = pMap.layer(1)

Dim pObjectCopy As IObjectCopy
Set pObjectCopy = New ObjectCopy

Set pLayer2.Renderer = pObjectCopy.Copy(pLayer1.Renderer)

Dim hx As IRendererPropertyPage
Set hx = New CombiUniqueValuePropertyPage
  pLayer2.RendererPropertyPageClassID = hx.ClassID

pMxDoc.ActiveView.ContentsChanged
pMxDoc.UpdateContents
pMxDoc.ActiveView.Refresh

End Sub

progrmatically modify field type ms access

' Make sure you have a reference to the library:
' Microsoft ADO Ext. 2.x for DDL and Security
Option Compare Database
Function ModifyTables()
Dim cat As New ADOX.Catalog 'Root object of ADOX.
Dim tbl As ADOX.Table 'Each Table in Tables.
Dim col As ADOX.Column 'Each Column in the Table.
Dim strSQL As String
'Point the catalog to the current project's connection.
Set cat.ActiveConnection = CurrentProject.Connection

'Loop through the tables.
For Each tbl In cat.Tables
If InStr(tbl.Name, "Doc") Then
'Debug.Print tbl.Name, tbl.Type
'Loop through the columns of the table.
For Each col In tbl.Columns
'Debug.Print , col.Name, col.Type,
strSQL = "Alter table [" & tbl.Name & "] alter column [" & col.Name & "] Text(255)"
Debug.Print strSQL
DBEngine(0)(0).Execute strSQL, dbFailOnError

Next
Debug.Print "--------------------------------"
End If
Next

'Clean up
Set col = Nothing
Set tbl = Nothing
Set cat = Nothing
End Function


VBS version

Dim strSQL 'As String
Dim Conn 'As ADODB.Connection
Dim cat 'As ADOX.Catalog 'Root object of ADOX.
Dim tbl 'As ADOX.Table 'Each Table in Tables.
Dim col 'As ADOX.Column 'Each Column in the Table.


Set Conn = CreateObject("ADODB.Connection")
Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=maplibrary.mdb"

'Create catalog object
Set Cat = CreateObject("ADOX.Catalog")

Set Cat.ActiveConnection = Conn

'Loop through the tables.
For Each tbl In cat.Tables
If InStr(tbl.Name, "Doc") Then
'Debug.Print tbl.Name, tbl.Type
'Loop through the columns of the table.
For Each col In tbl.Columns
'Debug.Print , col.Name, col.Type,
strSQL = "Alter table [" & tbl.Name & "] alter column [" & col.Name & "] Text(255)"
' Debug.Print strSQL
Conn.Execute strSQL, dbFailOnError

Next
'Debug.Print "--------------------------------"
End If

Next

WScript.Echo "Completed!"