Scripts written in ArcObject 'For ArcMap Dim pWorkspace As IWorkspace '------------------------------------------------------------------------------ Private Sub main() 'Description: The main part of the ArcMap program '------------------------------------------------------------------------------ Dim pDoc As IMxDocument Dim pMap As IMap Set pDoc = ThisDocument Set pMap = pDoc.FocusMap Dim pTable As ITable Set pTable = Add_DbaseFile("d:\ ", "AE_dbase") 'Add the AE_dbase file to ArcMap Call Add_Table_TOC(pTable, pMap) pDoc.UpdateContents Dim wsNm As String wsNm = pWorkspace.PathName Dim height As Double Call DoComputation1(pMap, pTable, height, "c_0.075km") 'Call DoComputation1 to calculate the extinction coefficient Call DoComputation2(pMap, pTable, height, "c_0.075km") 'Call DoComputation2 to calculate the delta AOT Dim pFeatClass As IFeatureClass Set pFeatClass = CreateShapeFile(wsNm, "OutputShp") 'create an empty shapefile Set pFeatClass = OpenFeatureClass(wsNm, "OutputShp") ...... Dim i As Integer i = pTable.RowCount(Nothing) Call DuplicatePolygons(i, pFeatClass1, pFeatClass) 'Duplicate multiple polygons in shp Call JoinTable(pMap, pFeatClass, "FID", pTable, "OID") 'Call JoinTable to join the dbf to the shp Call ExportShp(pMap, "shp_0.075", wsNm) 'Call Exportshp to export many shps Call ExportShp(pMap, "shp_0.15", wsNm) ...... End Sub '-------------------------------------------------------------------------------- Public Function Add_DbaseFile(FilePath As String, FileName As String) As ITable 'Description: Add dbase file to ArcMap 'Input: FilePath, FileName 'Output: Add_DbaseFile: ITable '--------------------------------------------------------------------------------- Dim pFact As IWorkspaceFactory Dim pFeatws As IFeatureWorkspace Dim pTable As ITable Set pFact = New ShapefileWorkspaceFactory Set pWorkspace = pFact.OpenFromFile(FilePath, 0) Set pFeatws = pWorkspace Set pTable = pFeatws.OpenTable(FileName) Set Add_DbaseFile = pTable Add_Table_TOC pTable End Function '--------------------------------------------------------------------------------- Private Sub Add_Table_TOC(pTable As ITable, pMap As IMap) 'Description: Add dbase file to table of content 'Input: pTable, pMap '---------------------------------------------------------------------------------- 'Create a new standalone table and add it 'to the collection of the focus map Dim pStTab As IStandaloneTable Set pStTab = New StandaloneTable Set pStTab.Table = pTable Dim pStTabColl As IStandaloneTableCollection Set pStTabColl = pMap pStTabColl.AddStandaloneTable pStTab pDoc.UpdateContents End Sub '----------------------------------------------------------------------------------------------- Private Sub DoComputation1(pMap As IMap, pTable As ITable, height As Double, fldName As String) 'Description: Calculate the extinction coefficient at different heights (Equation 2) 'Input: pMap, pTable, height, fldName '------------------------------------------------------------------------------------------------ Dim pFieldA As IFields Dim pFieldB As IFields Dim pCalc As ICalculator Set pCalc = New Calculator Dim pCursor As ICursor Set pCursor = pTable.Update(Nothing, True) With pCalc Set .Cursor = pCursor .Expression = "[ext_coefficient_0]*exp(-height/[scaling_height])" .Field = fldName End With pCalc.Calculate Set pCursor = Nothing End Sub '----------------------------------------------------------------------------------------------- Private Sub DoComputation2(pMap As IMap, pTable As ITable, height As Double, fldName As String) 'Description: Calculate the delta AOT at different heights (Equation 4) 'Input: pMap, pTable, height, fldName '------------------------------------------------------------------------------------------------ Dim pFieldA As IFields Dim pFieldB As IFields Dim pCalc As ICalculator Set pCalc = New Calculator Dim pCursor As ICursor Set pCursor = pTable.Update(Nothing, True) With pCalc Set .Cursor = pCursor .Expression = "[ext_coefficient]*[height]" .Field = fldName End With pCalc.Calculate Set pCursor = Nothing End Sub '---------------------------------------------------------------------------------------------------------------------------- Public Sub JoinTable(pMap As IMap, pFCls As IFeatureClass, strFClsFld As String, pTable As ITable, strTabFld As String) 'Description: Join dbase to the polygon attribute table 'Input: pMap, pFCls, StrFClsFld, pTable, strTabFld '---------------------------------------------------------------------------------------------------------------------------- Dim pDpyRC As IDisplayRelationshipClass Dim pMemRCFact As IMemoryRelationshipClassFactory Dim pRelClass As IRelationshipClass ...... 'Create a relationship class in memory Set pMemRCFact = New MemoryRelationshipClassFactory Set pRelClass = pMemRCFact.Open("JoinTable", pTable, strTabFld, pFCls, strFClsFld, "Forward", "Backward", esriRelCardinalityOneToOne) 'Perform the join pDpyRC.DisplayRelationshipClass pRelClass, esriLeftOuterJoin End Sub '----------------------------------------------------------------------------------- Private Sub ExportShp(pMap As IMap, sFileName As String, wsName As String) 'Description: Export shapefile 'Input: pMap, sFileName, wsName '----------------------------------------------------------------------------------- Dim pFLayer As IFeatureLayer Dim pDataset As IDataset Dim pDSName As IDatasetName Dim pDispTable As IDisplayTable Dim pShapeFCName As IDatasetName Dim pShapeWSF As IWorkspaceFactory Dim pShapeWS As IDataset Dim pShapeWSName As IWorkspaceName Dim pQFilter As IQueryFilter Dim pExportOp As IExportOperation Set pFLayer = pMap.Layer(0) Set pDispTable = pFLayer Set pDataset = pDispTable.DisplayTable Set pDSName = pDataset.FullName Set pShapeWSF = New ShapefileWorkspaceFactory Set pShapeWS = pShapeWSF.OpenFromFile(wsName, 0) Set pShapeWSName = pShapeWS.FullName Set pShapeFCName = New FeatureClassName pShapeFCName.Name = sFileName Set pShapeFCName.WorkspaceName = pShapeWSName Dim strFld As String strFld = "*" Set pQFilter = New QueryFilter pQFilter.WhereClause = "YEARMODA=;20070201; and Time_HH_MM = 05:22:51" pQFilter.SubFields = strFld Set pExportOp = New ExportOperation pExportOp.ExportFeatureClass pDSName, pQFilter, Nothing, Nothing, pShapeFCName, 0 End Sub 'For ArcScene Public color_value As Double '---------------------------------------------------------------- Private Sub main() 'Description: The main part of the ArcScene program '---------------------------------------------------------------- Dim height() As Double height(1) = 0.075 ...... Dim pFeatClass As IFeatureClass Dim i As Integer For i = 1 To 10 Set pFeatClass = OpenFeatureClass("d:\", "shp_" + height(i), "c_" + height(i)) Call ExtrudePolygon(pFeatClass, height(i)) Next i End Sub '------------------------------------------------------------------ Private Sub ExtrudePolygon(pFC As IFeatureClass, height As Double) 'Desciption: Extrude polygons 'Input: pFC '------------------------------------------------------------------ Dim pMap As IMap Dim pFLayer As IFeatureLayer Dim pQFilter As IQueryFilter Dim pFCursor As IFeatureCursor Dim pF As IFeature Dim pPoly As IPolygon Dim pZaware As IZAware, pTopoOp As ITopologicalOperator Dim pgeometry As IGeometry Set pQFilter = New QueryFilter Set pFCursor = pFC.Search(pQFilter, False) Set pF = pFCursor.NextFeature Do Until pF Is Nothing Set pPoly = pF.ShapeCopy Set pF = pFCursor.NextFeature 'Get next feature Loop Set pZaware = pPoly 'Set the polygon Zs Aware pZaware.ZAware = True 'Add the points to the polygon Dim pZ As IZ Set pZ = pPoly pZ.SetConstantZ (0) Dim pMultipatch As IMultiPatch Set pMultipatch = New MultiPatch Dim pMC As IConstructMultiPatch Set pMC = pMultipatch pMC.ConstructExtrudeAbsolute height, pPoly Dim pGLayer As IGraphicsLayer Set pGLayer = AddNew3DGraphicsLayer("3D polygons") Dim pLayerEffects As ILayerEffects Set pLayerEffects = pGLayer pLayerEffects.Transparency = 27 AddGraphic pMultipatch, , , , , pGLayer End Sub '-------------------------------------------------------------------------------- Private Function AssignColor(eType As esriGeometryType) As ISymbol 'Description: Assign different color to display polygons 'Input: eType 'Output: AssignColor :ISymbol '-------------------------------------------------------------------------------- Dim pDefaults As IBasicDocumentDefaultSymbols Dim pSym As ISimpleFillSymbol Dim pSxDoc As ISxDocument Set pSxDoc = Application.Document Set pDefaults = pSxDoc Set pSym = New SimpleFillSymbol Dim pColor As IRgbColor Set pColor = New RgbColor If color_value >= 0 and color_value<=0.01 Then pColor.RGB = RGB(0,0,255) .blue ElseIf jf color_value >=0.011 and color_value <= 0.015 Then pColor.RGB = RGB(0, 255, 255) .aqua ElseIf color_value >=0.016 and color_value <=0.02 Then pColor.RGB = RGB(0, 255, 0) .lime ElseIf color_value >=0.021 and color_value <= 0.025 Then pColorRGB = RBG(255,0,0) .red Else pColorRBG = RBG(255,0,255) .magenta End If Set pSym.Color = pColor Set GetDefaultSymbol = pSym Exit Function End Function