Skip to content

Instantly share code, notes, and snippets.

@pyRobShrk
Created May 4, 2018 15:54
Show Gist options
  • Save pyRobShrk/17d85ce19b609725484da7085ab11503 to your computer and use it in GitHub Desktop.
Save pyRobShrk/17d85ce19b609725484da7085ab11503 to your computer and use it in GitHub Desktop.
This module adds text to a free-form Excel line or polygon, which shows the length or area of that drawing in inches
Sub CalcLength()
'Subroutine calculates the distance of straight line or "scribble" line
'It has not been tested in any other Office software, but it should work with minor modification
'By Rob Sherrick, 4/12/2018
Dim dpi As Integer
dpi = Application.InchesToPoints(1)
Length = 0
A = 1
On Error Resume Next
If TypeName(Selection) = "Drawing" Then
With Selection.ShapeRange
For Each nd In .Nodes
If nd.EditingType = msoEditingAuto Then
If A = 1 Then
FirstPt = nd.Points
A = A + 1
Else
Length = Length + pythagDist(FirstPt, nd.Points)
FirstPt = nd.Points
End If
End If
Next nd
Length = Round(Length / dpi, 2)
.TextFrame2.TextRange.Characters.Text = Length & " in"
.TextFrame2.VerticalAnchor = msoAnchorMiddle
.TextFrame2.HorizontalAnchor = msoAnchorCenter
End With
ElseIf TypeName(Selection) = "Line" Then
Length = Sqr((Selection.Width) ^ 2 + (Selection.Height) ^ 2)
Length = Round(Length / dpi, 2)
ActiveSheet.Shapes.AddLabel(msoTextOrientationHorizontal, Selection.Left + Selection.Width / 2, _
Selection.Top + Selection.Height / 2, 72, 72).Select
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = Length & " in"
End If
End Sub
Function pythagDist(pt1, pt2) As Double
pythagDist = Sqr((pt1(1, 1) - pt2(1, 1)) ^ 2 + (pt1(1, 2) - pt2(1, 2)) ^ 2)
End Function
Sub CalcArea()
'Subroutine calculates the area of a selected "Freeform" polygon in Excel
'You must click each point of the polygon, and it must close
'When you click and drag it makes curves which won't be accurate
'If you click the points counter-clockwise the result will be negative (but still correct)
'It has not been tested in any other Office software, but it should work with minor modification
'By Rob Sherrick, 5/14/2015
Dim dpi As Integer
dpi = Application.InchesToPoints(1)
AreaSum = 0
A = 1
If TypeName(Selection) = "Drawing" Then
With Selection.ShapeRange
For Each nd In .Nodes
If A = 1 Then
FirstPt = nd.Points
XY1 = FirstPt
Else
XY2 = nd.Points
If A = .Count Then
AreaSum = AreaSum + (XY1(1, 1) * XY2(1, 2) - XY1(1, 2) * XY2(1, 1)) / 2
AreaSum = AreaSum + (XY2(1, 1) * FirstPt(1, 2) - XY2(1, 2) * FirstPt(1, 1)) / 2
Else
AreaSum = AreaSum + (XY1(1, 1) * XY2(1, 2) - XY1(1, 2) * XY2(1, 1)) / 2
XY1 = XY2
End If
End If
A = A + 1
Next nd
AreaSum = Round(AreaSum / dpi ^ 2, 3)
.TextFrame2.TextRange.Characters.Text = "Area = " & AreaSum & "in²"
.TextFrame2.VerticalAnchor = msoAnchorMiddle
.TextFrame2.HorizontalAnchor = msoAnchorCenter
End With
End If
End Sub
@pyRobShrk
Copy link
Author

These functions can be used to make measurements on top of images. For example, you could have a rudimentary area or length calculation from an image of a published map. By scaling the image to 100%, and using the scale bar, it may be possible to convert the inches into a real length or area.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment