Attribute VB_Name = "RasterValueCalculator"
Option Explicit
Private m_ipMap As IMap
'==================================================================================
'    title : Æ÷ÀÎÆ® À§Ä¡ÀÇ ·¡½ºÅÍ°ª °è»êÇϱâ
'    2010.01.06
'    author : http://mapplus.textcube.com, mapplus@gmail.com
'==================================================================================

Public Sub CalculateRasterValue()
    Dim ipDoc As IMxDocument
    Set ipDoc = ThisDocument
    Set m_ipMap = ipDoc.FocusMap

    Dim ipFeatureLayer As IFeatureLayer, ipFeatureClass As IFeatureClass
    Dim fieldName As String, idxField As Long, ipField As IField
    Dim ipRasterLayer As IRasterLayer
    
    Set ipFeatureLayer = GetFeatureLayer(m_ipMap, "POINT")
    Set ipRasterLayer = GetRasterLayer(m_ipMap, "DEM")
    
    If (ipFeatureLayer Is Nothing Or ipRasterLayer Is Nothing) Then
        MsgBox "Æ÷ÀÎÆ® ¶Ç´Â ·¡½ºÅÍ ·¹À̾ ¾ø½À´Ï´Ù. È®ÀÎ ¹Ù¶ø´Ï´Ù."
        Exit Sub
    End If
    
    Set ipFeatureClass = ipFeatureLayer.FeatureClass
            
    '1. Çʵ尡 ¾øÀ¸¸é Double Çʵ带 Ãß°¡ÇÔ
    fieldName = "GRID_VALUE"
    AddField ipFeatureClass, fieldName, esriFieldTypeDouble
    
    idxField = ipFeatureClass.FindField(fieldName)
    Set ipField = ipFeatureClass.Fields.Field(idxField)
    
    '2. prepare identify
    Dim ipIdentify As IIdentify, ipRasterIDObj As IRasterIdentifyObj
    Dim ipArray As IArray, rasterValue As Variant
    
    Set ipIdentify = ipRasterLayer
    
    '3. °è»ê
    Dim totalCnt As Long, step As Long
    Dim ipQf As IQueryFilter, ipCursor As IFeatureCursor
    Dim ipFeature As IFeature, ipCurPoint As IPoint
        
    totalCnt = ipFeatureClass.FeatureCount(Nothing)
    
    Set ipQf = New QueryFilter
    ipQf.SubFields = ipFeatureClass.ShapeFieldName & ", " & fieldName
    
    Set ipCursor = ipFeatureClass.Update(ipQf, False)
    Set ipFeature = ipCursor.NextFeature
    Do Until ipFeature Is Nothing
        DoEvents
        Application.StatusBar.Message(0) = step & " / " & totalCnt & " calculated..."
        step = step + 1
        
        rasterValue = 0#
        Set ipCurPoint = ipFeature.ShapeCopy
        
        '·¡½ºÅÍ ·¹À̾îÀÇ °ª °¡Á®¿À±â
        Set ipArray = ipIdentify.Identify(ipCurPoint)
        If (Not ipArray Is Nothing) Then
            If (ipArray.Count > 0) Then
                Set ipRasterIDObj = ipArray.Element(0)
                If (IsNumeric(ipRasterIDObj.Name)) Then
                    rasterValue = ipRasterIDObj.Name
                End If
            End If
        End If
        
        'Çʵå À¯Çü¿¡ ¸Â°Ô °ª È®ÀÎ
        Select Case ipField.Type
            Case esriFieldTypeSmallInteger
                rasterValue = CInt(rasterValue)
            Case esriFieldTypeInteger
                rasterValue = CLng(rasterValue)
            Case esriFieldTypeDouble
                rasterValue = CDbl(rasterValue)
            Case esriFieldTypeString
                rasterValue = CStr(rasterValue)
        End Select
        
        'ÀúÀå
        ipFeature.Value(idxField) = rasterValue
        ipCursor.UpdateFeature ipFeature
        
        Set ipFeature = ipCursor.NextFeature
    Loop
    
    MsgBox "°è»êÀ» ¿Ï·áÇÏ¿´½À´Ï´Ù !"
End Sub

