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
Thursday, December 11, 2008
Wednesday, December 10, 2008
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
Monday, December 8, 2008
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!"
' 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!"
Thursday, October 2, 2008
clean up Windows cache files
on error resume next
dim oUIResManager
dim oCache
dim oCacheElement
dim oCacheElements
set oUIResManager = createobject("UIResource.UIResourceMgr")
if oUIResManager is nothing then
' wscript.echo "Couldn't create Resource Manager - quitting"
wscript.quit
end if
set oCache=oUIResManager.GetCacheInfo()
if oCache is nothing then
set oUIResManager=nothing
' wscript.echo "Couldn't get cache info - quitting"
wscript.quit
end if
set oCacheElements=oCache.GetCacheElements
wscript.echo "There are " & oCacheElements.Count & " cache elements"
'wscript.echo
' ***** Begin CLEAR CACHE *****
for each oCacheElement in oCacheElements
oCache.DeleteCacheElement(oCacheElement.CacheElementID)
next
' ***** End CLEAR CACHE *****
' ***** Clean up *****
set oCacheElements=nothing
set oUIResManager=nothing
set oCache=nothing
dim oUIResManager
dim oCache
dim oCacheElement
dim oCacheElements
set oUIResManager = createobject("UIResource.UIResourceMgr")
if oUIResManager is nothing then
' wscript.echo "Couldn't create Resource Manager - quitting"
wscript.quit
end if
set oCache=oUIResManager.GetCacheInfo()
if oCache is nothing then
set oUIResManager=nothing
' wscript.echo "Couldn't get cache info - quitting"
wscript.quit
end if
set oCacheElements=oCache.GetCacheElements
wscript.echo "There are " & oCacheElements.Count & " cache elements"
'wscript.echo
' ***** Begin CLEAR CACHE *****
for each oCacheElement in oCacheElements
oCache.DeleteCacheElement(oCacheElement.CacheElementID)
next
' ***** End CLEAR CACHE *****
' ***** Clean up *****
set oCacheElements=nothing
set oUIResManager=nothing
set oCache=nothing
Friday, August 22, 2008
Friday, August 15, 2008
oracle update fields using joining other table
The short URL for this FAQ is http://tinyurl.com/2vphxg
Here are four examples of updating multiple columns with a single statement. The DML options are UPDATE, 10gr2 MERGE, 9i MERGE. Another option, if you can join on a database-enforced unique constraint (for example, a primary key), is "updating a join".
Set up the example: create table tgt ( id number /*primary key*/, x number, y number )
/
insert into tgt ( id, x, y )
select level, level, level from dual connect by level < 4
/
create table src ( id number /*primary key*/, x number, y number )
/
insert into src ( id, x, y )
select level+1, level*5, level*5 from dual connect by level < 3
/
commit
/
select * from src;
ID X Y
---------- ---------- ----------
2 5 5
3 10 10
select * from tgt;
ID X Y
---------- ---------- ----------
1 1 1
2 2 2
3 3 3
The first example is an UPDATE statment: UPDATE tgt
SET ( tgt.x, tgt.y ) =
( SELECT src.x, src.y
FROM src
WHERE src.id = tgt.id
)
WHERE EXISTS
( SELECT src.x, src.y
FROM src
WHERE src.id = tgt.id
)
/
2 rows updated.
select * from tgt;
ID X Y
---------- ---------- ----------
1 1 1
2 5 5
3 10 10
The second example uses a 10gR2 MERGE statement: MERGE into tgt /* Oracle 10gR2 doesn't require WHEN NOT MATCHED */
USING src
ON ( src.id = tgt.id )
WHEN MATCHED THEN UPDATE SET
tgt.x = src.x
, tgt.y = src.y
/
2 rows updated.
select * from tgt;
ID X Y
---------- ---------- ----------
1 1 1
2 5 5
3 10 10
The third example using a 9i MERGE, which requires (even if it doesn't use) a WHEN NOT MATCHED clause: MERGE into tgt /* Oracle 9i requires WHEN NOT MATCHED */
USING
( SELECT src.x, src.y, src.id
FROM src INNER JOIN tgt
ON ( src.id = tgt.id )
) src
ON ( src.id = tgt.id )
WHEN MATCHED THEN UPDATE SET
tgt.x = src.x
, tgt.y = src.y
WHEN NOT MATCHED -- NEVER INVOKED
THEN INSERT -- NEVER INVOKED
( tgt.id ) -- NEVER INVOKED
VALUES -- NEVER INVOKED
( src.id ) -- NEVER INVOKED
/
2 rows updated.
select * from tgt;
ID X Y
---------- ---------- ----------
1 1 1
2 5 5
3 10 10
The previous examples succeeded despite a lack of database-enforced uniqueness constraints. SRC.ID had to be unique in practice, otherwise Oracle will throw the error: ORA-30926: unable to get a stable set of rows in the source tables
If there are multiple subquery results per updated row, the DBMS doesn't know which source row to use for the update. However, uniqueness didn't have to be declared in DDL to the DBMS.
The fourth example, "updating a join", requires database-enforced uniqueness on SRC.ID. In other words, SRC must be key preserved not just in practice, but enforced design. Updating a join doesn't check for a "stable set of rows" on-the-fly, it demands a "stable set of rows" be database-enforced before hand.
Here the UPDATE is without a unique constraint (like the previous three examples). It fails: UPDATE
( SELECT src.x src_x, src.y src_y
, tgt.x tgt_x, tgt.y tgt_y
FROM src INNER JOIN tgt
ON ( src.id = tgt.id )
)
SET tgt_x = src_x
, tgt_y = src_y
/
SET tgt_x = src_x
*
ERROR at line 7:
ORA-01779: cannot modify a column which maps to a non key-preserved table
So "key preserve" the join by putting a primary key on src.ID. alter table src add primary key (id)
/
Table altered.
Then updating a join will succeed: UPDATE
( SELECT src.x src_x, src.y src_y
, tgt.x tgt_x, tgt.y tgt_y
FROM src INNER JOIN tgt
ON ( src.id = tgt.id )
)
SET tgt_x = src_x
, tgt_y = src_y
/
2 rows updated.
select * from tgt;
ID X Y
---------- ---------- ----------
1 1 1
2 5 5
3 10 10
Note that the use of column aliases. This ensured unique column
Here are four examples of updating multiple columns with a single statement. The DML options are UPDATE, 10gr2 MERGE, 9i MERGE. Another option, if you can join on a database-enforced unique constraint (for example, a primary key), is "updating a join".
Set up the example: create table tgt ( id number /*primary key*/, x number, y number )
/
insert into tgt ( id, x, y )
select level, level, level from dual connect by level < 4
/
create table src ( id number /*primary key*/, x number, y number )
/
insert into src ( id, x, y )
select level+1, level*5, level*5 from dual connect by level < 3
/
commit
/
select * from src;
ID X Y
---------- ---------- ----------
2 5 5
3 10 10
select * from tgt;
ID X Y
---------- ---------- ----------
1 1 1
2 2 2
3 3 3
The first example is an UPDATE statment: UPDATE tgt
SET ( tgt.x, tgt.y ) =
( SELECT src.x, src.y
FROM src
WHERE src.id = tgt.id
)
WHERE EXISTS
( SELECT src.x, src.y
FROM src
WHERE src.id = tgt.id
)
/
2 rows updated.
select * from tgt;
ID X Y
---------- ---------- ----------
1 1 1
2 5 5
3 10 10
The second example uses a 10gR2 MERGE statement: MERGE into tgt /* Oracle 10gR2 doesn't require WHEN NOT MATCHED */
USING src
ON ( src.id = tgt.id )
WHEN MATCHED THEN UPDATE SET
tgt.x = src.x
, tgt.y = src.y
/
2 rows updated.
select * from tgt;
ID X Y
---------- ---------- ----------
1 1 1
2 5 5
3 10 10
The third example using a 9i MERGE, which requires (even if it doesn't use) a WHEN NOT MATCHED clause: MERGE into tgt /* Oracle 9i requires WHEN NOT MATCHED */
USING
( SELECT src.x, src.y, src.id
FROM src INNER JOIN tgt
ON ( src.id = tgt.id )
) src
ON ( src.id = tgt.id )
WHEN MATCHED THEN UPDATE SET
tgt.x = src.x
, tgt.y = src.y
WHEN NOT MATCHED -- NEVER INVOKED
THEN INSERT -- NEVER INVOKED
( tgt.id ) -- NEVER INVOKED
VALUES -- NEVER INVOKED
( src.id ) -- NEVER INVOKED
/
2 rows updated.
select * from tgt;
ID X Y
---------- ---------- ----------
1 1 1
2 5 5
3 10 10
The previous examples succeeded despite a lack of database-enforced uniqueness constraints. SRC.ID had to be unique in practice, otherwise Oracle will throw the error: ORA-30926: unable to get a stable set of rows in the source tables
If there are multiple subquery results per updated row, the DBMS doesn't know which source row to use for the update. However, uniqueness didn't have to be declared in DDL to the DBMS.
The fourth example, "updating a join", requires database-enforced uniqueness on SRC.ID. In other words, SRC must be key preserved not just in practice, but enforced design. Updating a join doesn't check for a "stable set of rows" on-the-fly, it demands a "stable set of rows" be database-enforced before hand.
Here the UPDATE is without a unique constraint (like the previous three examples). It fails: UPDATE
( SELECT src.x src_x, src.y src_y
, tgt.x tgt_x, tgt.y tgt_y
FROM src INNER JOIN tgt
ON ( src.id = tgt.id )
)
SET tgt_x = src_x
, tgt_y = src_y
/
SET tgt_x = src_x
*
ERROR at line 7:
ORA-01779: cannot modify a column which maps to a non key-preserved table
So "key preserve" the join by putting a primary key on src.ID. alter table src add primary key (id)
/
Table altered.
Then updating a join will succeed: UPDATE
( SELECT src.x src_x, src.y src_y
, tgt.x tgt_x, tgt.y tgt_y
FROM src INNER JOIN tgt
ON ( src.id = tgt.id )
)
SET tgt_x = src_x
, tgt_y = src_y
/
2 rows updated.
select * from tgt;
ID X Y
---------- ---------- ----------
1 1 1
2 5 5
3 10 10
Note that the use of column aliases. This ensured unique column
Thursday, August 7, 2008
VBA geocoding script
'this code can be expanded to use google geocode
'this code can be expanded to provide web service
Const LATITUDECOL = 1 ' column to put longitude into
Const LONGITUDECOL = 2 ' column to put latitude into
Const PRECISIONCOL = 3
Const STREETCOL = 4 ' column to find street
Const CITYCOL = 5 ' column to find city
Const STATECOL = 6 ' column to find state
Const ZIPCOL = 7 ' column to find zipcode data
Const stdAddr = 8
Const FIRSTDATAROW = 2 ' rows above this row don't contain address data
' holds cache of strings submitted to geocoder during this session along with results
' to ensure that duplicate strings aren't submitted
' TODO: make this cache persist across sessions
Dim geocodeResults As New Collection
' GEOCODING is done using the following layers
'
'geocodeSelectedRows
'(for each row call geocodeRow)
'
' geocodeRow(r)
' (check that row is geocodable, pass to geocode, parse results)
'
' geocode(street,city,state,zip)
' (clean all variables, pass url to geocoderAddressLookup,
' if no result then try different permuatations of address)
'
' geocoderAddressLookup
' (query geocoder.us, return result, marshal results)
'
' submit selected rows to the geocoder
Sub geocodeSelectedRows()
Dim r
If [GeocoderToUse] = "Yahoo" Then
If [yahooid] <> "" Then
For Each r In Selection.rows()
If r.Row() >= FIRSTDATAROW Then geocodeRow (r.Row())
Next r
Application.StatusBar = False
Else:
MsgBox "Please enter a Yahoo Id for geocoding"
End If
Else:
If (trim(CStr([geocoderPassword])) <> "" And trim(CStr([geocoderPassword])) <> "") Then
For Each r In Selection.rows()
If r.Row() >= FIRSTDATAROW Then geocodeRow (r.Row())
Next r
Application.StatusBar = False
Else
MsgBox "Please enter a username and password at geocoder.us on the Settings and Instructions page."
End If
End If
End Sub
Sub geocodeAllRows()
Dim r As Integer
If [GeocoderToUse] = "Yahoo" Then
If [yahooid] <> "" Then
For r = FIRSTDATAROW To LastDataRow()
geocodeRow (r)
Next r
Application.StatusBar = False
Else:
MsgBox "Please enter a Yahoo Id for geocoding"
End If
Else:
If (trim(CStr([geocoderPassword])) <> "" And trim(CStr([geocoderPassword])) <> "") Then
For r = FIRSTDATAROW To LastDataRow()
geocodeRow (r)
Next r
Application.StatusBar = False
Else
MsgBox "Please enter a username and password at geocoder.us on the Settings and Instructions page."
End If
End If
End Sub
' geocode a single row of data
Sub geocodeRow(r As Integer)
Dim addr As String
Dim resultstr As String
Dim resultarray
Application.StatusBar = "Geocoding row: " & r
' requires street address and a blank latitude to continue
' can't geocode if no address data
' nonblank latitude means we've already geocoded this row
If Cells(r, STREETCOL) & Cells(r, CITYCOL) & Cells(r, STATECOL) & Cells(r, ZIPCOL) <> "" And Cells(r, LATITUDECOL) = "" Then
' pass the street, city, state, and zip to the function geocode
' geocode returns a string containing the results in comma delimited format
' this is crude, but works
' CStr casts (converts) a value to a string
resultstr = geocode(CStr(Cells(r, STREETCOL)), CStr(Cells(r, CITYCOL)), CStr(Cells(r, STATECOL)), CStr(Cells(r, ZIPCOL)))
' parse the results
resultarray = Split(resultstr, ",")
If resultarray(0) = "" Then resultarray(0) = "not found"
If resultarray(1) = "" Then resultarray(1) = "not found"
If resultarray(2) = "" And resultarray(0) = "not found" Then resultarray(2) = "not found"
'If resultarray(2) = "" Then resultarray(2) = "address"
' store the results
Cells(r, LATITUDECOL) = resultarray(0)
Cells(r, LONGITUDECOL) = resultarray(1)
Cells(r, PRECISIONCOL) = resultarray(2)
Cells(r, stdAddr) = resultarray(3)
End If
End Sub
' normalization function for street addresses
' removes apartment numbers, suite numbers that cause problems for geocoder.us
Function geocodeCleanStreet(street As String) As String
street = LCase(street)
street = trimstr(street, "#")
street = trimstr(street, " apartment ")
street = trimstr(street, " apt ")
street = trimstr(street, " apt ")
street = trimstr(street, " lot ")
street = trimstr(street, " unit ")
street = trimstr(street, " suite ")
street = trimstr(street, " ste ")
street = trimstr(street, " trlr ")
geocodeCleanStreet = street
End Function
' removed invalid characters from address
Function geocodeNormalizeAddress(addr As String) As String
' normalize address and prepare to pass to geocoder.us
addr = LCase(addr)
addr = Replace(addr, "-", " ")
addr = Replace(addr, ".", " ")
addr = Replace(addr, " ", " ")
addr = Replace(addr, " ", " ")
addr = Replace(addr, " ", " ")
addr = Replace(addr, " ", "+")
geocodeNormalizeAddress = addr
End Function
Function geocodeCleanZip(zip As String) As String
' normalize zipcode to 5 digits or 9 digits
zip = RegExValidate(zip, "[0-9]")
If Len(zip) = 4 Or Len(zip) = 5 Then
geocodeCleanZip = Application.WorksheetFunction.Text(zip, "00000")
ElseIf Len(zip) = 8 Or Len(zip) = 9 Then
zip4 = Right(zip, 4)
zip5 = Left(zip, Len(zip) - 4)
geocodeCleanZip = Application.WorksheetFunction.Text(zip5, "00000") & "-" & Application.WorksheetFunction.Text(zip4, "0000")
Else:
geocodeCleanZip = ""
End If
End Function
' remove everything following the start of the string trim
Function trimstr(basestr As String, trim As String) As String
If InStr(basestr, trim) > 0 Then
trimstr = Left(basestr, InStr(basestr, trim) - 1)
Else
trimstr = basestr
End If
End Function
' remove everything following the end of the string trim
Function trimstrafter(basestr As String, trim As String) As String
If InStr(basestr, trim) > 0 Then
trimstrafter = Left(basestr, InStr(basestr, trim) + Len(trim) - 1)
Else
trimstrafter = basestr
End If
End Function
Function geocode(street As String, city As String, state As String, zip As String) As String
' clean up the address and call geocodeAddressLookup
Dim result As String
Dim addr As String
street = geocodeCleanStreet(street)
city = RegExValidate(LCase(city), "[a-z ]")
state = RegExValidate(UCase(state), "[A-Z ]")
zip = geocodeCleanZip(zip)
' if the street address is a PO box then we won't be able to geocode
' if zip not blank then try looking up street and zip
' if this fails, try looking up street, city, state
' if this fails, try fixing up the street
' if street has changed after fixup, try looking up street and zip
' if this fails, try looking up street, city, state
If [GeocoderToUse] = "Yahoo" Then
result = yahooAddressLookup(street, city, state, zip)
Else:
If Left(street, 5) = "xxxxx" Or _
Left(street, 6) = "po box" Or _
Left(street, 7) = "post of" Or _
Left(street, 7) = "p o box" Or _
Left(street, 7) = "city of" Then
result = ",,"
Else:
If zip <> "" Then
result = geocoderAddressLookup(geocodeNormalizeAddress(street & ", " & zip))
Else
result = ",,"
End If
If result = ",," Then
If city <> "" And state <> "" Then
result = geocoderAddressLookup(geocodeNormalizeAddress(street & ", " & zip))
Else
result = ",,"
End If
If result = ",," And street <> "" Then
oldstreet = street
' try to clean up street
street = Replace(street, " th ", "th ")
street = Replace(street, " rd ", "rd ")
street = trimstrafter(street, "st")
street = trimstrafter(street, "dr")
street = trimstrafter(street, "rd")
street = trimstrafter(street, "road")
street = trimstrafter(street, "dr")
street = trimstrafter(street, "lane")
street = trimstrafter(street, "ln")
street = trimstrafter(street, "ave")
street = trimstrafter(street, "blvd")
street = trimstrafter(street, "boulevard")
street = trimstrafter(street, "pl")
If street <> oldstreet Then
If zip <> "" Then
result = geocoderAddressLookup(geocodeNormalizeAddress(street & ", " & zip))
Else
result = ",,"
End If
If result = ",," Then
result = geocoderAddressLookup(geocodeNormalizeAddress(street & ", " & zip))
Else
result = ",,"
End If
End If
End If
End If
End If
End If
geocode = result
End Function
Function yahooAddressLookup(street As String, city As String, state As String, zip As String) As String
' perform RESTian lookup on Yahoo
Dim marshalledResult As String
Dim yahoo As String
Dim response As String
Dim result As String
' marshal the results of this very time consuming function
' see if we've already looked up this address
' turn error handling off
On Error Resume Next
' lookup the result in the collection
' an error will be raised if the value is not found
marshalledResult = geocodeResults(addr)
If marshalledResult <> "" Then
' if a value is found then return the result
geocodeAddressLookup = marshalledResult
Exit Function
End If
' turn error handling back on
On Error GoTo 0
Application.StatusBar = "Looking for " & street & ", " & city & ", " & state & " " & zip
yahoo = trim(CStr([yahooid]))
street = trim(street)
city = trim(city)
state = trim(state)
zip = trim(zip)
URL = "http://api.local.yahoo.com/MapsService/V1/geocode?appid=" & yahoo & "&street=" & street & "&city=" & city & "&state=" & state & "&zip=" & zip
'Create Http object
If IsEmpty(http) Then Set http = CreateObject("WinHttp.WinHttpRequest.5.1")
'Send request To URL
http.Open "GET", URL
http.send
'Get response data As a string
response = http.responseText
' capture the latitude by regex matching the values in the tags and
lat = RegExMatch(response, "([\.\-0-9]+) ")
lng = RegExMatch(response, "([\.\-0-9]+) ")
precision = RegExMatch(response, "precision=""([a-z0-9+]+)""")
addr = RegExMatch(response, "[0-9+]+ (.*)")
' return a comma delimited string
' if values not found, this will return ","
yahooAddressLookup = lat & "," & lng & "," & precision & "," & addr
If [BeepOn] Then Beep
' store the result in the cache collection
'
' turn off error handling with "On Error Resume Next"
' an error will be raised if you try to store to an address already in the cache
' we can ignore this error
On Error Resume Next
' store the result
geocodeResults(addr) = lat & "," & lng
End Function
Function geocoderAddressLookup(addr As String) As String
' perform RESTian lookup on geocoder.us
Dim marshalledResult As String
Dim usernm As String
Dim passwd As String
Dim response As String
Dim result As String
' marshal the results of this very time consuming function
' see if we've already looked up this address
' turn error handling off
On Error Resume Next
' lookup the result in the collection
' an error will be raised if the value is not found
marshalledResult = geocodeResults(addr)
If marshalledResult <> "" Then
' if a value is found then return the result
geocodeAddressLookup = marshalledResult
Exit Function
End If
' turn error handling back on
On Error GoTo 0
Application.StatusBar = "Looking for " & addr
usernm = trim(CStr([geocoderUsername]))
passwd = trim(CStr([geocoderPassword]))
URL = "http://geocoder.us/member/service/rest/geocode?address=" & addr
'Create Http object
If IsEmpty(http) Then Set http = CreateObject("WinHttp.WinHttpRequest.5.1")
'Send request To URL
http.Open "GET", URL
http.setcredentials usernm, passwd, 0
http.send
'Get response data As a string
response = http.responseText
' capture the latitude by regex matching the values in the tags and
lat = RegExMatch(response, "(.+) ")
lng = RegExMatch(response, "(.+) ")
' return a comma delimtied string
' if values not found, this will return ","
geocoderAddressLookup = lat & "," & lng & ","
Beep
' store the result in the cache collection
'
' turn off error handling with "On Error Resume Next"
' an error will be raised if you try to store to an address already in the cache
' we can ignore this error
On Error Resume Next
' store the result
geocodeResults(addr) = lat & "," & lng
End Function
' wraps string with a tag
Function tag(xmltag As String, val As String) As String
tag = "<" & xmltag & ">" & val & "" & vbCrLf
End Function
' basic distance function for latitude/longitude
Public Function latLongDistance(lat1 As Double, long1 As Double, lat2 As Double, long2 As Double) As Double
Dim x As Double
Dim y As Double
x = 69.1 * (lat2 - lat1)
y = 69.1 * (long2 - long1) * Cos(lat1 / 57.3)
latLongDistance = (x * x + y * y) ^ 0.5
End Function
Private Function max(a, b):
If a > b Then
max = a
Else
max = b
End If
End Function
' locate the last row containing address data
Function LastDataRow() As Integer
Dim r As Integer
activecelladdr = ActiveCell.Address
Range("d65536").End(xlUp).Select
r = ActiveCell.Row()
Range("e65536").End(xlUp).Select
r = max(r, ActiveCell.Row())
Range("f65536").End(xlUp).Select
r = max(r, ActiveCell.Row())
Range("g65536").End(xlUp).Select
r = max(r, ActiveCell.Row())
Range(activecelladdr).Select
LastDataRow = r
End Function
Sub MacrosWorking()
MsgBox "Macros are enabled."
End Sub
'this code can be expanded to provide web service
Const LATITUDECOL = 1 ' column to put longitude into
Const LONGITUDECOL = 2 ' column to put latitude into
Const PRECISIONCOL = 3
Const STREETCOL = 4 ' column to find street
Const CITYCOL = 5 ' column to find city
Const STATECOL = 6 ' column to find state
Const ZIPCOL = 7 ' column to find zipcode data
Const stdAddr = 8
Const FIRSTDATAROW = 2 ' rows above this row don't contain address data
' holds cache of strings submitted to geocoder during this session along with results
' to ensure that duplicate strings aren't submitted
' TODO: make this cache persist across sessions
Dim geocodeResults As New Collection
' GEOCODING is done using the following layers
'
'geocodeSelectedRows
'(for each row call geocodeRow)
'
' geocodeRow(r)
' (check that row is geocodable, pass to geocode, parse results)
'
' geocode(street,city,state,zip)
' (clean all variables, pass url to geocoderAddressLookup,
' if no result then try different permuatations of address)
'
' geocoderAddressLookup
' (query geocoder.us, return result, marshal results)
'
' submit selected rows to the geocoder
Sub geocodeSelectedRows()
Dim r
If [GeocoderToUse] = "Yahoo" Then
If [yahooid] <> "" Then
For Each r In Selection.rows()
If r.Row() >= FIRSTDATAROW Then geocodeRow (r.Row())
Next r
Application.StatusBar = False
Else:
MsgBox "Please enter a Yahoo Id for geocoding"
End If
Else:
If (trim(CStr([geocoderPassword])) <> "" And trim(CStr([geocoderPassword])) <> "") Then
For Each r In Selection.rows()
If r.Row() >= FIRSTDATAROW Then geocodeRow (r.Row())
Next r
Application.StatusBar = False
Else
MsgBox "Please enter a username and password at geocoder.us on the Settings and Instructions page."
End If
End If
End Sub
Sub geocodeAllRows()
Dim r As Integer
If [GeocoderToUse] = "Yahoo" Then
If [yahooid] <> "" Then
For r = FIRSTDATAROW To LastDataRow()
geocodeRow (r)
Next r
Application.StatusBar = False
Else:
MsgBox "Please enter a Yahoo Id for geocoding"
End If
Else:
If (trim(CStr([geocoderPassword])) <> "" And trim(CStr([geocoderPassword])) <> "") Then
For r = FIRSTDATAROW To LastDataRow()
geocodeRow (r)
Next r
Application.StatusBar = False
Else
MsgBox "Please enter a username and password at geocoder.us on the Settings and Instructions page."
End If
End If
End Sub
' geocode a single row of data
Sub geocodeRow(r As Integer)
Dim addr As String
Dim resultstr As String
Dim resultarray
Application.StatusBar = "Geocoding row: " & r
' requires street address and a blank latitude to continue
' can't geocode if no address data
' nonblank latitude means we've already geocoded this row
If Cells(r, STREETCOL) & Cells(r, CITYCOL) & Cells(r, STATECOL) & Cells(r, ZIPCOL) <> "" And Cells(r, LATITUDECOL) = "" Then
' pass the street, city, state, and zip to the function geocode
' geocode returns a string containing the results in comma delimited format
' this is crude, but works
' CStr casts (converts) a value to a string
resultstr = geocode(CStr(Cells(r, STREETCOL)), CStr(Cells(r, CITYCOL)), CStr(Cells(r, STATECOL)), CStr(Cells(r, ZIPCOL)))
' parse the results
resultarray = Split(resultstr, ",")
If resultarray(0) = "" Then resultarray(0) = "not found"
If resultarray(1) = "" Then resultarray(1) = "not found"
If resultarray(2) = "" And resultarray(0) = "not found" Then resultarray(2) = "not found"
'If resultarray(2) = "" Then resultarray(2) = "address"
' store the results
Cells(r, LATITUDECOL) = resultarray(0)
Cells(r, LONGITUDECOL) = resultarray(1)
Cells(r, PRECISIONCOL) = resultarray(2)
Cells(r, stdAddr) = resultarray(3)
End If
End Sub
' normalization function for street addresses
' removes apartment numbers, suite numbers that cause problems for geocoder.us
Function geocodeCleanStreet(street As String) As String
street = LCase(street)
street = trimstr(street, "#")
street = trimstr(street, " apartment ")
street = trimstr(street, " apt ")
street = trimstr(street, " apt ")
street = trimstr(street, " lot ")
street = trimstr(street, " unit ")
street = trimstr(street, " suite ")
street = trimstr(street, " ste ")
street = trimstr(street, " trlr ")
geocodeCleanStreet = street
End Function
' removed invalid characters from address
Function geocodeNormalizeAddress(addr As String) As String
' normalize address and prepare to pass to geocoder.us
addr = LCase(addr)
addr = Replace(addr, "-", " ")
addr = Replace(addr, ".", " ")
addr = Replace(addr, " ", " ")
addr = Replace(addr, " ", " ")
addr = Replace(addr, " ", " ")
addr = Replace(addr, " ", "+")
geocodeNormalizeAddress = addr
End Function
Function geocodeCleanZip(zip As String) As String
' normalize zipcode to 5 digits or 9 digits
zip = RegExValidate(zip, "[0-9]")
If Len(zip) = 4 Or Len(zip) = 5 Then
geocodeCleanZip = Application.WorksheetFunction.Text(zip, "00000")
ElseIf Len(zip) = 8 Or Len(zip) = 9 Then
zip4 = Right(zip, 4)
zip5 = Left(zip, Len(zip) - 4)
geocodeCleanZip = Application.WorksheetFunction.Text(zip5, "00000") & "-" & Application.WorksheetFunction.Text(zip4, "0000")
Else:
geocodeCleanZip = ""
End If
End Function
' remove everything following the start of the string trim
Function trimstr(basestr As String, trim As String) As String
If InStr(basestr, trim) > 0 Then
trimstr = Left(basestr, InStr(basestr, trim) - 1)
Else
trimstr = basestr
End If
End Function
' remove everything following the end of the string trim
Function trimstrafter(basestr As String, trim As String) As String
If InStr(basestr, trim) > 0 Then
trimstrafter = Left(basestr, InStr(basestr, trim) + Len(trim) - 1)
Else
trimstrafter = basestr
End If
End Function
Function geocode(street As String, city As String, state As String, zip As String) As String
' clean up the address and call geocodeAddressLookup
Dim result As String
Dim addr As String
street = geocodeCleanStreet(street)
city = RegExValidate(LCase(city), "[a-z ]")
state = RegExValidate(UCase(state), "[A-Z ]")
zip = geocodeCleanZip(zip)
' if the street address is a PO box then we won't be able to geocode
' if zip not blank then try looking up street and zip
' if this fails, try looking up street, city, state
' if this fails, try fixing up the street
' if street has changed after fixup, try looking up street and zip
' if this fails, try looking up street, city, state
If [GeocoderToUse] = "Yahoo" Then
result = yahooAddressLookup(street, city, state, zip)
Else:
If Left(street, 5) = "xxxxx" Or _
Left(street, 6) = "po box" Or _
Left(street, 7) = "post of" Or _
Left(street, 7) = "p o box" Or _
Left(street, 7) = "city of" Then
result = ",,"
Else:
If zip <> "" Then
result = geocoderAddressLookup(geocodeNormalizeAddress(street & ", " & zip))
Else
result = ",,"
End If
If result = ",," Then
If city <> "" And state <> "" Then
result = geocoderAddressLookup(geocodeNormalizeAddress(street & ", " & zip))
Else
result = ",,"
End If
If result = ",," And street <> "" Then
oldstreet = street
' try to clean up street
street = Replace(street, " th ", "th ")
street = Replace(street, " rd ", "rd ")
street = trimstrafter(street, "st")
street = trimstrafter(street, "dr")
street = trimstrafter(street, "rd")
street = trimstrafter(street, "road")
street = trimstrafter(street, "dr")
street = trimstrafter(street, "lane")
street = trimstrafter(street, "ln")
street = trimstrafter(street, "ave")
street = trimstrafter(street, "blvd")
street = trimstrafter(street, "boulevard")
street = trimstrafter(street, "pl")
If street <> oldstreet Then
If zip <> "" Then
result = geocoderAddressLookup(geocodeNormalizeAddress(street & ", " & zip))
Else
result = ",,"
End If
If result = ",," Then
result = geocoderAddressLookup(geocodeNormalizeAddress(street & ", " & zip))
Else
result = ",,"
End If
End If
End If
End If
End If
End If
geocode = result
End Function
Function yahooAddressLookup(street As String, city As String, state As String, zip As String) As String
' perform RESTian lookup on Yahoo
Dim marshalledResult As String
Dim yahoo As String
Dim response As String
Dim result As String
' marshal the results of this very time consuming function
' see if we've already looked up this address
' turn error handling off
On Error Resume Next
' lookup the result in the collection
' an error will be raised if the value is not found
marshalledResult = geocodeResults(addr)
If marshalledResult <> "" Then
' if a value is found then return the result
geocodeAddressLookup = marshalledResult
Exit Function
End If
' turn error handling back on
On Error GoTo 0
Application.StatusBar = "Looking for " & street & ", " & city & ", " & state & " " & zip
yahoo = trim(CStr([yahooid]))
street = trim(street)
city = trim(city)
state = trim(state)
zip = trim(zip)
URL = "http://api.local.yahoo.com/MapsService/V1/geocode?appid=" & yahoo & "&street=" & street & "&city=" & city & "&state=" & state & "&zip=" & zip
'Create Http object
If IsEmpty(http) Then Set http = CreateObject("WinHttp.WinHttpRequest.5.1")
'Send request To URL
http.Open "GET", URL
http.send
'Get response data As a string
response = http.responseText
' capture the latitude by regex matching the values in the tags
lat = RegExMatch(response, "
lng = RegExMatch(response, "
precision = RegExMatch(response, "precision=""([a-z0-9+]+)""")
addr = RegExMatch(response, "[0-9+]+ (.*)")
' return a comma delimited string
' if values not found, this will return ","
yahooAddressLookup = lat & "," & lng & "," & precision & "," & addr
If [BeepOn] Then Beep
' store the result in the cache collection
'
' turn off error handling with "On Error Resume Next"
' an error will be raised if you try to store to an address already in the cache
' we can ignore this error
On Error Resume Next
' store the result
geocodeResults(addr) = lat & "," & lng
End Function
Function geocoderAddressLookup(addr As String) As String
' perform RESTian lookup on geocoder.us
Dim marshalledResult As String
Dim usernm As String
Dim passwd As String
Dim response As String
Dim result As String
' marshal the results of this very time consuming function
' see if we've already looked up this address
' turn error handling off
On Error Resume Next
' lookup the result in the collection
' an error will be raised if the value is not found
marshalledResult = geocodeResults(addr)
If marshalledResult <> "" Then
' if a value is found then return the result
geocodeAddressLookup = marshalledResult
Exit Function
End If
' turn error handling back on
On Error GoTo 0
Application.StatusBar = "Looking for " & addr
usernm = trim(CStr([geocoderUsername]))
passwd = trim(CStr([geocoderPassword]))
URL = "http://geocoder.us/member/service/rest/geocode?address=" & addr
'Create Http object
If IsEmpty(http) Then Set http = CreateObject("WinHttp.WinHttpRequest.5.1")
'Send request To URL
http.Open "GET", URL
http.setcredentials usernm, passwd, 0
http.send
'Get response data As a string
response = http.responseText
' capture the latitude by regex matching the values in the tags
lat = RegExMatch(response, "
lng = RegExMatch(response, "
' return a comma delimtied string
' if values not found, this will return ","
geocoderAddressLookup = lat & "," & lng & ","
Beep
' store the result in the cache collection
'
' turn off error handling with "On Error Resume Next"
' an error will be raised if you try to store to an address already in the cache
' we can ignore this error
On Error Resume Next
' store the result
geocodeResults(addr) = lat & "," & lng
End Function
' wraps string with a tag
Function tag(xmltag As String, val As String) As String
tag = "<" & xmltag & ">" & val & "" & vbCrLf
End Function
' basic distance function for latitude/longitude
Public Function latLongDistance(lat1 As Double, long1 As Double, lat2 As Double, long2 As Double) As Double
Dim x As Double
Dim y As Double
x = 69.1 * (lat2 - lat1)
y = 69.1 * (long2 - long1) * Cos(lat1 / 57.3)
latLongDistance = (x * x + y * y) ^ 0.5
End Function
Private Function max(a, b):
If a > b Then
max = a
Else
max = b
End If
End Function
' locate the last row containing address data
Function LastDataRow() As Integer
Dim r As Integer
activecelladdr = ActiveCell.Address
Range("d65536").End(xlUp).Select
r = ActiveCell.Row()
Range("e65536").End(xlUp).Select
r = max(r, ActiveCell.Row())
Range("f65536").End(xlUp).Select
r = max(r, ActiveCell.Row())
Range("g65536").End(xlUp).Select
r = max(r, ActiveCell.Row())
Range(activecelladdr).Select
LastDataRow = r
End Function
Sub MacrosWorking()
MsgBox "Macros are enabled."
End Sub
Tuesday, July 29, 2008
clean up orphaned connection
set SERVEROUTPUT ON
exec dbms_output.enable(100000);
DECLARE
CURSOR process_list IS
SELECT sde_id, owner, nodename FROM sde.process_information;
lock_name VARCHAR2(30);
lock_handle VARCHAR2(128);
lock_status INTEGER;
cnt INTEGER DEFAULT 0;
BEGIN
FOR check_locks IN process_list LOOP
lock_name := 'SDE_Connection_ID#' || TO_CHAR (check_locks.sde_id);
DBMS_LOCK.ALLOCATE_UNIQUE (lock_name,lock_handle);
lock_status := DBMS_LOCK.REQUEST (lock_handle,DBMS_LOCK.X_MODE,0,TRUE);
IF lock_status = 0 THEN
DELETE FROM sde.process_information WHERE sde_id = check_locks.sde_id;
DELETE FROM sde.state_locks WHERE sde_id = check_locks.sde_id;
DELETE FROM sde.table_locks WHERE sde_id = check_locks.sde_id;
DELETE FROM sde.object_locks WHERE sde_id = check_locks.sde_id;
DELETE FROM sde.layer_locks WHERE sde_id = check_locks.sde_id;
cnt := cnt + 1;
dbms_output.put_line('Removed entry ('||check_locks.sde_id||'): '||check_locks.owner||'/'||check_locks.nodename||'');
END IF;
END LOOP;
/* Remove any orphaned lock entries... */
DELETE FROM sde.state_locks WHERE sde_id NOT IN (SELECT sde_id FROM sde.process_information);
DELETE FROM sde.table_locks WHERE sde_id NOT IN (SELECT sde_id FROM sde.process_information);
DELETE FROM sde.object_locks WHERE sde_id NOT IN (SELECT sde_id FROM sde.process_information);
DELETE FROM sde.layer_locks WHERE sde_id NOT IN (SELECT sde_id FROM sde.process_information);
COMMIT;
dbms_output.put_line('Removed '||cnt||' entries.');
END;
exec dbms_output.enable(100000);
DECLARE
CURSOR process_list IS
SELECT sde_id, owner, nodename FROM sde.process_information;
lock_name VARCHAR2(30);
lock_handle VARCHAR2(128);
lock_status INTEGER;
cnt INTEGER DEFAULT 0;
BEGIN
FOR check_locks IN process_list LOOP
lock_name := 'SDE_Connection_ID#' || TO_CHAR (check_locks.sde_id);
DBMS_LOCK.ALLOCATE_UNIQUE (lock_name,lock_handle);
lock_status := DBMS_LOCK.REQUEST (lock_handle,DBMS_LOCK.X_MODE,0,TRUE);
IF lock_status = 0 THEN
DELETE FROM sde.process_information WHERE sde_id = check_locks.sde_id;
DELETE FROM sde.state_locks WHERE sde_id = check_locks.sde_id;
DELETE FROM sde.table_locks WHERE sde_id = check_locks.sde_id;
DELETE FROM sde.object_locks WHERE sde_id = check_locks.sde_id;
DELETE FROM sde.layer_locks WHERE sde_id = check_locks.sde_id;
cnt := cnt + 1;
dbms_output.put_line('Removed entry ('||check_locks.sde_id||'): '||check_locks.owner||'/'||check_locks.nodename||'');
END IF;
END LOOP;
/* Remove any orphaned lock entries... */
DELETE FROM sde.state_locks WHERE sde_id NOT IN (SELECT sde_id FROM sde.process_information);
DELETE FROM sde.table_locks WHERE sde_id NOT IN (SELECT sde_id FROM sde.process_information);
DELETE FROM sde.object_locks WHERE sde_id NOT IN (SELECT sde_id FROM sde.process_information);
DELETE FROM sde.layer_locks WHERE sde_id NOT IN (SELECT sde_id FROM sde.process_information);
COMMIT;
dbms_output.put_line('Removed '||cnt||' entries.');
END;
Friday, July 25, 2008
script to get the duct info blob
'getting the value from Blob field
Dim pBlob As IMemoryBlobStream
iCount = iCount + 1
If IsNull(pfeat.Value(nBlob)) Then
GoTo myEnd
End If
Set pBlob = pfeat.Value(nBlob)
'create the duckbankconfig and ductview objecs
Dim pDuctBankConfig As IMMDuctBankConfig
Dim pDuctView As IMMDuctView
Set pDuctBankConfig = New MMDuctBankConfig
Set pDuctView = New MMDuctView
'asociate list objects with duct configuration object
Dim pDuctBankConfigList As ID8List
Dim pDuctViewList As ID8List
Set pDuctViewList = pDuctView
Set pDuctBankConfigList = pDuctBankConfig
Dim pMMListItem As IMMPersistentListItem
Set pMMListItem = pDuctBankConfigList
'load the blob into list objects
pMMListItem.LoadFromStream pBlob
Dim pDuctDefinition As IMMDuctDefinition
If Not (pDuctBankConfigList Is Nothing) Then 'And (Not IsNull(pDuctBankConfigList))
pDuctBankConfigList.Reset
Do
Set pDuctViewList = pDuctBankConfigList.Next
If Not (pDuctViewList Is Nothing) Then 'And (Not IsNull(pDuctViewList))
pDuctViewList.Reset
Do
Set pDuctDefinition = pDuctViewList.Next
If Not (pDuctDefinition Is Nothing) Then 'And (Not IsNull(pDuctDefinition))
'MsgBox pfeat.OID & "-" & pDuctDefinition.availability & "-" & pDuctDefinition.ductID & "-" & pDuctDefinition.diameter
TextStream.WriteLine iCount & "," & pfeat.OID & "," & pDuctDefinition.availability & "," & pDuctDefinition.ductID & "," & pDuctDefinition.diameter & "," & pDuctDefinition.ductNumber & "," & pDuctDefinition.Material
End If
Loop While Not (pDuctDefinition Is Nothing) ' And (Not IsNull(pDuctDefinition))
End If
Loop While Not (pDuctViewList Is Nothing) ' And (Not IsNull(pDuctViewList))
End If
Set pDuctView = Nothing
Set pDuctBankConfig = Nothing
Set pBlob = Nothing
myEnd:
Set pfeat = pftCursor.NextFeature
Loop
TextStream.Close
Set TextStream = Nothing
Set FileSystem = Nothing
End Sub
Dim pBlob As IMemoryBlobStream
iCount = iCount + 1
If IsNull(pfeat.Value(nBlob)) Then
GoTo myEnd
End If
Set pBlob = pfeat.Value(nBlob)
'create the duckbankconfig and ductview objecs
Dim pDuctBankConfig As IMMDuctBankConfig
Dim pDuctView As IMMDuctView
Set pDuctBankConfig = New MMDuctBankConfig
Set pDuctView = New MMDuctView
'asociate list objects with duct configuration object
Dim pDuctBankConfigList As ID8List
Dim pDuctViewList As ID8List
Set pDuctViewList = pDuctView
Set pDuctBankConfigList = pDuctBankConfig
Dim pMMListItem As IMMPersistentListItem
Set pMMListItem = pDuctBankConfigList
'load the blob into list objects
pMMListItem.LoadFromStream pBlob
Dim pDuctDefinition As IMMDuctDefinition
If Not (pDuctBankConfigList Is Nothing) Then 'And (Not IsNull(pDuctBankConfigList))
pDuctBankConfigList.Reset
Do
Set pDuctViewList = pDuctBankConfigList.Next
If Not (pDuctViewList Is Nothing) Then 'And (Not IsNull(pDuctViewList))
pDuctViewList.Reset
Do
Set pDuctDefinition = pDuctViewList.Next
If Not (pDuctDefinition Is Nothing) Then 'And (Not IsNull(pDuctDefinition))
'MsgBox pfeat.OID & "-" & pDuctDefinition.availability & "-" & pDuctDefinition.ductID & "-" & pDuctDefinition.diameter
TextStream.WriteLine iCount & "," & pfeat.OID & "," & pDuctDefinition.availability & "," & pDuctDefinition.ductID & "," & pDuctDefinition.diameter & "," & pDuctDefinition.ductNumber & "," & pDuctDefinition.Material
End If
Loop While Not (pDuctDefinition Is Nothing) ' And (Not IsNull(pDuctDefinition))
End If
Loop While Not (pDuctViewList Is Nothing) ' And (Not IsNull(pDuctViewList))
End If
Set pDuctView = Nothing
Set pDuctBankConfig = Nothing
Set pBlob = Nothing
myEnd:
Set pfeat = pftCursor.NextFeature
Loop
TextStream.Close
Set TextStream = Nothing
Set FileSystem = Nothing
End Sub
Wednesday, July 23, 2008
code to break blob
Sub Test_break_blob()'create a file to save the broken information'it will be replaced by writing a database tablestrFilename = "C:\testBreakBlob.txt"
'need to set a reference to Microsoft Scripting LibraryDim FileSystem As FileSystemObject, TextStream As TextStreamSet FileSystem = CreateObject("Scripting.FileSystemObject")Set TextStream = FileSystem.CreateTextFile(strFilename)'set up the system'getting the layer and selectionset'in the future, we may consider write an AutoUpdater
Dim pMap As IMapDim pmxDoc As IMxDocumentSet pmxDoc = ThisDocumentSet pMap = pmxDoc.ActiveViewDim pftLayer As IFeatureLayerSet pftLayer = pMap.Layer(0) ' assume one layer, but in the future should find the layer from TOC
Dim pftClass As IFeatureClassSet pftClass = pftLayer.FeatureClassDim pfeat As IFeatureDim pftCursor As IFeatureCursor'getting all featuresSet pftCursor = pftClass.Search(Nothing, False)
Set pfeat = pftCursor.NextFeatureDo While Not (pfeat Is Nothing) 'finding the configuration field Dim pField As IField Dim nBlob As Long nBlob = pftClass.FindField("configuration") Set pField = pfeat.Fields.Field(nBlob)
'getting the value from Blob field Dim pBlob As IMemoryBlobStream Set pBlob = pfeat.Value(nBlob)
'create the duckbankconfig and ductview objecs Dim pDuctBankConfig As IMMDuctBankConfig Dim pDuctView As IMMDuctView Set pDuctBankConfig = New MMDuctBankConfig Set pDuctView = New MMDuctView 'asociate list objects with duct configuration object Dim pDuctBankConfigList As ID8List Dim pDuctViewList As ID8List Set pDuctViewList = pDuctView Set pDuctBankConfigList = pDuctBankConfig Dim pMMListItem As IMMPersistentListItem Set pMMListItem = pDuctBankConfigList 'load the blob into list objects pMMListItem.LoadFromStream pBlob Dim pDuctDefinition As IMMDuctDefinition
If Not (pDuctBankConfigList Is Nothing) Then 'And (Not IsNull(pDuctBankConfigList)) pDuctBankConfigList.Reset Do Set pDuctViewList = pDuctBankConfigList.Next If Not (pDuctViewList Is Nothing) Then 'And (Not IsNull(pDuctViewList)) pDuctViewList.Reset Do Set pDuctDefinition = pDuctViewList.Next If Not (pDuctDefinition Is Nothing) Then 'And (Not IsNull(pDuctDefinition)) 'MsgBox pfeat.OID & "-" & pDuctDefinition.availability & "-" & pDuctDefinition.ductID & "-" & pDuctDefinition.diameter TextStream.WriteLine pfeat.OID & "," & pDuctDefinition.availability & "," & pDuctDefinition.ductID & "," & pDuctDefinition.diameter & "," & pDuctDefinition.ductNumber & "," & pDuctDefinition.Material pductdefinition. End If Loop While Not (pDuctDefinition Is Nothing) ' And (Not IsNull(pDuctDefinition)) End If Loop While Not (pDuctViewList Is Nothing) ' And (Not IsNull(pDuctViewList)) End If Set pDuctView = Nothing Set pDuctBankConfig = Nothing Set pBlob = Nothing Set pfeat = pftCursor.NextFeatureLoopTextStream.CloseSet TextStream = NothingSet FileSystem = NothingEnd Sub
'need to set a reference to Microsoft Scripting LibraryDim FileSystem As FileSystemObject, TextStream As TextStreamSet FileSystem = CreateObject("Scripting.FileSystemObject")Set TextStream = FileSystem.CreateTextFile(strFilename)'set up the system'getting the layer and selectionset'in the future, we may consider write an AutoUpdater
Dim pMap As IMapDim pmxDoc As IMxDocumentSet pmxDoc = ThisDocumentSet pMap = pmxDoc.ActiveViewDim pftLayer As IFeatureLayerSet pftLayer = pMap.Layer(0) ' assume one layer, but in the future should find the layer from TOC
Dim pftClass As IFeatureClassSet pftClass = pftLayer.FeatureClassDim pfeat As IFeatureDim pftCursor As IFeatureCursor'getting all featuresSet pftCursor = pftClass.Search(Nothing, False)
Set pfeat = pftCursor.NextFeatureDo While Not (pfeat Is Nothing) 'finding the configuration field Dim pField As IField Dim nBlob As Long nBlob = pftClass.FindField("configuration") Set pField = pfeat.Fields.Field(nBlob)
'getting the value from Blob field Dim pBlob As IMemoryBlobStream Set pBlob = pfeat.Value(nBlob)
'create the duckbankconfig and ductview objecs Dim pDuctBankConfig As IMMDuctBankConfig Dim pDuctView As IMMDuctView Set pDuctBankConfig = New MMDuctBankConfig Set pDuctView = New MMDuctView 'asociate list objects with duct configuration object Dim pDuctBankConfigList As ID8List Dim pDuctViewList As ID8List Set pDuctViewList = pDuctView Set pDuctBankConfigList = pDuctBankConfig Dim pMMListItem As IMMPersistentListItem Set pMMListItem = pDuctBankConfigList 'load the blob into list objects pMMListItem.LoadFromStream pBlob Dim pDuctDefinition As IMMDuctDefinition
If Not (pDuctBankConfigList Is Nothing) Then 'And (Not IsNull(pDuctBankConfigList)) pDuctBankConfigList.Reset Do Set pDuctViewList = pDuctBankConfigList.Next If Not (pDuctViewList Is Nothing) Then 'And (Not IsNull(pDuctViewList)) pDuctViewList.Reset Do Set pDuctDefinition = pDuctViewList.Next If Not (pDuctDefinition Is Nothing) Then 'And (Not IsNull(pDuctDefinition)) 'MsgBox pfeat.OID & "-" & pDuctDefinition.availability & "-" & pDuctDefinition.ductID & "-" & pDuctDefinition.diameter TextStream.WriteLine pfeat.OID & "," & pDuctDefinition.availability & "," & pDuctDefinition.ductID & "," & pDuctDefinition.diameter & "," & pDuctDefinition.ductNumber & "," & pDuctDefinition.Material pductdefinition. End If Loop While Not (pDuctDefinition Is Nothing) ' And (Not IsNull(pDuctDefinition)) End If Loop While Not (pDuctViewList Is Nothing) ' And (Not IsNull(pDuctViewList)) End If Set pDuctView = Nothing Set pDuctBankConfig = Nothing Set pBlob = Nothing Set pfeat = pftCursor.NextFeatureLoopTextStream.CloseSet TextStream = NothingSet FileSystem = NothingEnd Sub
Wednesday, July 16, 2008
List data source
Sub List_Source()
Dim mxDoc As IMxDocument
Dim pMap As iMap
Set mxDoc = ThisDocument
Set pMap = mxDoc.FocusMap
Dim pLayer As ILayer
Dim pDataLayer As IDataLayer2
Dim pftlayer As IFeatureLayer
For i = 0 To pMap.LayerCount - 1
Set pLayer = pMap.Layer(i)
If TypeOf pLayer Is IDataLayer Then
Set pDataLayer = pLayer
Dim pdataSrc As IDatasetName
Set pdataSrc = pDataLayer.DataSourceName
Debug.Print pLayer.Name & "," & pdataSrc.WorkspaceName.BrowseName & "," & pdataSrc.WorkspaceName.PathName & "," & pdataSrc.WorkspaceName.Type
'Debug.Print pDataLayer.DataSourceName
End If
Next
End Sub
Dim mxDoc As IMxDocument
Dim pMap As iMap
Set mxDoc = ThisDocument
Set pMap = mxDoc.FocusMap
Dim pLayer As ILayer
Dim pDataLayer As IDataLayer2
Dim pftlayer As IFeatureLayer
For i = 0 To pMap.LayerCount - 1
Set pLayer = pMap.Layer(i)
If TypeOf pLayer Is IDataLayer Then
Set pDataLayer = pLayer
Dim pdataSrc As IDatasetName
Set pdataSrc = pDataLayer.DataSourceName
Debug.Print pLayer.Name & "," & pdataSrc.WorkspaceName.BrowseName & "," & pdataSrc.WorkspaceName.PathName & "," & pdataSrc.WorkspaceName.Type
'Debug.Print pDataLayer.DataSourceName
End If
Next
End Sub
Thursday, March 27, 2008
Wednesday, March 26, 2008
#Python Script for put water mark annontation on image
#Python Script for put water mark annontation on image
#John Zhou MWH Global 12/19/2006
#Not for other use
#need Python and PIL Installed
import win32com.client
import fnmatch
import string
import os
import Image,ImageDraw,ImageFont,sys
engine = win32com.client.Dispatch("DAO.DBEngine.36")
strPath="E:\\PWP_WaterMark\\"
#Determine the path to your database and use the following syntax:
#make sure the database name
db = engine.OpenDatabase(strPath+"ConsolidatedGPS_18Dec2006.mdb")
totalNum=0
ferr=open("c:\\err.txt","w")
fsuccess=open("c:\\success.txt","w")
for fileName in os.listdir ( strPath+"Field Photos"):
if fnmatch.fnmatch ( fileName, '*.jpg' ) :
path, name = os.path.split (fileName)
queryString="select PoleFacilityID, Address, PhotoLocation from Pole where PhotoLocation like '*" +name+"*'"
# print queryString
x=1
rs = db.OpenRecordset( queryString )
Anno=""
while not rs.EOF and x<2:
Anno= rs.Fields("PoleFacilityID").Value+"|"+rs.Fields("Address").Value+ "|"+name
rs.MoveNext
x=x+1
strFileName = strPath+"Field Photos\\"+fileName.upper()
totalNum=totalNum+1
if (len(Anno)>0):
fsuccess.write(strFileName+"\n")
else:
ferr.write(strFileName+"\n")
# print strFileName
im1=Image.open(strFileName)
im2=Image.new(im1.mode,im1.size)
font = ImageFont.truetype("arial.ttf", 16)
textsize=font.getsize(Anno)
for mySize in range(18,100,2):
if textsize[0]>=im1.size[0]-im1.size[0]*0.2:
break
font = ImageFont.truetype("arial.ttf", mySize)
textsize=font.getsize(Anno)
draw2=ImageDraw.Draw(im2)
draw2.rectangle([0,im2.size[1],im2.size[0],im2.size[1]-textsize[1]],fill=128)
im3=Image.blend(im1,im2,0.2)
draw3=ImageDraw.Draw(im3)
draw3.text(((im3.size[0]-textsize[0])/2, im3.size[1]-textsize[1]), Anno, font=font)
im3.save(strFileName,"JPEG")
print totalNum
ferr.close()
fsuccess.close()
#rs = db.OpenRecordset("select PoleFacilityID, Address, PhotoLocation from Pole")
# db.Execute("delete * from customers where balancetype = 'overdue' and name = 'bill'")
#while not rs.EOF:
# print rs.Fields("PoleFacilityID").Value
# rs.MoveNext
#Python Script for put water mark annontation on image
# where PhotoLocation like '*PWP*'
#Instantiate the Jet engine.
import win32com.client
import fnmatch
import string
import os
import Image,ImageDraw,ImageFont,sys
engine = win32com.client.Dispatch("DAO.DBEngine.36")
#Determine the path to your database and use the following syntax:
db = engine.OpenDatabase(r"C:\Documents and Settings\John Zhou\Desktop\ElectricArea3.mdb")
#rs = db.OpenRecordset("pole")
#You can also do the following
x=1
for fileName in os.listdir ( r"C:\Documents and Settings\John Zhou\Desktop\Field Photos"):
if fnmatch.fnmatch ( fileName, '*.jpg' ):
path, name = os.path.split (fileName)
queryString="select PoleFacilityID, Address, PhotoLocation from Pole where PhotoLocation like '*" +name+"*'"
# print queryString
x=1
rs = db.OpenRecordset( queryString )
Anno=""
while not rs.EOF and x<2:
Anno= rs.Fields("PoleFacilityID").Value+"|"+rs.Fields("Address").Value+ "|"+name
rs.MoveNext
x=x+1
# if len(Anno) = 0:
# break
strFileName = "C:\\Documents and Settings\\John Zhou\\Desktop\\Field Photos\\"+fileName.upper()
print strFileName
im1=Image.open(strFileName)
im2=Image.new(im1.mode,im1.size)
font = ImageFont.truetype("arial.ttf", 16)
textsize=font.getsize(Anno)
for mySize in range(18,100,2):
if textsize[0]>=im1.size[0]-im1.size[0]*0.2:
break
font = ImageFont.truetype("arial.ttf", mySize)
textsize=font.getsize(Anno)
draw2=ImageDraw.Draw(im2)
draw2.rectangle([0,im2.size[1],im2.size[0],im2.size[1]-textsize[1]],fill=128)
im3=Image.blend(im1,im2,0.2)
draw3=ImageDraw.Draw(im3)
draw3.text(((im3.size[0]-textsize[0])/2, im3.size[1]-textsize[1]), Anno, font=font)
im3.save("c:\\"+name,"JPEG")
#rs = db.OpenRecordset("select PoleFacilityID, Address, PhotoLocation from Pole")
# db.Execute("delete * from customers where balancetype = 'overdue' and name = 'bill'")
#while not rs.EOF:
# print rs.Fields("PoleFacilityID").Value
# rs.MoveNext
#John Zhou MWH Global 12/19/2006
#Not for other use
#need Python and PIL Installed
import win32com.client
import fnmatch
import string
import os
import Image,ImageDraw,ImageFont,sys
engine = win32com.client.Dispatch("DAO.DBEngine.36")
strPath="E:\\PWP_WaterMark\\"
#Determine the path to your database and use the following syntax:
#make sure the database name
db = engine.OpenDatabase(strPath+"ConsolidatedGPS_18Dec2006.mdb")
totalNum=0
ferr=open("c:\\err.txt","w")
fsuccess=open("c:\\success.txt","w")
for fileName in os.listdir ( strPath+"Field Photos"):
if fnmatch.fnmatch ( fileName, '*.jpg' ) :
path, name = os.path.split (fileName)
queryString="select PoleFacilityID, Address, PhotoLocation from Pole where PhotoLocation like '*" +name+"*'"
# print queryString
x=1
rs = db.OpenRecordset( queryString )
Anno=""
while not rs.EOF and x<2:
Anno= rs.Fields("PoleFacilityID").Value+"|"+rs.Fields("Address").Value+ "|"+name
rs.MoveNext
x=x+1
strFileName = strPath+"Field Photos\\"+fileName.upper()
totalNum=totalNum+1
if (len(Anno)>0):
fsuccess.write(strFileName+"\n")
else:
ferr.write(strFileName+"\n")
# print strFileName
im1=Image.open(strFileName)
im2=Image.new(im1.mode,im1.size)
font = ImageFont.truetype("arial.ttf", 16)
textsize=font.getsize(Anno)
for mySize in range(18,100,2):
if textsize[0]>=im1.size[0]-im1.size[0]*0.2:
break
font = ImageFont.truetype("arial.ttf", mySize)
textsize=font.getsize(Anno)
draw2=ImageDraw.Draw(im2)
draw2.rectangle([0,im2.size[1],im2.size[0],im2.size[1]-textsize[1]],fill=128)
im3=Image.blend(im1,im2,0.2)
draw3=ImageDraw.Draw(im3)
draw3.text(((im3.size[0]-textsize[0])/2, im3.size[1]-textsize[1]), Anno, font=font)
im3.save(strFileName,"JPEG")
print totalNum
ferr.close()
fsuccess.close()
#rs = db.OpenRecordset("select PoleFacilityID, Address, PhotoLocation from Pole")
# db.Execute("delete * from customers where balancetype = 'overdue' and name = 'bill'")
#while not rs.EOF:
# print rs.Fields("PoleFacilityID").Value
# rs.MoveNext
#Python Script for put water mark annontation on image
# where PhotoLocation like '*PWP*'
#Instantiate the Jet engine.
import win32com.client
import fnmatch
import string
import os
import Image,ImageDraw,ImageFont,sys
engine = win32com.client.Dispatch("DAO.DBEngine.36")
#Determine the path to your database and use the following syntax:
db = engine.OpenDatabase(r"C:\Documents and Settings\John Zhou\Desktop\ElectricArea3.mdb")
#rs = db.OpenRecordset("pole")
#You can also do the following
x=1
for fileName in os.listdir ( r"C:\Documents and Settings\John Zhou\Desktop\Field Photos"):
if fnmatch.fnmatch ( fileName, '*.jpg' ):
path, name = os.path.split (fileName)
queryString="select PoleFacilityID, Address, PhotoLocation from Pole where PhotoLocation like '*" +name+"*'"
# print queryString
x=1
rs = db.OpenRecordset( queryString )
Anno=""
while not rs.EOF and x<2:
Anno= rs.Fields("PoleFacilityID").Value+"|"+rs.Fields("Address").Value+ "|"+name
rs.MoveNext
x=x+1
# if len(Anno) = 0:
# break
strFileName = "C:\\Documents and Settings\\John Zhou\\Desktop\\Field Photos\\"+fileName.upper()
print strFileName
im1=Image.open(strFileName)
im2=Image.new(im1.mode,im1.size)
font = ImageFont.truetype("arial.ttf", 16)
textsize=font.getsize(Anno)
for mySize in range(18,100,2):
if textsize[0]>=im1.size[0]-im1.size[0]*0.2:
break
font = ImageFont.truetype("arial.ttf", mySize)
textsize=font.getsize(Anno)
draw2=ImageDraw.Draw(im2)
draw2.rectangle([0,im2.size[1],im2.size[0],im2.size[1]-textsize[1]],fill=128)
im3=Image.blend(im1,im2,0.2)
draw3=ImageDraw.Draw(im3)
draw3.text(((im3.size[0]-textsize[0])/2, im3.size[1]-textsize[1]), Anno, font=font)
im3.save("c:\\"+name,"JPEG")
#rs = db.OpenRecordset("select PoleFacilityID, Address, PhotoLocation from Pole")
# db.Execute("delete * from customers where balancetype = 'overdue' and name = 'bill'")
#while not rs.EOF:
# print rs.Fields("PoleFacilityID").Value
# rs.MoveNext
Tuesday, March 25, 2008
Sort Domain
http://edndoc.esri.com/arcobjects/9.2/CPP_VB6_VBA_VCPP_Doc/COM_Samples_Docs/Geodatabase/Schema_Creation_and_Management/Sort_a_domain/e826c5a8-9740-4f0b-86b6-d3b834735574.htm
Thursday, March 20, 2008
Thursday, March 6, 2008
remove blankline awk
Many times of output of some packages contain lot of blank lines. You can remove those blank line using awk as follows:
Assume that /tmp/test is the file containing blank lines
cat /tmp/test | awk '$0!~/^$/ {print $0}' > /tmp/test1
This script is to exclude blank line ^ represent beginning of a line, $ represents end of a line, therefore ^$ stands for a line without any contents. ! stands for not.
It could be done by grep in the similar way. grep -v "^$" filename > newfilename
-v stands for "not"
Assume that /tmp/test is the file containing blank lines
cat /tmp/test | awk '$0!~/^$/ {print $0}' > /tmp/test1
This script is to exclude blank line ^ represent beginning of a line, $ represents end of a line, therefore ^$ stands for a line without any contents. ! stands for not.
It could be done by grep in the similar way. grep -v "^$" filename > newfilename
-v stands for "not"
Tuesday, March 4, 2008
quick imagemagick command to identify massive files resolution and size
G:\MWH_PWP Water Sources\WorkOrders>identify -format "%f,%x,%y,%p,%P" -quiet *.tif>D:\workorder.txt
scripts to read and write BLOB in MS Access
Const Blocksize = 32768
'**********************************************************************
'FUNCTION: ReadBLOB()
'
'PURPOSE:
'Reads a BLOB from a disk file and stores the contents in the specified
'table and field.
'
'PREREQUISITES:
'The specified table with the OLE object field to contain the binary
'data must be opened in Visual Basic code and prepared for a new record.
'
'ARGUMENTS:
'Source - the path and filename of the file to be stored.
'T - the table object to store the data in.
'Field - the OLE object to store the
'RETURN:
'0 on fail 1 on success
'**********************************************************************
Public Function ReadBLOB(Source As String, T As Recordset, sField As String)
Dim NumBlocks As Integer, SourceFile As Integer, i As Integer
Dim FileLength As Long, LeftOver As Long
Dim FileData() As Byte, RetVal As Variant
On Error GoTo Err_ReadBLOB
SourceFile = FreeFile
Open Source For Binary Access Read As SourceFile
FileLength = LOF(SourceFile)
If FileLength <> 0 Then
NumBlocks = FileLength \ Blocksize
LeftOver = FileLength Mod Blocksize 'remainder appended first
'initialize status bar meter.
RetVal = SysCmd(acSysCmdInitMeter, "Reading BLOB", FileLength \ 1000)
ReDim FileData(LeftOver)
Get SourceFile, , FileData()
T(sField).AppendChunk FileData() 'store the first image chunk
RetVal = SysCmd(acSysCmdUpdateMeter, LeftOver / 1000)
ReDim FileData(Blocksize)
For i = 1 To NumBlocks
Get SourceFile, , FileData()
T(sField).AppendChunk FileData() 'remaining chunks
'update status bar meter
RetVal = SysCmd(acSysCmdUpdateMeter, Blocksize * i / 1000)
Next i
'remove status bar meter
RetVal = SysCmd(acSysCmdRemoveMeter)
End If
Close SourceFile
ReadBLOB = 1
Exit Function
Err_ReadBLOB:
MsgBox Err.Description
ReadBLOB = 0
Exit Function
End Function
'**********************************************************************
'FUNCTION: WriteBLOB()
'
'PURPOSE:
'WritesBLOB information stored in the specified table and field to the
'specified disk file.
'
'PREREQUISITES:
'
'ARGUMENTS:
'Destination - the path and filename of the file to be extracted.
'T - the table object the data is stored in.
'Field - the OLE object to store the data in.
'
'RETURN:
'0 on fail 1 on success
'**********************************************************************
Public Function WriteBLOB(T As Recordset, sField As String, Destination As String)
Dim NumBlocks As Integer, DestFile As Integer, i As Integer
Dim FileLength As Long, LeftOver As Long
Dim FileData() As Byte, RetVal As Variant
On Error GoTo Err_WriteBLOB
' Get the length of the file.
FileLength = T(sField).ActualSize()
If FileLength <> 0 Then
DestFile = FreeFile
NumBlocks = FileLength \ Blocksize
LeftOver = FileLength Mod Blocksize 'reminder appended first
'initialize status bar meter
RetVal = SysCmd(acSysCmdInitMeter, "Writing BLOB", NumBlocks)
Open Destination For Binary Access Write Lock Write As DestFile
ReDim FileData(LeftOver)
FileData() = T(sField).GetChunk(LeftOver)
Put DestFile, , FileData() 'write first chunk
ReDim FileData(Blocksize)
For i = 1 To NumBlocks
FileData() = T(sField).GetChunk(Blocksize)
Put DestFile, , FileData() 'write remaining chunks
'update status bar meter
RetVal = SysCmd(acSysCmdUpdateMeter, i)
Next i
Close DestFile
End If
'remove status bar meter
RetVal = SysCmd(acSysCmdRemoveMeter)
WriteBLOB = 1
Exit Function
Err_WriteBLOB:
MsgBox Err.Description
WriteBLOB = 0
Exit Function
End Function
Sub test()
Dim Cnn As ADODB.Connection
Dim Rst As ADODB.Recordset
Set Cnn = New ADODB.Connection
Cnn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0; " & "Data Source=E:\PWP Program\Task C Data Conversion\C.3 Power DC\Perform Full Data Conversion\Area2\PWP_Electric_2_test.mdb"
Cnn.Open
'Cnn.Execute ("SELECT CONFIGURATION FROM ConduitSection WHERE OBJECTID=78723;")
'Open a recordest based on the open connection
' Set Rst = New ADODB.Recordset
' Set Rst.ActiveConnection = Cnn
Set Rst = Cnn.Execute("SELECT CONFIGURATION FROM ConduitSection WHERE OBJECTID=78723;")
Rst.MoveFirst
MsgBox Rst.RecordCount
WriteBLOB Rst, "CONFIGURATION", "C:\testblog"
End Sub
'**********************************************************************
'FUNCTION: ReadBLOB()
'
'PURPOSE:
'Reads a BLOB from a disk file and stores the contents in the specified
'table and field.
'
'PREREQUISITES:
'The specified table with the OLE object field to contain the binary
'data must be opened in Visual Basic code and prepared for a new record.
'
'ARGUMENTS:
'Source - the path and filename of the file to be stored.
'T - the table object to store the data in.
'Field - the OLE object to store the
'RETURN:
'0 on fail 1 on success
'**********************************************************************
Public Function ReadBLOB(Source As String, T As Recordset, sField As String)
Dim NumBlocks As Integer, SourceFile As Integer, i As Integer
Dim FileLength As Long, LeftOver As Long
Dim FileData() As Byte, RetVal As Variant
On Error GoTo Err_ReadBLOB
SourceFile = FreeFile
Open Source For Binary Access Read As SourceFile
FileLength = LOF(SourceFile)
If FileLength <> 0 Then
NumBlocks = FileLength \ Blocksize
LeftOver = FileLength Mod Blocksize 'remainder appended first
'initialize status bar meter.
RetVal = SysCmd(acSysCmdInitMeter, "Reading BLOB", FileLength \ 1000)
ReDim FileData(LeftOver)
Get SourceFile, , FileData()
T(sField).AppendChunk FileData() 'store the first image chunk
RetVal = SysCmd(acSysCmdUpdateMeter, LeftOver / 1000)
ReDim FileData(Blocksize)
For i = 1 To NumBlocks
Get SourceFile, , FileData()
T(sField).AppendChunk FileData() 'remaining chunks
'update status bar meter
RetVal = SysCmd(acSysCmdUpdateMeter, Blocksize * i / 1000)
Next i
'remove status bar meter
RetVal = SysCmd(acSysCmdRemoveMeter)
End If
Close SourceFile
ReadBLOB = 1
Exit Function
Err_ReadBLOB:
MsgBox Err.Description
ReadBLOB = 0
Exit Function
End Function
'**********************************************************************
'FUNCTION: WriteBLOB()
'
'PURPOSE:
'WritesBLOB information stored in the specified table and field to the
'specified disk file.
'
'PREREQUISITES:
'
'ARGUMENTS:
'Destination - the path and filename of the file to be extracted.
'T - the table object the data is stored in.
'Field - the OLE object to store the data in.
'
'RETURN:
'0 on fail 1 on success
'**********************************************************************
Public Function WriteBLOB(T As Recordset, sField As String, Destination As String)
Dim NumBlocks As Integer, DestFile As Integer, i As Integer
Dim FileLength As Long, LeftOver As Long
Dim FileData() As Byte, RetVal As Variant
On Error GoTo Err_WriteBLOB
' Get the length of the file.
FileLength = T(sField).ActualSize()
If FileLength <> 0 Then
DestFile = FreeFile
NumBlocks = FileLength \ Blocksize
LeftOver = FileLength Mod Blocksize 'reminder appended first
'initialize status bar meter
RetVal = SysCmd(acSysCmdInitMeter, "Writing BLOB", NumBlocks)
Open Destination For Binary Access Write Lock Write As DestFile
ReDim FileData(LeftOver)
FileData() = T(sField).GetChunk(LeftOver)
Put DestFile, , FileData() 'write first chunk
ReDim FileData(Blocksize)
For i = 1 To NumBlocks
FileData() = T(sField).GetChunk(Blocksize)
Put DestFile, , FileData() 'write remaining chunks
'update status bar meter
RetVal = SysCmd(acSysCmdUpdateMeter, i)
Next i
Close DestFile
End If
'remove status bar meter
RetVal = SysCmd(acSysCmdRemoveMeter)
WriteBLOB = 1
Exit Function
Err_WriteBLOB:
MsgBox Err.Description
WriteBLOB = 0
Exit Function
End Function
Sub test()
Dim Cnn As ADODB.Connection
Dim Rst As ADODB.Recordset
Set Cnn = New ADODB.Connection
Cnn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0; " & "Data Source=E:\PWP Program\Task C Data Conversion\C.3 Power DC\Perform Full Data Conversion\Area2\PWP_Electric_2_test.mdb"
Cnn.Open
'Cnn.Execute ("SELECT CONFIGURATION FROM ConduitSection WHERE OBJECTID=78723;")
'Open a recordest based on the open connection
' Set Rst = New ADODB.Recordset
' Set Rst.ActiveConnection = Cnn
Set Rst = Cnn.Execute("SELECT CONFIGURATION FROM ConduitSection WHERE OBJECTID=78723;")
Rst.MoveFirst
MsgBox Rst.RecordCount
WriteBLOB Rst, "CONFIGURATION", "C:\testblog"
End Sub
Tuesday, February 26, 2008
powerful combination
to kill a process named mplayer
ps -ef|grep [m]player|awk '{print $2}'|xargs kill
ps -ef|grep [m]player|awk '{print $2}'|xargs kill
Thursday, February 21, 2008
ImageMagick Scritps to Crop Borders
I was experimenting ImageMagic's capability to crop images to come up an automated way for PWP's scanning issue. Made some progress, yet far from the solution.
convert SS0124570.tif -gravity northwest -crop 55%x55%+110+90 -quiet +repage tt.tif
convert SS0124570.tif -gravity northwest -crop 55%x55%+110+90 -quiet +repage tt.tif
Use ImageMagick to Scale Images
'This script produces resized images out of a given
'directory on the fly by using imagemagick
'This script is compiled by John Zhou, MWH Global, 1/14/2007
'This script is not part of any deliverables of PWP eGIS program currently undertaken by MWH
'This script is given to help PWP resizing large scanned images for free.
'Neither John Zhou, personally or MWH as a company is responsible for any damage caused by using this script.
'PWP should use this script at their own risk and discreetion.
'depending the amount file to be proceessed, it may take minutes to hours to run the script. Be patient.
'Need ImageMagick installed to run the script http://www.imagemagick.org/script/binary-releases.php#windows
Option Explicit 'This is to ensure no variable is used without defintion.
On Error Resume Next
Dim img 'ImageMagick object
Dim inputdir 'original directory
Dim inputfld ' file collection in the original folder
Dim outputdir 'destination directory
Dim outputfld 'file collection in the destination folder
Dim fso 'filesystem object
Dim f 'file object
Dim tnSize 'scale size
Dim nFileSize 'largest file size to be resized
inputdir = "d:\water\" 'This is the directory where the original files/images located
outputdir = "d:\water\"'This is the directory where the resized images will be located
'define how big the thumbnail should be
tnSize = "50%" 'default to reduce 1/4 size of original, it can be changed
nFileSize = 100000000 ' default only file larger than 100 Mega need to be resized
Set img = CreateObject("ImageMagickObject.MagickImage.1") 'Create a ImageMagick Object
Set fso = CreateObject("Scripting.FileSystemObject") 'Create a File System Object
Set inputfld = fso.GetFolder(inputdir).Files 'Get all files in the original folder
Set outputfld = fso.GetFolder(outputdir).Files 'Get all files in the destination folder
'reads all files in input dir, resizes them and copies them into output dir
'OPTIONS FOR CONVERT FUNCTION (taken from http://imagemagick.org/script/command-line-options.php):
'
'-resize width{%}{@} {!} {<} {>}
'resize an image.
'By default, the width and height are maximum values. That is, the image is expanded or contracted to fit the width and height value while maintaining the aspect ratio of the image. Append an exclamation point to the geometry to force the image size to exactly the size you specify. For example, if you specify 640x480! the image width is set to 640 pixels and height to 480.
'If only the width is specified, the width assumes the value and the height is chosen to maintain the aspect ratio of the image. Similarly, if only the height is specified (e.g., -resize x256, the width is chosen to maintain the aspect ratio.
'To specify a percentage width or height instead, append %. The image size is multiplied by the width and height percentages to obtain the final image dimensions. To increase the size of an image, use a value greater than 100 (e.g. 125%). To decrease an image's size, use a percentage less than 100.
'Use @ to specify the maximum area in pixels of an image.
'Use <> resizes the image only if both of its dimensions are less than the geometry specification. For example, if you specify 640x480 and the image size is 256x256, the image size does not change. However, if the image is 512x512 or 1024x1024, it is resized to 480x480. Enclose the geometry specification in quotation marks to prevent the <> from being interpreted by your shell as a file redirection.
'if the -filter option precedes the -resize option, the image is resized with the specified filter.
'If the -support option precedes the -resize option, the image is resized with the specified support.
For Each f In inputfld 'for each file in the original file folder
'if and only if there is no "resized" image in the destination folder (avoid redudant work) and the original file size is larger than nFileSize
If Not fso.fileexists(outputdir & fso.GetBaseName(f) & "_resize." & fso.GetExtensionName(f)) and f.Size > nFileSize Then
' Use ImageMagick's Convert function to resize and add "_resize" at the end of original file name
rs = img.Convert("-quiet","-resize",tnSize,inputdir & f.Name,outputdir & fso.GetBaseName(f) & "_resize." & fso.GetExtensionName(f))
End If
Next
WScript.Echo "Done" 'tell the user the file is done
Set img=Nothing
'directory on the fly by using imagemagick
'This script is compiled by John Zhou, MWH Global, 1/14/2007
'This script is not part of any deliverables of PWP eGIS program currently undertaken by MWH
'This script is given to help PWP resizing large scanned images for free.
'Neither John Zhou, personally or MWH as a company is responsible for any damage caused by using this script.
'PWP should use this script at their own risk and discreetion.
'depending the amount file to be proceessed, it may take minutes to hours to run the script. Be patient.
'Need ImageMagick installed to run the script http://www.imagemagick.org/script/binary-releases.php#windows
Option Explicit 'This is to ensure no variable is used without defintion.
On Error Resume Next
Dim img 'ImageMagick object
Dim inputdir 'original directory
Dim inputfld ' file collection in the original folder
Dim outputdir 'destination directory
Dim outputfld 'file collection in the destination folder
Dim fso 'filesystem object
Dim f 'file object
Dim tnSize 'scale size
Dim nFileSize 'largest file size to be resized
inputdir = "d:\water\" 'This is the directory where the original files/images located
outputdir = "d:\water\"'This is the directory where the resized images will be located
'define how big the thumbnail should be
tnSize = "50%" 'default to reduce 1/4 size of original, it can be changed
nFileSize = 100000000 ' default only file larger than 100 Mega need to be resized
Set img = CreateObject("ImageMagickObject.MagickImage.1") 'Create a ImageMagick Object
Set fso = CreateObject("Scripting.FileSystemObject") 'Create a File System Object
Set inputfld = fso.GetFolder(inputdir).Files 'Get all files in the original folder
Set outputfld = fso.GetFolder(outputdir).Files 'Get all files in the destination folder
'reads all files in input dir, resizes them and copies them into output dir
'OPTIONS FOR CONVERT FUNCTION (taken from http://imagemagick.org/script/command-line-options.php):
'
'-resize width{%}{@} {!} {<} {>}
'resize an image.
'By default, the width and height are maximum values. That is, the image is expanded or contracted to fit the width and height value while maintaining the aspect ratio of the image. Append an exclamation point to the geometry to force the image size to exactly the size you specify. For example, if you specify 640x480! the image width is set to 640 pixels and height to 480.
'If only the width is specified, the width assumes the value and the height is chosen to maintain the aspect ratio of the image. Similarly, if only the height is specified (e.g., -resize x256, the width is chosen to maintain the aspect ratio.
'To specify a percentage width or height instead, append %. The image size is multiplied by the width and height percentages to obtain the final image dimensions. To increase the size of an image, use a value greater than 100 (e.g. 125%). To decrease an image's size, use a percentage less than 100.
'Use @ to specify the maximum area in pixels of an image.
'Use <> resizes the image only if both of its dimensions are less than the geometry specification. For example, if you specify 640x480 and the image size is 256x256, the image size does not change. However, if the image is 512x512 or 1024x1024, it is resized to 480x480. Enclose the geometry specification in quotation marks to prevent the <> from being interpreted by your shell as a file redirection.
'if the -filter option precedes the -resize option, the image is resized with the specified filter.
'If the -support option precedes the -resize option, the image is resized with the specified support.
For Each f In inputfld 'for each file in the original file folder
'if and only if there is no "resized" image in the destination folder (avoid redudant work) and the original file size is larger than nFileSize
If Not fso.fileexists(outputdir & fso.GetBaseName(f) & "_resize." & fso.GetExtensionName(f)) and f.Size > nFileSize Then
' Use ImageMagick's Convert function to resize and add "_resize" at the end of original file name
rs = img.Convert("-quiet","-resize",tnSize,inputdir & f.Name,outputdir & fso.GetBaseName(f) & "_resize." & fso.GetExtensionName(f))
End If
Next
WScript.Echo "Done" 'tell the user the file is done
Set img=Nothing
Monday, February 18, 2008
Reverse Selection Set
I created this short script to switch selectionset for all layers in one map. It may have no generic value, but it does demonstrate the selectionset interface.
Sub SwitchSelection()
Dim pMxDoc As IMxDocument
Dim pMap As IMap
Dim pLayer As ILayer
Set pMxDoc = ThisDocument
Set pMap = pMxDoc.ActiveView
Dim pFLayer As IFeatureLayer
Dim pEnumLayer As IEnumLayer
Set pEnumLayer = pMap.Layers
Set pLayer = pEnumLayer.Next
Do While Not pLayer Is Nothing
If TypeOf pLayer Is IFeatureLayer Then
Set pFLayer = pLayer
Dim pFSel As IFeatureSelection
Set pFSel = pFLayer
Dim pSelFeats As ISelectionSet
Set pSelFeats = pFSel.SelectionSet
Dim pAllFeats As ISelectionSet
Set pAllFeats = pFLayer.FeatureClass.Select(Nothing, esriSelectionTypeIDSet, esriSelectionOptionNormal, Nothing)
Dim pNewSel As ISelectionSet
pAllFeats.Combine pSelFeats, esriSetDifference, pNewSel
Set pFSel.SelectionSet = pNewSel
End If
Set pLayer = pEnumLayer.Next
Loop
pMxDoc.ActiveView.Refresh
Sub SwitchSelection()
Dim pMxDoc As IMxDocument
Dim pMap As IMap
Dim pLayer As ILayer
Set pMxDoc = ThisDocument
Set pMap = pMxDoc.ActiveView
Dim pFLayer As IFeatureLayer
Dim pEnumLayer As IEnumLayer
Set pEnumLayer = pMap.Layers
Set pLayer = pEnumLayer.Next
Do While Not pLayer Is Nothing
If TypeOf pLayer Is IFeatureLayer Then
Set pFLayer = pLayer
Dim pFSel As IFeatureSelection
Set pFSel = pFLayer
Dim pSelFeats As ISelectionSet
Set pSelFeats = pFSel.SelectionSet
Dim pAllFeats As ISelectionSet
Set pAllFeats = pFLayer.FeatureClass.Select(Nothing, esriSelectionTypeIDSet, esriSelectionOptionNormal, Nothing)
Dim pNewSel As ISelectionSet
pAllFeats.Combine pSelFeats, esriSetDifference, pNewSel
Set pFSel.SelectionSet = pNewSel
End If
Set pLayer = pEnumLayer.Next
Loop
pMxDoc.ActiveView.Refresh
Setting Definition Queries for all layers
I just need to set definition query for all layers in one map. This script is just to demonstrate how to navigate layers in one map and the IFeatureLayerDefinition interface. I actually can write the "dropdown" box for PWP's feederID.
Sub SetDQ()
Dim pMxDoc As IMxDocument
Dim pMap As IMap
Dim pLayer As ILayer
Set pMxDoc = ThisDocumentSet
pMap = pMxDoc.ActiveView
Dim pFLayerDef As IFeatureLayerDefinition
Dim pEnumLayer As IEnumLayer
Set pEnumLayer = pMap.Layers
Set pLayer = pEnumLayer.Next
Do While Not pLayer Is Nothing
If TypeOf pLayer Is IFeatureLayer Then
Set pFLayerDef = pLayer
pFLayerDef.DefinitionExpression = "DELIVERY ='5'"
End If
Set pLayer = pEnumLayer.Next
Loop
pMxDoc.ActivatedView.Refresh
End Sub
Sub SetDQ()
Dim pMxDoc As IMxDocument
Dim pMap As IMap
Dim pLayer As ILayer
Set pMxDoc = ThisDocumentSet
pMap = pMxDoc.ActiveView
Dim pFLayerDef As IFeatureLayerDefinition
Dim pEnumLayer As IEnumLayer
Set pEnumLayer = pMap.Layers
Set pLayer = pEnumLayer.Next
Do While Not pLayer Is Nothing
If TypeOf pLayer Is IFeatureLayer Then
Set pFLayerDef = pLayer
pFLayerDef.DefinitionExpression = "DELIVERY ='5'"
End If
Set pLayer = pEnumLayer.Next
Loop
pMxDoc.ActivatedView.Refresh
End Sub
Subscribe to:
Posts (Atom)