'Get Area 12 version c
'Copyright Nick Wilkinson 2001-2004
'www.isocalc.com

Option Explicit

Private dArea As Double 'By making this private, it is available to the
            'whole class, even when the form is hidden and then reloaded
            
Private userWorldScale As Double

Private Sub bnCalculate_Click()
    If CheckShape() = False Then Exit Sub
    dArea = GetShapeArea()
    Call CalcScaledArea
End Sub
    
Private Sub CalcScaledArea()
    Dim dInvScale As Double
    
    If Val(txtScaleNum.Text) = 0 Then txtScaleNum.Text = "1"
    If Val(txtScaleDen.Text) = 0 Then txtScaleDen.Text = "1"
    
    If chkUseDocScale.Value = False Then
        userWorldScale = Val(txtScaleDen.Text) / Val(txtScaleNum.Text)
        dInvScale = userWorldScale ^ 2
    Else
        dInvScale = (Val(txtScaleDen.Text) / Val(txtScaleNum.Text)) ^ 2
    End If
    
    Select Case coUnits.ListIndex
    Case 0 'mm
        txtArea.Text = Int(dInvScale * dArea)
    Case 1 'cm
        txtArea.Text = Int(dInvScale * dArea) / 100
    Case 2 'm
        txtArea.Text = Int(dInvScale * dArea) / 1000000
    Case 3 'km
        txtArea.Text = Int(dInvScale * dArea) / (10 ^ 12)
    Case 4 'in
        txtArea.Text = Int((dInvScale * dArea / 645.16) * 100) / 100
    Case 5 'ft
        txtArea.Text = Int((dInvScale * dArea / 92903.04) * 10000) / 10000
    Case 6 'yd
        txtArea.Text = Int((dInvScale * dArea / 836127.36) * 1000000) / 1000000
    Case 7 'mi
        Dim dTemp As Double
        dTemp = dInvScale * dArea / 836127.36
        txtArea.Text = Int((dInvScale * dArea / (3097600 * 836127.36)) * (10 ^ 12)) / (10 ^ 12)
    Case Else
        txtArea.Text = Int(dInvScale * dArea)
    End Select
End Sub

Private Sub bnMeasureScale_Click()
    Dim doc As Document, shs As Shapes, sh As Shape
    Dim originalUnit As Long, originalScale As Double
    Dim X1 As Double, Y1 As Double, X2 As Double, Y2 As Double
    Dim paperlength As Double, worldlength As Double, wlst As String, units As Long, temp As String
    Dim worldscale As Double
    
    Set doc = ActiveDocument
    If doc Is Nothing Then Exit Sub
    
    'Check that a valid line is selected
    Set shs = doc.Selection.Shapes
    If shs.Count <> 1 Then
        MsgBox "You must select a straight line of a known 'world' length and try again.", vbExclamation, "IsoCalc.com's Get Area"
        Exit Sub
    End If
    Set sh = shs.Item(1)
    If sh Is Nothing Then Exit Sub
    If sh.Type <> cdrCurveShape Then
        MsgBox "You must select a straight line of a known 'world' length and try again.", vbExclamation, "IsoCalc.com's Get Area"
        Exit Sub
    End If
    If sh.Curve.Segments.Count <> 1 Or sh.Curve.Closed = True Then
        MsgBox "You must select a straight line of a known 'world' length and try again. The line should have only one curve segment (i.e. two nodes)", vbExclamation, "IsoCalc.com's Get Area"
        Exit Sub
    End If

    'Set units to MM and scale to 1:1, but remember the original values
    originalUnit = doc.Unit
    doc.Unit = cdrMillimeter
    originalScale = doc.worldscale
    doc.worldscale = 1
    
    'Calculate the length of the line
    Call sh.Curve.Segments(1).StartNode.GetPosition(X1, Y1)
    Call sh.Curve.Segments(1).EndNode.GetPosition(X2, Y2)
    paperlength = Sqr((X1 - X2) ^ 2 + (Y1 - Y2) ^ 2)
    
    'Set units back to the original values
    doc.Unit = originalUnit
    doc.worldscale = originalScale
    
    'Get the worldlength of the line
    wlst = InputBox("Enter the world-length of the line with the units appended (mm, cm, m, km, in, ft, yd, mi)", "IsoCalc.com's Get Area", "1m")
    worldlength = Val(Trim(wlst))
    If worldlength = 0 Then
        MsgBox "You must give a valid length of the line.", vbExclamation, "IsoCalc.com's Get Area"
        Exit Sub
    End If
    temp = Right(Trim(wlst), 2)
    Select Case temp
    Case "mm"
        units = 0
        worldlength = worldlength
    Case "cm"
        units = 1
        worldlength = worldlength * 10
    Case "km"
        units = 3
        worldlength = worldlength * 1000000
    Case "in"
        units = 4
        worldlength = worldlength * 25.4
    Case "ft"
        units = 5
        worldlength = worldlength * 304.8
    Case "yd"
        units = 6
        worldlength = worldlength * 914.4
    Case "mi"
        units = 7
        worldlength = worldlength * 1609344
    Case Else
        If Right(temp, 1) = "m" Then units = 2
        worldlength = worldlength * 1000
    End Select
    
    'And finally calculate the effective scale of the item
    worldscale = worldlength / paperlength
    
    'And update the correct one depending on whether it's document or user worldscale
    If chkUseDocScale.Value = True Then
        If MsgBox("Do you want to update the document's drawing scale to the measured value?", vbYesNo, "IsoCalc.com's Get Area") = vbYes Then
            doc.worldscale = worldscale
        Else
            userWorldScale = worldscale
            chkUseDocScale = False
        End If
    Else
        userWorldScale = worldscale
    End If
    Call setDocScaleCheckbox(chkUseDocScale, userWorldScale)