'+++ Get RasterLayer
Private Function GetRasterLayer(ipMap As IMap, layerName As String) As IRasterLayer
    Dim ipEnumLayer As IEnumLayer
    Dim ipLayer As ILayer
    Dim pUid As New UID
    On Error GoTo ErrHand
    
    If ipMap.LayerCount = 0 Then Exit Function
    
    '{6CA416B1-E160-11D2-9F4E-00C04F6BC78E} IDataLayer
    pUid = "{6CA416B1-E160-11D2-9F4E-00C04F6BC78E}"
    Set ipEnumLayer = ipMap.Layers(pUid, True)
    
    ipEnumLayer.Reset
    Set ipLayer = ipEnumLayer.Next
    Do Until ipLayer Is Nothing
        If ipLayer.Valid And TypeOf ipLayer Is IRasterLayer Then
            If UCase(ipLayer.Name) = UCase(layerName) Then
                Set GetRasterLayer = ipLayer
                Exit Function
            End If
        End If
        Set ipLayer = ipEnumLayer.Next
    Loop
    
    Set GetRasterLayer = Nothing
    Exit Function
ErrHand:
    Set GetRasterLayer = Nothing
End Function

'+++ Get FeatureLayer
Private Function GetFeatureLayer(ipMap As IMap, layerName As String) As IFeatureLayer
    Dim ipEnumLayer As IEnumLayer
    Dim ipLayer As ILayer
    Dim pUid As New UID
    On Error GoTo ErrHand
    
    If ipMap.LayerCount = 0 Then Exit Function
    
    '{E156D7E5-22AF-11D3-9F99-00C04F6BC78E} IGeoFeatureLayer
    pUid = "{E156D7E5-22AF-11D3-9F99-00C04F6BC78E}"
    Set ipEnumLayer = ipMap.Layers(pUid, True)
    
    ipEnumLayer.Reset
    Set ipLayer = ipEnumLayer.Next
    Do Until ipLayer Is Nothing
        If ipLayer.Valid Then
            If UCase(ipLayer.Name) = UCase(layerName) Then
                Set GetFeatureLayer = ipLayer
                Exit Function
            End If
        End If
        Set ipLayer = ipEnumLayer.Next
    Loop
    
    Set GetFeatureLayer = Nothing
    Exit Function
ErrHand:
    Set GetFeatureLayer = Nothing
End Function

'+++ Add Field
Private Function AddField(ipTable As ITable, fieldName As String, fieldType As esriFieldType, _
    Optional fieldLength As Long, Optional fieldAlias As String) As Boolean
    
    On Error GoTo ErrHand
    
    If Len(Trim(fieldName)) = 0 Then Exit Function
    
    Dim lPrecision As Long, lScale As Long
    
    Select Case fieldType
        Case esriFieldTypeString
            If IsMissing(fieldLength) Then fieldLength = 50
        Case esriFieldTypeSmallInteger
            If IsMissing(fieldLength) Then fieldLength = 4
            lPrecision = 4
        Case esriFieldTypeInteger
            If IsMissing(fieldLength) Then fieldLength = 9
            lPrecision = 9
        Case esriFieldTypeSingle
            If IsMissing(fieldLength) Then fieldLength = 19
            lPrecision = 19
            lScale = 8
        Case esriFieldTypeDouble
            If IsMissing(fieldLength) Then fieldLength = 38
            lPrecision = 38
            lScale = 8
        Case esriFieldTypeDate
            If IsMissing(fieldLength) Then fieldLength = 8
    End Select
    
    Dim ipField As IField
    Dim ipFieldEdit As IFieldEdit
    
    If ipTable.FindField(fieldName) = -1 Then   'Çʵ尡 ¾øÀ¸¸é Ãß°¡
        Set ipField = New Field
        Set ipFieldEdit = ipField
        
        With ipFieldEdit
            .Editable = True
            .IsNullable = True
            .Name = fieldName
            .Type = fieldType
            .Length = fieldLength
            If Not IsMissing(lPrecision) Then .precision = lPrecision
            If Not IsMissing(lScale) Then .Scale = lScale
            If Len(Trim(fieldAlias)) > 0 Then .AliasName = fieldAlias
            .IsNullable = True
        End With
        
        ipTable.AddField ipField
        AddField = True
    Else
        Set ipField = ipTable.Fields.Field(ipTable.FindField(fieldName))
        If ipField.Editable Then
            AddField = True
        End If
    End If
    
    Exit Function
ErrHand:
    MsgBox "Çʵå Ãß°¡ ¿À·ù : " & vbCrLf & Err.Description
    AddField = False
End Function