Take the 2-minute tour ×
Geographic Information Systems Stack Exchange is a question and answer site for cartographers, geographers and GIS professionals. It's 100% free, no registration required.

so i have a point shapefile. I made a button that finds the best fit line for selected points and calculates the azimuth of it (Zero degrees being the east)

is there a way i can add something to the code so that it edit a field in the attributes table of the shapefile and put the azimuth value for the selected points ??? P.S I am using arcmap 9.3 this is the code im using :

Private Sub UIButtonControl1_Click()

Dim pMxDoc As IMxDocument
Dim pFtrLyr As IFeatureLayer

    Set pMxDoc = ThisDocument
    ' Check we have a featurelayer selected
    'If Not (TypeOf pMxDoc.SelectedLayer Is IFeatureLayer) Then
    If (pMxDoc.SelectedLayer Is Nothing) Then
        MsgBox "Please Select a Point Layer", vbExclamation, "Nothing Is Selected"
        Exit Sub
    End If

    ' Check we have a point layer selected
    Set pFtrLyr = pMxDoc.SelectedLayer
    If pFtrLyr.FeatureClass.ShapeType <> esriGeometryPoint Then
        MsgBox "Please Select a Point Layer", vbExclamation, "Wrong Layer Type"
        Exit Sub
    End If

    ' Create the line
    LeastSquaresLine pFtrLyr

End Sub


Private Sub LeastSquaresLine(pFtrLyr As IFeatureLayer)
' Calculates a line of best fit for all points in the specified layer
' Uses the "Least-Squares" method
Dim pFtrCls As IFeatureClass
Dim pFtrCsr As IFeatureCursor
Dim pFtr As IFeature
Dim pPt As IPoint
Dim pFeatureSelection As IFeatureSelection

Dim pSelectionSet As ISelectionSet

Dim dX As Double, dY As Double
'
Dim N As Double                     ' No. of points
Dim Ax As Double, Ay As Double      ' Average X and Y coordinate
Dim Sx As Double                    ' Standard Deviation for X coords
Dim Sxx As Double, Sxy As Double    ' Used to determine slope
Dim m As Double, b As Double        ' Slope and Y intercept of line
Dim Zxy As Double                   ' Holds sum of X*Y values
Dim Pi As Double
Dim Az As Double
Dim cc As Double
cc = 0
Set pFtrCls = pFtrLyr.FeatureClass
Set pFeatureSelection = pFtrLyr

Set pSelectionSet = pFeatureSelection.SelectionSet
pSelectionSet.Search Nothing, False, pFtrCsr
    ' Loop thru points and calculate averages and sum of X*Y
   ' Set pFtrCsr = pFtrCls.Search(Nothing, False)
    Set pFtr = pFtrCsr.NextFeature

 '   N = pFtrCls.FeatureCount(Nothing)
    While Not pFtr Is Nothing
        Set pPt = pFtr.Shape
        X = pPt.X
        Y = pPt.Y
        Ax = Ax + X
        Ay = Ay + Y
        Zxy = Zxy + X * Y
        cc = cc + 1
        Set pFtr = pFtrCsr.NextFeature

    Wend
    Set pFtrCsr = Nothing
    Ax = Ax / cc
    Ay = Ay / cc

    ' Loop thru points again to calculate Standard Deviation of X coords
   ' Set pFtrCsr = pFtrCls.Search(Nothing, False)
    Set pFtrCls = pFtrLyr.FeatureClass
Set pFeatureSelection = pFtrLyr

