cdr怎么算曲线周长_CorelDRAW X3计算封闭曲线长度和面积

作为世界最优秀的矢量图形设计软件CorelDRAW X3(最新版)居然没有查询图形周长、面积的功能，然而作为矢量图形设计软件，查询图形几何属性是必不可少的，还好有VBA，给了我们扩展 CorelDRAW X3功能的无限空间，以下就是查询矢量图形几何信息的VBA过程。如果你有Corel Designer 12,   可以在里面找到此功能，将其中的窗体，模块，类模块，导出，再到 CorelDRAW X3 VBA中，把它们导过来，运行“宏”就可以在CorelDRAW X3中运行了，如果没有请看下面宏代码编写过程。

1、启动CorelDRAW X3,新建“图形1”，按“Alt+F11”打开Visual Basic编辑器，添加如下图所示用户窗体，名称为“frmGeometric”：

2、为窗体编写VBA代码，窗体代码全部如下：

Option Explicit

Private CurUnit As Long

Private Lang As New clsLang

Private bPerimeter As Boolean

Private bValidSelection As Boolean

Private bValidArea As Boolean

Private vDepth As Double

Private vLength As Double

Private vArea As Double

Private WithEvents cPrecision As clsIntSpin

Private Sub OnUnitChange(ByVal Unit As Long)

Dim strLength As String

Dim strArea As String

Dim strVolume As String

vDepth = Application.ConvertUnits(vDepth, GetAppUnits(CurUnit), GetAppUnits(Unit))

CurUnit = Unit

UpdateDepth

strLength = GetCurUnitString()

lblUnitLength.Caption = strLength

lblUnitArea.Caption = strLength & GetSquare(False)

lblUnitDepth.Caption = strLength

lblUnitVolume.Caption = strLength & GetCube(False)

UpdateValues

End Sub

Private Sub UpdateDepth()

Updating = Updating + 1

txtDepth.Text = CStr(vDepth)

Updating = Updating - 1

End Sub

Private Function GetCurUnitString() As String

Dim strLength As String

Select Case CurUnit

Case 0

strLength = Lang.GetString(eUnitInch)

Case 1

strLength = Lang.GetString(eUnitMM)

Case 2

strLength = Lang.GetString(eUnitCM)

Case 3

strLength = Lang.GetString(eUnitM)

End Select

GetCurUnitString = strLength

End Function

Private Function GetSquare(ByVal bUnicode As Boolean) As String

Dim s As String

s = ChrW$(178)

If Not bUnicode And Asc(s) = 63 Then

s = "2"

End If

GetSquare = s

End Function

Private Function GetCube(ByVal bUnicode As Boolean) As String

Dim s As String

s = ChrW$(179)

If Not bUnicode And Asc(s) = 63 Then

s = "3"

End If

GetCube = s

End Function

Private Sub cArea_Click()

UpdateControls

End Sub

Private Sub cboUnits_Change()

OnUnitChange cboUnits.ListIndex

End Sub

Private Sub cLength_Click()

UpdateControls

End Sub

Private Sub cmClose_Click()

Unload Me

End Sub

Private Sub cmCopy_Click()

Dim sData As String

Dim oData As New DataObject

sData = GetDataString(False)

If sData <> "" Then

oData.SetText sData

oData.PutInClipboard

End If

End Sub

Private Sub cmCreateText_Click()

Const TextSize As Double = 24 ' 24 pt text

Dim lr As Layer

Dim sData As String

Dim sr As ShapeRange

Dim x As Double, y As Double, w As Double, h As Double

sData = GetDataString(True)

Updating = Updating + 1

If Not ActiveShape Is Nothing And sData <> "" Then

Set sr = ActiveSelectionRange

ActiveShape.GetBoundingBox x, y, w, h

x = x + w / 2

y = y - ActiveDocument.ToUnits(TextSize, cdrPoint)

Set lr = ActiveShape.Layer

If lr.Editable Then Set lr = ActiveLayer

lr.CreateArtisticText x, y, sData, cdrEnglishUS, , "Times New Roman", 24, cdrTrue, cdrTrue, , cdrLeftAlignment

sr.CreateSelection

End If

Updating = Updating - 1

End Sub

Private Sub cmRefresh_Click()

RefreshForm

End Sub

Private Sub cmReset_Click()

vDepth = 0

UpdateDepth

UpdateValues

End Sub

Private Sub cPrecision_Change()

UpdateValues

End Sub

Private Sub cVolume_Click()

UpdateControls

End Sub

Private Sub txtDepth_Ch