UTDM Label Field Update Script

Home

GIS Data & Resources

Scripts and Code

Visual Basic / VBA

UTDM Label Field Update Script

Written by AGRC Administrator,

'Two VBA sub procedures to populated the LABEL field in the UTDM. The first one, PopulateLabelField_SDEONLY, is for working in a versioned-SDE environment and should only be used when a small number of label field value changes are expected (a few thousand or so). The second script, PopulateLabelField_NON_SDE(), is for working with a large number of expected label field value changes outside of the SDE versioned environment where the much faster update cursor can be used.

VBA Code:

Public Sub PopulateLabelField_SDEONLY()

    On Error GoTo errorhandler

    Dim pMxDoc As IMxDocument
    Dim pMap As IMap

    Dim pTarLayer As IFeatureLayer
    Dim pTarFeatureClass As IFeatureClass
    Dim pTarFeature As IFeature
    Dim pFLDef As IFeatureLayerDefinition

    Dim pID As New UID
    pID = "esriEditor.Editor"
    Dim pEditor As IEditor
    Set pEditor = Application.FindExtensionByCLSID(pID)

    Set pMxDoc = ThisDocument
    Set pMap = pMxDoc.FocusMap

    Set pTarLayer = pMap.Layer(0) '(Target layer is first layer in TOC)
    Set pTarFeatureClass = pTarLayer.FeatureClass

    Dim pDataset As IDataset
    Dim pWorkspace As IWorkspace
    Set pDataset = pTarFeatureClass 'qi
    Set pWorkspace = pDataset.Workspace

    Dim changecnt As Long

    pEditor.StartEditing pWorkspace
    'Dim pVersion As IVersion
    'Set pVersion = pDataset.Workspace
    'Debug.Print pVersion.VersionName
    'Debug.Print pVersion.VersionInfo.Description

    Dim pqf As IQueryFilter
    Set pqf = New QueryFilter
    Set pFLDef = pTarLayer

    pqf.WhereClause = pFLDef.DefinitionExpression

    Dim pFeatureCursor As IFeatureCursor
    Dim pfeature As IFeature

    'Set pFeatureCursor = pTarFeatureClass.Update(pqf, True)
    Set pFeatureCursor = pTarFeatureClass.Search(pqf, True)
    Set pfeature = pFeatureCursor.NextFeature

    Dim preDirIndex As Integer
    Dim sNameIndex As Integer
    Dim sTypeIndex As Integer
    Dim sufdirindex As Integer
    Dim altnameindex As Integer
    Dim labelIndex As Integer
    Dim acsaliasindex As Integer
    Dim lFIndex As Integer
    Dim lTIndex As Integer
    Dim rFIndex As Integer
    Dim rTIndex As Integer

    preDirIndex = pTarFeatureClass.FindField("PRE_DIR")
    sNameIndex = pTarFeatureClass.FindField("S_NAME")
    sTypeIndex = pTarFeatureClass.FindField("S_TYPE")
    sufdirindex = pTarFeatureClass.FindField("SUF_DIR")
    altnameindex = pTarFeatureClass.FindField("ALT_NAME")
    labelIndex = pTarFeatureClass.FindField("LABEL")
    lFIndex = pTarFeatureClass.FindField("L_F_ADD")
    lTIndex = pTarFeatureClass.FindField("L_T_ADD")
    rFIndex = pTarFeatureClass.FindField("R_F_ADD")
    rTIndex = pTarFeatureClass.FindField("R_T_ADD")
    acsaliasindex = pTarFeatureClass.FindField("ACS_ALIAS")

    Dim predir As String
    Dim sname As String
    Dim stype As String
    Dim sufdir As String
    Dim altname As String
    Dim labelstr As String
    Dim change1 As Boolean
    Dim change2 As Boolean
    Dim change3 As Boolean
    Dim acsAlias As String
    Dim lfrom As Double
    Dim rfrom As Double
    Dim lto As Double
    Dim rto As Double
    Dim cnt As Long
    cnt = 0

    Do Until pfeature Is Nothing

        change1 = False
        labelstr = ""

        If IsNull(pfeature.Value(preDirIndex)) Then
            predir = ""
        Else
            predir = Trim(pfeature.Value(preDirIndex))
        End If

        If IsNull(pfeature.Value(sNameIndex)) Then
            sname = ""
        Else
            sname = Trim(pfeature.Value(sNameIndex))
        End If

        If IsNull(pfeature.Value(sTypeIndex)) Then
            stype = ""
        Else
            stype = Trim(pfeature.Value(sTypeIndex))
        End If

        If IsNull(pfeature.Value(sufdirindex)) Then
            sufdir = ""
        Else
           sufdir = Trim(pfeature.Value(sufdirindex))
        End If

        If IsNull(pfeature.Value(altnameindex)) Then
            altname = ""
        Else
           altname = Trim(pfeature.Value(altnameindex))
        End If



        'USE TO POPULATE LABEL FIELD:

        'Populates LABEL field for Interstates, Highways, Routes
        If sname Like "HIGHWAY*" And Not sufdir = "" Then
            labelstr = Replace(altname, "SR", "HWY") + " " + sufdir

        ElseIf sname Like "HIGHWAY*" And sufdir = "" Then
            labelstr = Replace(altname, "SR", "HWY")

        ElseIf sname Like "HIGHWAY*" And Not sufdir = "" Then
            labelstr = Replace(altname, "SR", "HWY") + " " + sufdir

        ElseIf sname Like "HIGHWAY*" And sufdir = "" Then
            labelstr = Replace(altname, "SR", "HWY")

        'ElseIf sname Like "US-*" And Not sufdir = "" Then
            'labelstr = sname + " " + sufdir

        'ElseIf sname Like "US-*" And sufdir = "" Then
            'labelstr = sname

        'ElseIf sname Like "SR-*" And Not sufdir = "" Then
            'labelstr = sname + " " + sufdir

        'ElseIf sname Like "SR-*" And sufdir = "" Then
            'labelstr = sname

        'ElseIf sname Like "I-*" And Not sufdir = "" Then
            'labelstr = sname + " " + sufdir

        'ElseIf sname Like "I-*" And sufdir = "" Then
            'labelstr = sname

        ElseIf sname Like "INTERSTATE*" And Not stype = "" And Not sufdir = "" Then
            labelstr = Replace(sname, "INTERSTATE", "I-") + " " + stype + " " + sufdir

        ElseIf sname Like "INTERSTATE*" And Not stype = "" And sufdir = "" Then
            labelstr = Replace(sname, "INTERSTATE", "I-") + " " + stype

        'ElseIf sname Like "STATE ROUTE*" And Not sufdir = "" Then
            'labelstr = sname + " " + sufdir

        'ElseIf sname Like "STATE ROUTE*" And sufdir = "" Then
            'labelstr = sname

        'ElseIf sname Like "STATE HIGHWAY*" And Not sufdir = "" Then
            'labelstr = sname + " " + sufdir

        'ElseIf sname Like "STATE HIGHWAY*" And sufdir = "" Then
            'labelstr = sname


        'Populates LABEL field for all other instances
        ElseIf Not sname = "" And Not stype = "" And sufdir = "" Then
            labelstr = sname + " " + stype

        ElseIf Not sname = "" And Not stype = "" And Not sufdir = "" Then
            labelstr = sname + " " + stype + " " + sufdir

        ElseIf Not sname = "" And Not sufdir = "" And stype = "" Then
            labelstr = sname + " " + sufdir

        ElseIf Not sname = "" And stype = "" And sufdir = "" Then
            labelstr = sname

        'ElseIf Not altname = "" And Not sname = "" And stype = "" And sufdir = "" Then
            'labelstr = sname (THIS NEEDS TO BE FIXED OR DELETED)


        End If

        labelstr = UCase(labelstr)
        cnt = cnt + 1
        If pfeature.Value(labelIndex) <> labelstr or isnull(pfeature.Value(labelIndex)) Then
            pfeature.Value(labelIndex) = labelstr
            changecnt = changecnt + 1
            'pFeatureCursor.UpdateFeature pfeature

            pEditor.StartOperation
            pfeature.Store
            pEditor.StopOperation "Label 1 Feature"