Set pSelectionSet = pFeatureSelection.SelectionSet
pSelectionSet.Search Nothing, False, pFtrCsr
    Set pFtr = pFtrCsr.NextFeature
    While Not pFtr Is Nothing
        Set pPt = pFtr.Shape
        X = pPt.X
        Y = pPt.Y
        Sx = Sx + (X - Ax) ^ 2
        Set pFtr = pFtrCsr.NextFeature
    Wend
    Set pFtrCsr = Nothing
    If cc = 1 Then
    MsgBox "Please select more than one point", vbExclamation, "ERROR"
    Exit Sub
    End If

    Sx = Sqr(Sx / (cc - 1))

    Sxx = (cc - 1) * (Sx ^ 2)
    Sxy = Zxy - (cc * Ax * Ay)

    ' Calculate Slope and Y intercept
    m = Sxy / Sxx
    b = Ay - (m * Ax)
    Pi = 4 * Atn(1)
    Az = Atn(m) * 180 / Pi
    Az = Round(Az, 3)

MsgBox "Azimuth is : " & Az & " Degrees, Based on " & cc & " Points", vbInformation, "Azimuth"

Dim pGeoDS As IGeoDataset
Dim dLLx As Double, dLLy As Double
Dim dURx As Double, dURy As Double

    ' Calculate end points of line based on extents of layer
    Set pGeoDS = pFtrLyr
    With pGeoDS.Extent
        dLLx = .XMin - (.Width / 10)
        dURx = .XMax + (.Width / 10)
    End With

    dLLy = m * dLLx + b
    dURy = m * dURx + b

    ' Draw the line as a graphic element
    DrawLine dLLx, dLLy, dURx, dURy

End Sub


Private Sub DrawLine(dLLx As Double, dLLy As Double, dURx As Double, dURy As Double)
' Draws a graphic element with the specified coords
Dim pMxDoc As IMxDocument
Dim pPLine As IPointCollection
Dim pPt As IPoint
Dim pLineEl As ILineElement
Dim pEl As IElement
Dim pLineSym As ISimpleLineSymbol
Dim pRGB As IRgbColor

    ' Create the polyline from the coords
    Set pPLine = New Polyline
    Set pPt = New Point
    pPt.PutCoords dLLx, dLLy
    pPLine.AddPoint pPt
    Set pPt = New Point
    pPt.PutCoords dURx, dURy
    pPLine.AddPoint pPt

    ' Create a symbol colour
    Set pRGB = New RgbColor
    pRGB.RGB = vbRed

    ' Create a line symbol
    Set pLineSym = New SimpleLineSymbol
    pLineSym.Color = pRGB
    pLineSym.Style = esriSLSSolid
    pLineSym.Width = 2

    ' Create a line element
    Set pLineEl = New LineElement
    pLineEl.Symbol = pLineSym
    Set pEl = pLineEl
    pEl.Geometry = pPLine

    ' Add the line element to the active view and refresh
    Set pMxDoc = ThisDocument
    pMxDoc.ActiveView.GraphicsContainer.AddElement pEl, 0
    pMxDoc.ActiveView.PartialRefresh esriViewGraphics, Nothing, Nothing



End Sub
share|improve this question
    
What your code does it to add the line as a graphic to the dataView. DO you want to create a new Polyline featureClass and add the line + Azimuth Value to this featureclass, or do you want to add the Values to the points featureClass? –  Devdatta Tengshe Dec 3 '10 at 18:44
    
Devdatta, I want it to "add the Values to the points featureClass" but i actually figured it out, and im gonna put the new code as an answer now –  ammar Dec 3 '10 at 19:52
    
