YouTube | Facebook | Twitter  Feed


2016/9/1 (木)

Sub CreateAndApplyUVRenderer()
     '** Paste into VBA
     '** Creates a UniqueValuesRenderer and applies it to first layer in the map.
     '** Layer must have "Name" field
     Dim strField1 As String
     Dim strField2 As String
     strField1 = "PREF"
     strField2 = "CITY1"
     Dim pApp As Application
     Dim pDoc As IMxDocument
     Set pDoc = ThisDocument
     Dim pMap As IMap
     Set pMap = pDoc.FocusMap
     Dim pLayer As ILayer
     Set pLayer = pMap.Layer(0)
     Dim pFLayer As IFeatureLayer
     Set pFLayer = pLayer
     Dim pLyr As IGeoFeatureLayer
     Set pLyr = pFLayer
     Dim pFeatCls As IFeatureClass
     Set pFeatCls = pFLayer.FeatureClass
     Dim pQueryFilter As IQueryFilter
     Set pQueryFilter = New QueryFilter 'empty supports: SELECT *
     Dim pFeatCursor As IFeatureCursor
     Set pFeatCursor = pFeatCls.Search(pQueryFilter, False)
     '** Make the color ramp we will use for the symbols in the renderer
     Dim rx As IRandomColorRamp
     Set rx = New RandomColorRamp
     rx.MinSaturation = 20
     rx.MaxSaturation = 40
     rx.MinValue = 85
     rx.MaxValue = 100
     rx.StartHue = 76
     rx.EndHue = 188
     rx.UseSeed = True
     rx.Seed = 43
     '** Make the renderer
     Dim pRender As IUniqueValueRenderer, n As Long
     Set pRender = New UniqueValueRenderer
     pRender.FieldDelimiter = ","                                               '<--追加(複数フィールドを区切る文字列を設定)
     Dim symd As ISimpleFillSymbol
     Set symd = New SimpleFillSymbol
     symd.Style = esriSFSSolid
     symd.Outline.Width = 0.4
     '** These properties should be set prior to adding values
     pRender.FieldCount = 2                                                     '<--変更(個別値分類に使用するフィールド数)
     pRender.Field(0) = strField1
     pRender.Field(1) = strField2                                               '<--変更(複数フィールドによる個別値で使用するフィールド名)
     pRender.DefaultSymbol = symd
     pRender.UseDefaultSymbol = True
     Dim pFeat As IFeature
     n = pFeatCls.FeatureCount(pQueryFilter)
     '** Loop through the features
     Dim i As Integer
     i = 0
     Dim ValFound As Boolean
     Dim NoValFound As Boolean
     Dim uh As Integer
     Dim pFields As IFields
     Dim iField As Integer
     Set pFields = pFeatCursor.Fields
     iField = pFields.FindField(strField1)
     Dim iField2 As Integer                                                     '<--追加(2つめのフィールド名)
     iField2 = pFields.FindField(strField2)                                     '<--追加
     Do Until i = n
         Dim symx As ISimpleFillSymbol
         Set symx = New SimpleFillSymbol
         symx.Style = esriSFSSolid
         symx.Outline.Width = 0.4
         Set pFeat = pFeatCursor.NextFeature
         Dim x As String
         x = pFeat.Value(iField) & pRender.FieldDelimiter & pFeat.Value(iField2) '*new Cory*       '<--変更(複数フィールドによる凡例表示用文字列)
         '** Test to see if we've already added this value
         '** to the renderer, if not, then add it.
         ValFound = False
         For uh = 0 To (pRender.ValueCount - 1)
           If pRender.Value(uh) = x Then
             NoValFound = True
             Exit For
           End If
         Next uh
         If Not ValFound Then
             pRender.AddValue x, strField1 & pRender.FieldDelimiter & strField2, symx              '<--変更(複数フィールドによる個別値を追加[カンマで区切る])
             pRender.Label(x) = x
             pRender.Symbol(x) = symx
         End If
         i = i + 1
     '** now that we know how many unique values there are
     '** we can size the color ramp and assign the colors.
     rx.size = pRender.ValueCount
     rx.CreateRamp (True)
     Dim RColors As IEnumColors, ny As Long
     Set RColors = rx.Colors
     For ny = 0 To (pRender.ValueCount - 1)
         Dim xv As String
         xv = pRender.Value(ny)
         If xv <> "" Then
             Dim jsy As ISimpleFillSymbol
             Set jsy = pRender.Symbol(xv)
             jsy.Color = RColors.Next
             pRender.Symbol(xv) = jsy
         End If
     Next ny
     '** If you didn't use a color ramp that was predefined
     '** in a style, you need to use "Custom" here, otherwise
     '** use the name of the color ramp you chose.
     pRender.ColorScheme = "Custom"
     pRender.fieldType(0) = True
     Set pLyr.Renderer = pRender
     pLyr.DisplayField = strField1 
     '** This makes the layer properties symbology tab show
     '** show the correct interface.
     Dim hx As IRendererPropertyPage
     Set hx = New UniqueValuePropertyPage
     pLyr.RendererPropertyPageClassID = hx.ClassID
     '** Refresh the TOC
     '** Draw the map
End Sub


  • この記事を書いた人

羽田 康祐

Esri認定インストラクター、GIS上級技術者、測量士補、潜水士。GISy / GISc とその関連分野である地理学・地図学について日々の出来事で学んだ記憶を記録するためにブログを書いています。行動原理は伊達と酔狂。好きな地形は圏谷。好きな地図投影法はパースクインカンシャル図法とマクブライドトーマス四次平極図法。広島県呉市生まれ広島市出身。GIS を使った自己紹介はこちら

-プログラミング, ArcGIS

© 2021 WINGFIELD since1981