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_Change()
Dim s As String
If Updating Then Exit Sub
s = Trim$(txtDepth.Text)
If s <> "" Then
vDepth = Val(Replace(s, ",", "."))
Else
vDepth = 0
End If
UpdateValues
End Sub
Private Sub UserForm_Initialize()
Updating = 0
vDepth = 0
Set cPrecision = New clsIntSpin
cPrecision.Init txtPrecision, spnPrecision, 3, lblPrecision, 0, 5, 1
Me.Caption = Lang.GetString(eFormCaption)
grpLength.Caption = Lang.GetString(eCapPerimeter)
cLength.Caption = Lang.GetString(eCapPerimeter) & ":"
bPerimeter = True
grpArea.Caption = Lang.GetString(eCapArea)
cArea.Caption = Lang.GetString(eCapArea) & ":"
grpVolume.Caption = Lang.GetString(eCapVolume)
lblDepth.Caption = Lang.GetString(eCapDepth) & ":"
cmReset.Caption = Lang.GetString(eBtnReset)
cVolume.Caption = Lang.GetString(eCapVolume) & ":"
cmCreateText.Caption = Lang.GetString(eBtnCreateText)
cmCopy.Caption = Lang.GetString(eBtnCopy)
cmClose.Caption = Lang.GetString(eBtnClose)
cmRefresh.Caption = Lang.GetString(eBtnRefresh)
lblUnits.Caption = Lang.GetString(eCapUnits) & ":"
lblPrecision.Caption = Lang.GetString(eCapPrecision) & ":"
cboUnits.Clear
cboUnits.AddItem Lang.GetString(eStrInch)
cboUnits.AddItem Lang.GetString(eStrMM)
cboUnits.AddItem Lang.GetString(eStrCM)
cboUnits.AddItem Lang.GetString(eStrM)
cboUnits.ListIndex = IIf(Lang.IsMetric(), 1, 0)
RefreshForm
MacroRunning = True
End Sub
Sub RefreshForm()
Dim nSelCount As Long
bValidSelection = False
bValidArea = False
Updating = Updating + 1
On Error GoTo ErrHandler
If Not ActiveDocument Is Nothing Then
nSelCount = ActiveDocument.Selection.Shapes.Count
Select Case nSelCount
Case 0
ShowStatusMessage Lang.GetString(eStrNoSelection)
Case 1
ProcessSelection ActiveShape
Case Else
ShowStatusMessage Lang.GetString(eStrGroupSelected)
End Select
Else
ShowStatusMessage Lang.GetString(eStrNoSelection)
End If
ExitSub:
UpdateControls
Updating = Updating - 1
Exit Sub
ErrHandler:
ShowStatusMessage Lang.GetString(eStrError) & ": " & Err.Description
Resume ExitSub
End Sub
Private Sub EnableTextControl(ByVal Txt As TextBox, ByVal bState As Boolean)
Txt.Enabled = bState
Txt.BackColor = IIf(bState, vbWindowBackground, vbButtonFace)
End Sub
Private Sub UpdateControls()
Dim bEnabled As Boolean
cLength.Enabled = bValidSelection
EnableTextControl txtLength, bValidSelection
lblUnitLength.Enabled = bValidSelection
cArea.Enabled = bValidArea
EnableTextControl txtArea, bValidArea
lblUnitArea.Enabled = bValidArea
lblDepth.Enabled = bValidArea
EnableTextControl txtDepth, bValidArea
lblUnitDepth.Enabled = bValidArea
cmReset.Enabled = bValidArea
cVolume.Enabled = bValidArea
EnableTextControl txtVolume, bValidArea
lblUnitVolume.Enabled = bValidArea
bEnabled = bValidSelection
If bEnabled Then
bEnabled = cLength.Value <> 0
If bValidArea And Not bEnabled Then
bEnabled = cArea.Value <> 0 Or cVolume.Value <> 0
End If
End If
cmCreateText.Enabled = bEnabled
cmCopy.Enabled = bEnabled
End Sub
Private Sub ProcessSelection(ByVal s As Shape)
If s.Type = cdrGroupShape Then
ShowStatusMessage Lang.GetString(eStrGroupSelected)
ElseIf s.IsSimpleShape And s.Type <> cdrTextShape Then
ProcessCurve s.DisplayCurve
Else
ShowStatusMessage Lang.GetString(eStrInvalidObject)
End If
End Sub
Private Function CheckSubpaths(ByVal crv As Curve) As Boolean
Dim bRet As Boolean
Dim n As Long
bRet = True
If crv.SubPaths.Count <> 1 Then
For n = 2 To crv.SubPaths.Count
If crv.SubPaths(n).Nodes.Count > 1 Then
bRet = False
Exit For
End If
Next n
End If
CheckSubpaths = bRet
End Function
Private Sub ProcessCurve(ByVal crv As Curve)
Dim v As Double
Dim bClearStatus As Boolean
Dim bClosed As Boolean
bClosed = crv.SubPaths(1).Closed
bClearStatus = True
bValidArea = bClosed And CheckSubpaths(crv)
If bValidArea Then
grpLength.Caption = Lang.GetString(eCapPerimeter)
cLength.Caption = Lang.GetString(eCapPerimeter) & ":"
bPerimeter = True
Else
grpLength.Caption = Lang.GetString(eCapLength)
cLength.Caption = Lang.GetString(eCapLength) & ":"
bPerimeter = False
End If
bValidSelection = True
vLength = crv.Length
If bValidArea Then
vArea = calcShapeArea(crv.SubPaths(1))
Else
vArea = 0
If bClosed Then
ShowStatusMessage Lang.GetString(eStrMultipathCurve)
Else
ShowStatusMessage Lang.GetString(eStrCurveOpen)
End If
bClearStatus = False
End If
If bClearStatus Then ClearStatusMessage
UpdateValues
End Sub
Private Sub UpdateValues()
Dim v As Double
txtLength.Text = FormatValue(GetLength(vLength))
If bValidArea Then
v = GetArea(vArea)
txtArea.Text = FormatValue(v)
txtVolume.Text = FormatValue(v * vDepth)
Else
txtArea.Text = ""
txtVolume.Text = ""
End If
End Sub
Private Function FormatValue(ByVal v As Double) As String
Dim sFormat As String
sFormat = "0"
If cPrecision.GetValue() > 0 Then
sFormat = "0." & String$(cPrecision.GetValue(), "0")
End If
FormatValue = Format$(v, sFormat)
End Function
Private Function GetAppUnits(ByVal vUnit As Long) As cdrUnit
Dim tUnit As cdrUnit
Select Case CurUnit
Case 1
tUnit = cdrMillimeter
Case 2
tUnit = cdrCentimeter
Case 3
tUnit = cdrMeter
Case Else
tUnit = cdrInch
End Select
GetAppUnits = tUnit
End Function
Private Function GetLength(ByVal v As Double) As Double
If ActiveDocument Is Nothing Then
GetLength = 0
Else
GetLength = ActiveDocument.FromUnits(v, GetAppUnits(CurUnit)) * ActiveDocument.WorldScale
End If
End Function
Private Function GetArea(ByVal v As Double) As Double
GetArea = GetLength(GetLength(v))
End Function
Private Function calcShapeArea(ByVal sp As SubPath) As Double
Dim cx As New Collection
Dim cy As New Collection
Dim seg As Segment
Dim n As Long
Dim x As Double, y As Double
Dim Area As Double
Dim nPts As Long
sp.StartNode.GetPosition x, y
cx.Add x
cy.Add y
For Each seg In sp.Segments
If seg.Type = cdrCurveSegment Then
For n = 1 To 49
seg.GetPointPositionAt x, y, n / 50
cx.Add x
cy.Add y
Next n
End If
seg.EndNode.GetPosition x, y
cx.Add x
cy.Add y
Next seg
Area = 0
For n = 1 To cx.Count - 1
Area = Area + cx(n) * cy(n + 1) - cy(n) * cx(n + 1)
Next
calcShapeArea = Abs(Area / 2)
End Function
Private Sub ShowStatusMessage(ByVal msg As String)
lblStatusBar.Caption = msg
End Sub
Private Sub ClearStatusMessage()
lblStatusBar.Caption = ""
End Sub
Private Sub UserForm_Terminate()
MacroRunning = False
End Sub
Private Function GetDataString(ByVal bUnicode As Boolean)
Dim s As String
s = ""
If bValidSelection Then
If cLength.Value Then
If bPerimeter Then
s = Lang.GetString(eCapPerimeter)
Else
s = Lang.GetString(eCapLength)
End If
s = s & " = " & txtLength.Text & " " & GetCurUnitString()
End If
If bValidArea Then
If cArea.Value Then
If s <> "" Then s = s & vbCrLf
s = s & Lang.GetString(eCapArea) & " = " & txtArea.Text & " " & GetCurUnitString() & GetSquare(bUnicode)
End If
If cVolume.Value Then
If s <> "" Then s = s & vbCrLf
s = s & Lang.GetString(eCapVolume) & " = " & txtVolume.Text & " " & GetCurUnitString() & GetCube(bUnicode)
End If
End If
End If
GetDataString = s
End Function
3、添加模块，名称为“Information”，代码如下：
Option Explicit
Public MacroRunning As Boolean
Public Updating As Long
Public Sub Dialog()
EventsEnabled = True
frmGeoMetric.Show vbModeless
End Sub
4、添加三个类模块：
（1）名称为clsIntSpin，代码如下：
Option Explicit
Public Event Change()
'================= Private Data =================
Private WithEvents cTxt As TextBox
Private WithEvents cSpin As SpinButton
Private Updating As Long
Private Value As Long
Private lLabel As Label
Private Digits As Long
'================= Interface ================
Public Sub Init(Txt As TextBox, Spin As SpinButton, ByVal v As Long, Optional CtlLabel As Label, Optional ByVal nMin As Long = 0, Optional ByVal nMax As Long = 2147483647, Optional ByVal nStep As Long = 1, Optional ByVal NumDigits As Long)
If v < nMin Then v = nMin
If v > nMax Then v = nMax
Value = v
Set cTxt = Txt
Set cSpin = Spin
Set lLabel = CtlLabel
BeginUpdate
If NumDigits > 0 Then
Digits = NumDigits
Else
Digits = 1
End If
cTxt.Value = FormatValue(Value)
With cSpin
.Min = nMin
.Max = nMax
.SmallChange = nStep
.Value = Value
End With
EndUpdate
End Sub
Public Function OnTextExit() As Boolean
Dim n As Long
OnTextExit = False
If Updating = 0 Then
n = GetTextValue()
BeginUpdate
If cSpin.Value <> n Then
cSpin.Value = n
Value = n
OnTextExit = True
RaiseEvent Change
Else
cTxt.Value = FormatValue(n)
End If
EndUpdate
End If
End Function
Public Sub SetValue(ByVal nVal As Long)
BeginUpdate
With cSpin
If nVal < .Min Then nVal = .Min
If nVal > .Max Then nVal = .Max
.Value = nVal
End With
Value = nVal
cTxt.Value = FormatValue(nVal)
EndUpdate
End Sub
Public Function GetValue() As Long
GetValue = Value
End Function
Public Sub Enable(ByVal bState As Boolean)
If Not lLabel Is Nothing Then lLabel.Enabled = bState
cTxt.Locked = Not bState
cTxt.TabStop = bState
cTxt.BackColor = IIf(bState, vbWindowBackground, vbButtonFace)
cTxt.ForeColor = IIf(bState, vbWindowText, vbButtonShadow)
cSpin.Enabled = bState
End Sub
Public Sub SetMaxRange(ByVal nVal)
BeginUpdate
If Value > nVal Then
Value = nVal
cSpin.Value = nVal
cTxt.Value = FormatValue(nVal)
End If
cSpin.Max = nVal
EndUpdate
End Sub
Public Sub SetMinRange(ByVal nVal)
BeginUpdate
If Value < nVal Then
Value = nVal
cSpin.Value = nVal
cTxt.Value = FormatValue(nVal)
End If
cSpin.Min = nVal
EndUpdate
End Sub
'================ Helper Functions ==============
Private Sub BeginUpdate()
Updating = Updating + 1
End Sub
Private Sub EndUpdate()
Updating = Updating - 1
End Sub
Private Function GetTextValue() As Long
Dim v As Double
v = 0
If Trim$(cTxt.Text) <> "" Then v = Val(cTxt.Text)
If v < CDbl(cSpin.Min) Then v = cSpin.Min
If v > CDbl(cSpin.Max) Then v = cSpin.Max
GetTextValue = CLng(v)
End Function
Private Function FormatValue(ByVal v As Long) As String
Dim s As String
Dim bNegative As Boolean
bNegative = v < 0
s = Trim$(str$(Abs(v)))
If Len(s) < Digits Then
s = Right$(String$(Digits, "0") & s, Digits)
End If
If bNegative Then s = "-" & s
FormatValue = s
End Function
Private Sub Class_Initialize()
Value = 0
End Sub
Private Sub cSpin_Change()
If Updating = 0 Then
BeginUpdate
cTxt.Value = FormatValue(cSpin.Value)
Value = cSpin.Value
RaiseEvent Change
EndUpdate
End If
End Sub
Private Sub cTxt_Change()
Dim n As Long
If Updating = 0 Then
n = GetTextValue()
If cSpin.Value <> n Then
BeginUpdate
cSpin.Value = n
Value = n
EndUpdate
RaiseEvent Change
End If
End If
End Sub
（2）名称为clsLang，代码如下：
Option Explicit
Private colDict As New Collection
Private bMetric As Boolean
Private Sub Class_Initialize()
AddString eFormCaption, "Geometric Information"
AddString eBtnClose, "关闭"
AddString eBtnCopy, "复制"
AddString eBtnCreateText, "创建文本"
AddString eBtnRefresh, "刷新"
AddString eBtnReset, "清零"
AddString eCapArea, "面积"
AddString eCapLength, "长度"
AddString eCapPerimeter, "周长"
AddString eCapVolume, "体积"
AddString eCapDepth, "高度"
AddString eCapUnits, "单位"
AddString eCapPrecision, "精度"
AddString eUnitInch, "in"
AddString eUnitMM, "mm"
AddString eUnitCM, "cm"
AddString eUnitM, "m"
AddString eStrInch, "英寸 (in)"
AddString eStrMM, "毫米 (mm)"
AddString eStrCM, "厘米 (cm)"
AddString eStrM, "米 (m)"
AddString eStrError, "Error"
AddString eStrNoSelection, "未选择任何图形"
AddString eStrGroupSelected, "不支持群组图形，请选择单个图形"
AddString eStrInvalidObject, "无效选择"
AddString eStrCurveOpen, "非闭合图形无法计算面积和体积"
AddString eStrMultipathCurve, "组合图形无法计算面积和体积"
End Sub
Private Sub AddString(ByVal eId As ELangStringID, ByVal s As String)
Dim tPair As New clsLangPair
tPair.eId = eId
tPair.sDef = s
colDict.Add tPair
End Sub
Public Function GetString(ByVal eId As ELangStringID) As String
Dim tPair As clsLangPair
Dim s As String
s = "Str #" & eId
For Each tPair In colDict
If tPair.eId = eId Then
s = tPair.sDef
Exit For
End If
Next tPair
GetString = s
End Function
Public Function IsMetric() As Boolean
IsMetric = bMetric
End Function
（3）名称为clsLangPair，代码如下：
Option Explicit
Public Enum ELangStringID
eFormCaption
eBtnClose
eBtnCopy
eBtnCreateText
eBtnRefresh
eBtnReset
eCapArea
eCapLength
eCapPerimeter
eCapVolume
eCapDepth
eCapUnits
eCapPrecision
eUnitInch
eUnitMM
eUnitCM
eUnitM
eStrInch
eStrMM
eStrCM
eStrM
eStrError
eStrNoSelection
eStrGroupSelected
eStrInvalidObject
eStrCurveOpen
eStrMultipathCurve
End Enum
Public eId As ELangStringID
Public sDef As String
现在一切编写完毕，按F5键运行吧，选中图形，点击程序中“刷新”，“面积”，“体积”等数据立即显示出来，程序运行效果如下图：