would you (or someone with admin priveleges be able to edit the formatting? It's tricky to see what is going on here. Also, perhaps removing the unnecessary parts if possible. –  djq Dec 4 '10 at 4:22
add comment

2 Answers

hi all again I was able to find the solution, here is the new code with the answer :

Private Sub UIButtonControl1_Click()

Dim pMxDoc As IMxDocument
Dim pFtrLyr As IFeatureLayer

    Set pMxDoc = ThisDocument
    ' Check we have a featurelayer selected
    'If Not (TypeOf pMxDoc.SelectedLayer Is IFeatureLayer) Then
    If (pMxDoc.SelectedLayer Is Nothing) Then
        MsgBox "Please Select a Point Layer", vbExclamation, "Nothing Is Selected"
        Exit Sub
    End If

    ' Check we have a point layer selected
    Set pFtrLyr = pMxDoc.SelectedLayer
    If pFtrLyr.FeatureClass.ShapeType <> esriGeometryPoint Then
        MsgBox "Please Select a Point Layer", vbExclamation, "Wrong Layer Type"
        Exit Sub
    End If

    ' Create the line
    LeastSquaresLine pFtrLyr

End Sub


Private Sub LeastSquaresLine(pFtrLyr As IFeatureLayer)
' Calculates a line of best fit for all points in the specified layer
' Uses the "Least-Squares" method
Dim pFtrCls As IFeatureClass
Dim pFtrCsr As IFeatureCursor
Dim pFtr As IFeature
Dim pPt As IPoint
Dim pFeatureSelection As IFeatureSelection

Dim pSelectionSet As ISelectionSet

Dim dX As Double, dY As Double
'
Dim N As Double                     ' No. of points
Dim Ax As Double, Ay As Double      ' Average X and Y coordinate
Dim Sx As Double                    ' Standard Deviation for X coords
Dim Sxx As Double, Sxy As Double    ' Used to determine slope
Dim m As Double, b As Double        ' Slope and Y intercept of line
Dim Zxy As Double                   ' Holds sum of X*Y values
Dim Pi As Double
Dim Az As Double
Dim cc As Double
cc = 0


Set pFtrCls = pFtrLyr.FeatureClass
Set pFeatureSelection = pFtrLyr
Set pSelectionSet = pFeatureSelection.SelectionSet
pSelectionSet.Search Nothing, False, pFtrCsr

    ' Loop thru points and calculate averages and sum of X*Y
   ' Set pFtrCsr = pFtrCls.Search(Nothing, False)

Set pFtr = pFtrCsr.NextFeature

 '   N = pFtrCls.FeatureCount(Nothing)

   If pFtr Is Nothing Then
    MsgBox "Please select at least two points, there is nothing selected", vbExclamation, "no points selected"
    Exit Sub
    End If


    While Not pFtr Is Nothing
        Set pPt = pFtr.Shape
        X = pPt.X
        Y = pPt.Y
        Ax = Ax + X
        Ay = Ay + Y
        Zxy = Zxy + X * Y
        cc = cc + 1

        Set pFtr = pFtrCsr.NextFeature

    Wend
    Set pFtrCsr = Nothing
    Ax = Ax / cc
    Ay = Ay / cc

    ' Loop thru points again to calculate Standard Deviation of X coords
   ' Set pFtrCsr = pFtrCls.Search(Nothing, False)
Set pFtrCls = pFtrLyr.FeatureClass
Set pFeatureSelection = pFtrLyr
Set pSelectionSet = pFeatureSelection.SelectionSet
pSelectionSet.Search Nothing, False, pFtrCsr
Set pFtr = pFtrCsr.NextFeature

    While Not pFtr Is Nothing
        Set pPt = pFtr.Shape
        X = pPt.X
        Y = pPt.Y
        Sx = Sx + (X - Ax) ^ 2

       Set pFtr = pFtrCsr.NextFeature

    Wend
    Set pFtrCsr = Nothing
    If cc = 1 Then
    MsgBox "Please select more than one point", vbExclamation, "ERROR"
    Exit Sub
    End If



    Sx = Sqr(Sx / (cc - 1))

    Sxx = (cc - 1) * (Sx ^ 2)
    Sxy = Zxy - (cc * Ax * Ay)

    ' Calculate Slope and Y intercept
    m = Sxy / Sxx
    b = Ay - (m * Ax)
    Pi = 4 * Atn(1)
    Az = Atn(m) * 180 / Pi
    Az = Round(Az, 3)

MsgBox "Azimuth is : " & Az & " Degrees, Based on " & cc & " Points", vbInformation, "Azimuth"
'=================================================
'trial to edit the attributes table so that it takes the angle
Set pFtrCls = pFtrLyr.FeatureClass
Set pFeatureSelection = pFtrLyr
Set pSelectionSet = pFeatureSelection.SelectionSet
pSelectionSet.Search Nothing, False, pFtrCsr
Set pFtr = pFtrCsr.NextFeature

While Not pFtr Is Nothing
pFtr.Value(pFtr.Fields.FindField("Angle")) = Az
pFtr.Store

Set pFtr = pFtrCsr.NextFeature
Wend

'==========================





Dim pGeoDS As IGeoDataset
Dim dLLx As Double, dLLy As Double
Dim dURx As Double, dURy As Double

    ' Calculate end points of line based on extents of layer
    Set pGeoDS = pFtrLyr
    With pGeoDS.Extent
        dLLx = .XMin - (.Width / 10)
        dURx = .XMax + (.Width / 10)
    End With

    dLLy = m * dLLx + b
    dURy = m * dURx + b

    ' Draw the line as a graphic element
    DrawLine dLLx, dLLy, dURx, dURy

End Sub


Private Sub DrawLine(dLLx As Double, dLLy As Double, dURx As Double, dURy As Double)
' Draws a graphic element with the specified coords
Dim pMxDoc As IMxDocument
Dim pPLine As IPointCollection
Dim pPt As IPoint
Dim pLineEl As ILineElement
Dim pEl As IElement
Dim pLineSym As ISimpleLineSymbol
Dim pRGB As IRgbColor

    ' Create the polyline from the coords
    Set pPLine = New Polyline
    Set pPt = New Point
    pPt.PutCoords dLLx, dLLy
    pPLine.AddPoint pPt
    Set pPt = New Point
    pPt.PutCoords dURx, dURy
    pPLine.AddPoint pPt

    ' Create a symbol colour
    Set pRGB = New RgbColor
    pRGB.RGB = vbRed

    ' Create a line symbol
    Set pLineSym = New SimpleLineSymbol
    pLineSym.Color = pRGB
    pLineSym.Style = esriSLSSolid
    pLineSym.Width = 2

    ' Create a line element
    Set pLineEl = New LineElement
    pLineEl.Symbol = pLineSym
    Set pEl = pLineEl
    pEl.Geometry = pPLine

    ' Add the line element to the active view and refresh
    Set pMxDoc = ThisDocument
    pMxDoc.ActiveView.GraphicsContainer.AddElement pEl, 0
    pMxDoc.ActiveView.PartialRefresh esriViewGraphics, Nothing, Nothing



End Sub
share|improve this answer
    
@ammar, thank you for taking the time to share the solution you found with the community. It's people that do that which makes this a great place. :) You're answer would be better if you showed only what was different, where the actual solution lay, rather than block pasting the whole function. You can use a tool like WinMerge (there are others) to create a unified diff or patch file for this purpose. –  matt wilkie Dec 6 '10 at 23:29
    
also to format code so the syntax highlighting and formatting works properly: select the block of text (code) and press [ctrl]-[k] (which indents 4 spaces). –  matt wilkie Dec 6 '10 at 23:32
add comment

this is the part that edits the attribute table :

'=================================================

'trial to edit the attributes table so that it takes the angle

Set pFtrCls = pFtrLyr.FeatureClass

Set pFeatureSelection = pFtrLyr

Set pSelectionSet = pFeatureSelection.SelectionSet

pSelectionSet.Search Nothing, False, pFtrCsr

Set pFtr = pFtrCsr.NextFeature

While Not pFtr Is Nothing

pFtr.Value(pFtr.Fields.FindField("Angle")) = Az

pFtr.Store

Set pFtr = pFtrCsr.NextFeature

Wend

'==========================

share|improve this answer
add comment

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.