YouTube | Facebook | X(Twitter) | RSS


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
  • この記事を書いた人

羽田 康祐

伊達と酔狂のGISエンジニア。GIS上級技術者、Esri認定インストラクター、CompTIA CTT+ Classroom Trainer、潜水士、PADIダイブマスター、四アマ。WordPress は 2.1 からのユーザーで歴だけは長い。 代表著書『地図リテラシー入門―地図の正しい読み方・描き方がわかる』 GIS を使った自己紹介はこちら。ESRIジャパン(株)所属、元青山学院大学非常勤講師を兼務。日本地図学会第31期常任委員。発言は個人の見解です。

-プログラミング, ArcGIS