'Debug.Print pfeature.OID

            If changecnt / 10 = CInt(changecnt / 10) Then
                Debug.Print changecnt & " / " & cnt
                pEditor.StopEditing True
                pEditor.StartEditing pWorkspace
            End If

        End If

        Set pfeature = pFeatureCursor.NextFeature

    Loop
    pEditor.StopOperation "Label 1 Feature"
    pEditor.StopEditing True
    Debug.Print changecnt & " / " & cnt

    Exit Sub

errorhandler:
Resume Next
End Sub

Public Sub PopulateLabelField_NON_SDE()

    On Error GoTo errorhandler

    Dim pMxDoc As IMxDocument
    Dim pMap As IMap

    Set pMxDoc = ThisDocument
    Set pMap = pMxDoc.FocusMap

    Set pTarLayer = pMap.Layer(0) '(Target layer is first layer in TOC)
    Set pTarFeatureClass = pTarLayer.FeatureClass

    Dim pDataset As IDataset
    Dim pWorkspace As IWorkspace
    Set pDataset = pTarFeatureClass 'qi
    Set pWorkspace = pDataset.Workspace

    Dim changecnt As Long

    'pEditor.StartEditing pWorkspace

    'Dim pVersion As IVersion
    'Set pVersion = pDataset.Workspace
    'Debug.Print pVersion.VersionName
    'Debug.Print pVersion.VersionInfo.Description

    Dim pqf As IQueryFilter
    Set pqf = New QueryFilter
    Set pFLDef = pTarLayer

    pqf.WhereClause = pFLDef.DefinitionExpression

    Dim pFeatureCursor As IFeatureCursor
    Dim pfeature As IFeature

    Set pFeatureCursor = pTarFeatureClass.Update(pqf, True)
    'Set pFeatureCursor = pTarFeatureClass.Search(pqf, True)
    Set pfeature = pFeatureCursor.NextFeature

    Dim preDirIndex As Integer
    Dim sNameIndex As Integer
    Dim sTypeIndex As Integer
    Dim sufdirindex As Integer
    Dim altnameindex As Integer
    Dim labelIndex As Integer
    Dim acsaliasindex As Integer
    Dim lFIndex As Integer
    Dim lTIndex As Integer
    Dim rFIndex As Integer
    Dim rTIndex As Integer

    preDirIndex = pTarFeatureClass.FindField("PRE_DIR")
    sNameIndex = pTarFeatureClass.FindField("S_NAME")
    sTypeIndex = pTarFeatureClass.FindField("S_TYPE")
    sufdirindex = pTarFeatureClass.FindField("SUF_DIR")
    altnameindex = pTarFeatureClass.FindField("ALT_NAME")
    labelIndex = pTarFeatureClass.FindField("LABEL")
    lFIndex = pTarFeatureClass.FindField("L_F_ADD")
    lTIndex = pTarFeatureClass.FindField("L_T_ADD")
    rFIndex = pTarFeatureClass.FindField("R_F_ADD")
    rTIndex = pTarFeatureClass.FindField("R_T_ADD")
    acsaliasindex = pTarFeatureClass.FindField("ACS_ALIAS")

    Dim predir As String
    Dim sname As String
    Dim stype As String
    Dim sufdir As String
    Dim altname As String
    Dim labelstr As String
    Dim change1 As Boolean
    Dim change2 As Boolean
    Dim change3 As Boolean
    Dim acsAlias As String
    Dim lfrom As Double
    Dim rfrom As Double
    Dim lto As Double
    Dim rto As Double
    Dim cnt As Long
    cnt = 0

    Do Until pfeature Is Nothing

        'ElseIf Not altname = "" And Not sname = "" And stype = "" And sufdir = "" Then
            'labelstr = sname (THIS NEEDS TO BE FIXED OR DELETED)


        End If

        labelstr = UCase(labelstr)
        cnt = cnt + 1
        If pfeature.Value(labelIndex) <> labelstr or isnull(pfeature.Value(labelIndex))Then
            pfeature.Value(labelIndex) = labelstr
            changecnt = changecnt + 1
            pFeatureCursor.UpdateFeature pfeature

            'pEditor.StartOperation
            'pfeature.Store
            'pEditor.StopOperation "Label 1 Feature"

'Debug.Print pfeature.OID

            If changecnt / 100 = CInt(changecnt / 100) Then
                Debug.Print changecnt & " / " & cnt
                'pEditor.StopEditing True
                'pEditor.StartEditing pWorkspace
            End If

        End If

        Set pfeature = pFeatureCursor.NextFeature

    Loop
    'pEditor.StopOperation "Label 1 Feature"
    'pEditor.StopEditing True
    Debug.Print changecnt & " / " & cnt

    Exit Sub

errorhandler:
Resume Next
End Sub

Users' Comments

No comment posted

Add your comment

17, Oct. 2007

Last Updated ( 25, Oct. 2007 )

< Prev		Next >

[ Back ]

Main Menu

Registered User Menu

User Login