End Sub

Private Sub bnPerimeter_Click()
    Dim dInvScale As Double, lPerimeter As Long, stMessage As String
    If Val(txtScaleNum.Text) = 0 Then txtScaleNum.Text = "1"
    If Val(txtScaleDen.Text) = 0 Then txtScaleDen.Text = "1"
    dInvScale = Val(txtScaleDen.Text) / Val(txtScaleNum.Text)
    lPerimeter = CorelScript.GetCurveLength() / 10000
    Select Case coUnits.ListIndex
    Case 0 'mm
        stMessage = Int(dInvScale * lPerimeter) & "mm"
    Case 1 'cm
        stMessage = (Int(dInvScale * lPerimeter) / 10) & "cm"
    Case 2 'm
        stMessage = (Int(dInvScale * lPerimeter) / 1000) & "m"
    Case 3 'm
        stMessage = (Int(dInvScale * lPerimeter) / 10 ^ 6) & "km"
    Case 4 'in
        stMessage = (Int((dInvScale * lPerimeter / 25.4) * 10) / 10) & "in"
    Case 5 'ft
        stMessage = (Int((dInvScale * lPerimeter / 304.8) * 100) / 100) & "ft"
    Case 6 'yd
        stMessage = (Int((dInvScale * lPerimeter / 914.4) * 1000) / 1000) & "yd"
    Case 7 'mi
        stMessage = (Int((dInvScale * lPerimeter / 1609344) * 100000) / 100000) & "mi"
    Case Else
    End Select
    MsgBox "Perimeter = " & stMessage & ".", vbInformation, "Get Perimeter"
End Sub

Private Sub chkUseDocScale_Click()
    Call setDocScaleCheckbox(chkUseDocScale.Value, userWorldScale)
    Call CalcScaledArea
End Sub

Private Sub coUnits_Change()
    Call CalcScaledArea
End Sub

Private Sub txtScaleDen_Change()
    Call CalcScaledArea
End Sub

Private Sub txtScaleNum_Change()
    Call CalcScaledArea
End Sub

Private Function GetShapeArea() As Double
    Dim doc As Document, originalUnit As Long, originalScale As Double
    Dim shs As Shapes, sh As Shape, segs As Segments, seg As Segment
    Dim X1 As Double, Y1 As Double, X2 As Double, Y2 As Double
    
    'Dim nodeCount As Long, nodeCoords(0) As tcoord
    Dim offset As Double
    
    Set doc = ActiveDocument
    If doc Is Nothing Then Exit Function
    
    'Set units to MM and scale to 1:1, but remember the original values
    originalUnit = doc.Unit
    doc.Unit = cdrMillimeter
    originalScale = doc.worldscale
    doc.worldscale = 1
    
    'Get the first shape and all of the curve segments of that shape
    Set sh = doc.Selection.Shapes.Item(1)
    If sh Is Nothing Then Exit Function
    Set segs = sh.Curve.Segments
    If segs.Count = 0 Then Exit Function
    
    'Calculate the area contributed by each segment
    dArea = 0
    For Each seg In segs
        Select Case seg.Type
        Case cdrLineSegment
            dArea = dArea + (seg.StartNode.PositionX * seg.EndNode.PositionY) _
                    - (seg.StartNode.PositionY * seg.EndNode.PositionX)
        Case cdrCurveSegment
            For offset = 0 To 0.9999 Step 0.0001
                Call seg.GetPointPositionAt(X1, Y1, offset)
                Call seg.GetPointPositionAt(X2, Y2, offset + 0.0001)
                dArea = dArea + X1 * Y2 - Y1 * X2
            Next offset
        End Select
    Next seg
    
    'Finish the area calculation and scale it to the correct scale
    GetShapeArea = Abs(dArea / 2) '* originalScale * originalScale

    'Set units back to the original values
    doc.Unit = originalUnit
    doc.worldscale = originalScale
