面积计算VBA代码myfreemind 问题
能不能没有比例尺的限制啊Subsarea()'计算多边形面积程序OnErrorGoToerr
DimareaobjAsAcadLWPolyline
DimssetAsAcadSelectionSet
DimminpntAsVariant
DimmaxpntAsVariant
Dimareains(0To2)AsDouble'
DimtxtareaAsString
DimtxtinsAsString
DimmsAsString
DimtxtobjAsAcadText
Dimus1AsInteger'比例尺
us1=ThisDrawing.GetVariable("userr1")'取得比例尺Fori=0ToThisDrawing.SelectionSets.Count-1
ThisDrawing.SelectionSets.Item(i).Clear
ThisDrawing.SelectionSets.Item(i).Delete
NextSetsset=ThisDrawing.SelectionSets.Add("sarea")sset.SelectOnScreen
Ifsset.Item(0).Closed=FalseThen
MsgBox"图形不闭合，请检查！"
ExitSub
EndIf
sset.Item(0).GetBoundingBoxminpnt,maxpntareains(0)=(minpnt(0)+maxpnt(0))/2
areains(1)=(minpnt(1)+maxpnt(1))/2
areains(2)=0SelectCaseus1
Case500
txtarea=sset.Item(0).area/4Case1000
txtarea=sset.Item(0).area
Case2000
txtarea=sset.Item(0).area*2
CaseElse
MsgBox"你的比例尺不在可计算之列,请检查你的比例尺"
ExitSubEndSelectms=Format(txtarea/666.6666,"#0.000")
txtarea=Format(txtarea,"#0.000")txtins="S="&txtarea&"平方米="&ms&"亩"Settxtobj=ThisDrawing.ModelSpace.AddText(txtins,areains,5)txtobj.Color=acGreen
'*******************************DimhatchobjAsAcadHatch
DimpnameAsString'阴影名称
DimpypeAsLong'阴影类型
pname="ANSI31"
ptype=0Sethatchobj=ThisDrawing.ModelSpace.AddHatch(ptype,pname,True)
Dimoutloop(0To0)AsAcadEntitySetoutloop(0)=sset.Item(0)hatchobj.AppendOuterLoop(outloop)
hatchobj.Evaluate
err:
ExitSub
EndSub 为什么非要加比例尺呢。
Case 1000<BR>txtarea = sset.Item(0).area<BR>Case 2000<BR>txtarea = sset.Item(0).area * 2<BR> Case Else<BR>'''MsgBox "你的比例尺不在可计算之列,请检查你的比例尺"
txtarea = sset.Item(0).area <BR>''Exit Sub
end sub
是不是这样就行了啊 能不能点他区域内就能得出面积啊。
页:
[1]