[VBA函数]：大面积土方面积计算

LIJUN4858

:1 在规划测绘中有时会要进行大地块土方面积计算,本人经多次摸索,发现用晓东工具可减轻计算量,但对好多高程数据的输入方法有点慢,请同行试试下面的两个VB函数,从电子表格中输入数据
Sub wz ( )
Char = RTrim(Left(c.Characters.Caption, 256))
If Char < > Empty Then
textStr = ""
For j = 1 To Len(Char)
If c.Characters(j, 1).Font.Underline =
xlUnderlineStyleNone Then
cpt = c.Characters(j, 1).Caption
sonstr = ForeFontStr(c, j)
tempstr = ""
Do While j + 1 < = Len(Char)
sonstr1 = ForeFontStr(c, j + 1)
If sonstr1 = sonstr Then
j = j + 1
tempstr = tempstr + c.Characters(j,
1).Caption
Else
Exit Do
End If
Loop
textStr = textStr + "{" + sonstr + cpt
+ tempstr + "}"
Else
cpt = c.Characters(j, 1).Caption
sonstr = ForeFontStr(c, j)
tempstr = ""
Do While j + 1 < = Len(Char)
sonstr1 = ForeFontStr(c, j + 1)
If sonstr1 = sonstr Then
j = j + 1
tempstr = tempstr + c.Characters(j,
1).Caption
Else
Exit Do
End If
Loop
textStr = textStr + "{L" +
sonstr + cpt + tempstr + "l}"
End If
Next j
End If
End Sub
‘下面函数控制字体本身属性
Function ForeFontStr(m As Range, u As Integer) As String
a1 = "F" + m.Characters(u, 1).Font.Name + ";" ‘字体
a2 = IIf(m.Characters(u, 1).Font.Superscript =
True, "H0.33x;A2;", "") /*上脚标
a3 = IIf(m.Characters(u, 1).Font.Subscript =
True, "H0.33x;A0;", "") /*下脚标
a4 = IIf(m.Characters(u, 1).Font.FontStyle =
"倾斜", "Q18;", "") /*倾斜
a5 = IIf(m.Characters(u, 1).Font.FontStyle =
"加粗", "W1.2;", "") /*加粗
a6 = IIf(m.Characters(u, 1).Font.FontStyle =
"加粗 倾斜", "W1.2;Q18;", "") /* 加粗倾斜
ForeFontStr = a1 + a2 + a3 + a4 + a5 + a6
End Function
Sub kz( )
With textObj ‘文字对象
.Height = textHgt
.Layer = newlayer.Name ‘设置图层
.Color = acRed ‘设置颜色
.DrawingDirection = 1 ‘设置书写方向
If (ma.VerticalAlignment = xlTop _
Or ma.VerticalAlignment = xlGeneral) _
And (ma.HorizontalAlignment = xlLeft _
Or ma.HorizontalAlignment = xlGeneral) _
Then .AttachmentPoint = 1 /*acAttachmentPointTopLeft
If (ma.VerticalAlignment = xlTop _
Or ma.VerticalAlignment = xlGeneral) _
And (ma.HorizontalAlignment = xlCenter _
Or ma.HorizontalAlignment = xlJustify _
Or ma.HorizontalAlignment = xlDistributed) _
Then .AttachmentPoint = 2 /*acAttachmentPointTopCenter
If (ma.VerticalAlignment = xlTop _
Or ma.VerticalAlignment = xlGeneral) _
And ma.HorizontalAlignment = xlRight _
Then .AttachmentPoint = 3 /*acAttachmentPointTopRight
If (ma.VerticalAlignment = xlCenter _
Or ma.VerticalAlignment = xlJustify _
Or ma.VerticalAlignment = xlDistributed) _
And (ma.HorizontalAlignment = xlLeft _
Or ma.HorizontalAlignment = xlGeneral) _
Then .AttachmentPoint = 4 /*acAttachmentPointMiddleLeft
If (ma.VerticalAlignment = xlCenter _
Or ma.VerticalAlignment = xlJustify _
Or ma.VerticalAlignment = xlDistributed) _
And (ma.HorizontalAlignment = xlCenter _
Or ma.HorizontalAlignment = xlJustify _
Or ma.HorizontalAlignment = xlDistributed) _
Then .AttachmentPoint = 5 /*acAttachmentPointMiddleCenter
If (ma.VerticalAlignment = xlCenter _
Or ma.VerticalAlignment = xlJustify _
Or ma.VerticalAlignment = xlDistributed) _
And ma.HorizontalAlignment = xlRight _
Then .AttachmentPoint = 6 /*acAttachmentPointMiddleRight
If ma.VerticalAlignment = xlBottom _
And (ma.HorizontalAlignment = xlLeft _
Or ma.HorizontalAlignment = xlGeneral) _
Then .AttachmentPoint = 7 /*acAttachmentPointBottomLeft
If ma.VerticalAlignment = xlBottom _
And (ma.HorizontalAlignment = xlCenter _
Or ma.HorizontalAlignment = xlJustify _
Or ma.HorizontalAlignment = xlDistributed) _
Then .AttachmentPoint = 8 /*acAttachmentPointBottomCenter
If ma.VerticalAlignment = xlBottom _
And ma.HorizontalAlignment = xlRight _
Then .AttachmentPoint = 9 /*acAttachmentPointBottomRight
End With
textObj.Update
End Sub
从电子表格中读取已形成表格的高程数值进CAD中,直接进行计算 合计

efan2000

可否做一个表格工具，以后只要运行一下就可以直接从Excel表中生成CAD表格。