End Function

Private Function CheckShape() As Boolean
    Dim shs As Shapes
    Set shs = ActiveDocument.Selection.Shapes
    If shs.Count <> 1 Then
        MsgBox "You must have just one object selected.", vbExclamation, "Get Shape Area Error"
        Exit Function
    ElseIf shs.Item(1).Type <> cdrCurveShape Then
        MsgBox "The selected object must be a curve, not a rectangle or ellipse. Convert the object to curves before clicking Calculate.", vbExclamation, "Get Shape Area Error"
        Exit Function
    ElseIf shs.Item(1).Curve.Subpaths.Count <> 1 Then
        MsgBox "The selected curve must have only one subpath. Break the curve apart into separate paths.", vbExclamation, "Get Shape Area Error"
        Exit Function
    ElseIf shs.Item(1).Curve.Closed = False Then
        MsgBox "The selected curve must be closed. Close the curve and try again.", vbExclamation, "Get Shape Area Error"
        Exit Function
    Else
        CheckShape = True
    End If
End Function

Private Sub UserForm_Initialize()
    Dim ver As String
    ver = Application.VersionMajor
    coUnits.AddItem "mmІ"
    coUnits.AddItem "cmІ"
    coUnits.AddItem "mІ"
    coUnits.AddItem "kmІ"
    coUnits.AddItem "inІ"
    coUnits.AddItem "ftІ"
    coUnits.AddItem "ydІ"
    coUnits.AddItem "miІ"
    coUnits.ListIndex = CLng(GetSetting("IsoCalc.com", "CorelDRAW " & ver & "\Get Area", "Units", "0"))
    dArea = CDbl(GetSetting("IsoCalc.com", "CorelDRAW " & ver & "\Get Area", "Old Area", "0"))
    'txtScaleNum.Text = GetSetting("IsoCalc.com", "CorelDRAW " & ver & "\Get Area", "Scale Numerator", "1")
    'txtScaleDen.Text = GetSetting("IsoCalc.com", "CorelDRAW " & ver & "\Get Area", "Scale Denominator", "1")
    userWorldScale = GetSetting("IsoCalc.com", "CorelDRAW " & ver & "\Get Area", "User World Scale", "1")
    Call setDocScaleCheckbox((GetSetting("IsoCalc.com", "CorelDRAW " & ver & "\Get Area", "Use Document Scale", "1") = "1"), userWorldScale)
End Sub

Private Sub UserForm_Terminate()
    Dim ver As String
    ver = Application.VersionMajor
    Call SaveSetting("IsoCalc.com", "CorelDRAW " & ver & "\Get Area", "Units", coUnits.ListIndex)
    'Call SaveSetting("IsoCalc.com", "CorelDRAW " & ver & "\Get Area", "Scale Numerator", txtScaleNum.Text)
    'Call SaveSetting("IsoCalc.com", "CorelDRAW " & ver & "\Get Area", "Scale Denominator", txtScaleDen.Text)
    Call SaveSetting("IsoCalc.com", "CorelDRAW " & ver & "\Get Area", "Old Area", dArea)
    Call SaveSetting("IsoCalc.com", "CorelDRAW " & ver & "\Get Area", "User World Scale", userWorldScale)
    Call SaveSetting("IsoCalc.com", "CorelDRAW " & ver & "\Get Area", "Use Document Scale", IIf(chkUseDocScale.Value, "1", "0"))
End Sub

Private Function setDocScaleCheckbox(useDocScale As Boolean, userWorldScale As Double) As Boolean
    Dim worldscale As Double
    If useDocScale = True Then
        chkUseDocScale.Value = 1
        worldscale = ActiveDocument.worldscale
        txtScaleNum.Enabled = False
        txtScaleDen.Enabled = False
    Else
        chkUseDocScale.Value = 0
        worldscale = userWorldScale
        txtScaleNum.Enabled = True
        txtScaleDen.Enabled = True
    End If
    
    If worldscale <= 0 Then Exit Function
    
    If worldscale >= 1 Then
        txtScaleNum.Text = "1"
        txtScaleDen.Text = worldscale
    Else
        txtScaleNum.Text = 1 / worldscale
        txtScaleDen.Text = "1"
    End If
End Function