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
أكثر...
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
أكثر...