求助，如何使用这个统计程序！----将数字求和的程序

zxj_76

改进后的程序，欢迎下载！

zgyxn

我常用的vba工具中的一小部分 裁出来的，很多定义是其它小程序才用到的 Option Explicit
Dim sysVarName, sysVarNameB As String
Dim varData As Variant
Dim varDataB As Variant
Dim intData As Integer
Dim sysvarData As Variant
Dim sysvarDataB As Variant
Dim varPnt As Variant
Dim sSet, eNt As Object
Dim tText As String
Public Pi As Double
Public FrNum As Integer
Public textH As Single

Dim laYerStr(80) As String
Dim laYerColor(80) As Integer

Public dimS, dimSet, PfSt, MuSt, eveDimset As Integer
'标总面积，标注方式，平方位数，亩位数，逐个标注
Public strExpPf, strExpMu As String
Public strPf, strMu As String
Public BzLay, HxLay As String
Dim Found As Boolean
Dim laYerObj As AcadLayer
Dim NewLayer As AcadLayer
Public FrontText As String
Public FrontNum As Integer
Dim FileName As String
Dim pT1, pT2, pT3, pT4 As Integer
Dim points As Variant
Dim ptMid(0 To 2) As Double '线段中点，文字对齐点
Dim NewPt(0 To 2) As Double
Dim keyWd As String
Dim Ptt As Variant
Dim i, j As Integer Dim varCancel As Variant
Dim ESC As Long
Public Declare Function CallNextHookEx Lib "user32" _
(ByVal hHook As Long, _
ByVal nCode As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long Public Declare Function UnhookWindowsHookEx Lib "user32" _
(ByVal hHook As Long) As Long Public Declare Function SetWindowsHookEx Lib "user32" _
Alias "SetWindowsHookExA" _
(ByVal idHook As Long, _
ByVal lpfn As Long, _
ByVal hmod As Long, _
ByVal dwThreadId As Long) As Long Public Declare Function PostMessage Lib "user32" _
Alias "PostMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer Private Const VK_ESCAPE = &H1B Public Const WH_KEYBOARD = 2
Public Const KBH_MASK = &H20000000
Public Const WM_LBUTTONDOWN = &H201
Public Const WM_LBUTTONUP = &H202 Global hHook As Long
Global EscKey As Boolean Public Function KeyboardProc(ByVal nCode As Long, ByVal wParam As Long, _
ByVal lParam As Long) As Long
If nCode >= 0 Then
'Process keys you want to filter
If wParam = 27 Then
EscKey = True
Else
EscKey = False
End If
End If
KeyboardProc = CallNextHookEx(hHook, nCode, wParam, lParam)
End Function
Public Sub hz()
'定义文本值
Dim TextNum As Integer
Dim eveTextNum As Double
Dim MinText As Double
Dim MaxText As Double
Dim AveText As Double
Dim TextHz As Double
'定义实体值
Dim ObjNum As Integer Dim ObjHz As Double
Dim JudgeClo As Integer
Dim JudgeText As Integer
Dim LongStr As String
Dim eveObjNum As Double
Dim MinObj As Double
Dim MaxObj As Double
Dim AveObj As Double
Dim errCo As Boolean
On Error Resume Next
'*************取得原始文字高*************
'GetOriData
'*************开始程序*************
On Error GoTo Err_Control

selec:
If ThisDrawing.SelectionSets.Count > 0 Then
For i = 0 To ThisDrawing.SelectionSets.Count - 1
ThisDrawing.SelectionSets.Item(i).Delete
Next i
End If
Set sSet = ThisDrawing.SelectionSets.add("ss1")
sSet.SelectOnScreen
Dim pdText, pdObj As Boolean
pdText = False
pdObj = False TextNum = 0
TextHz = 0
ObjNum = 0
ObjHz = 0
JudgeClo = 0 For Each eNt In sSet If eNt.ObjectName = "AcDbText" Or eNt.ObjectName = "AcDbMText" Then

For i = 1 To Len(eNt.TextString)
If Mid(eNt.TextString, i, 1) = "|" Or Mid(eNt.TextString, i, 1) = "\" Then errCo = True
If Asc(Mid(eNt.TextString, i, 1)) > 47 And Asc(Mid(eNt.TextString, i, 1)) < 58 Then
FrontNum = i - 1
i = Len(eNt.TextString)
End If
Next i
j = 0
For i = 1 To FrontNum
If Mid(eNt.TextString, i, 1) = " " Then j = j + 1
Next i
FrontNum = FrontNum - j eveTextNum = Val(Right(Trim(eNt.TextString), Len(Trim(eNt.TextString)) - FrontNum))
If errCo = True Then MsgBox "在该文本中发现异常字符，使用该命令后，请检查数据，以免出错!!!" + vbCrLf + " (建议使用Ddmodify命令检查该文本)", vbExclamation, "小游提醒您："

TextNum = TextNum + 1
TextHz = TextHz + eveTextNum

If pdObj = False Then
pdObj = True
MinText = eveTextNum
MaxText = eveTextNum
End If
If eveTextNum < MinText Then MinText = eveTextNum
If eveTextNum > MaxText Then MaxText = eveTextNum
Else
JudgeText = JudgeText + 1
End If
If eNt.ObjectName = "AcDbPolyline" Or eNt.ObjectName = "AcDbLWPolyline" Then
If eNt.Closed = True Then
If pdText = False Then
pdText = True
MinObj = eNt.Area
MaxObj = eNt.Area
End If
eveObjNum = eNt.Area
ObjNum = ObjNum + 1
ObjHz = ObjHz + eveObjNum
If eveObjNum < MinObj Then MinObj = eveObjNum
If eveObjNum > MaxObj Then MaxObj = eveObjNum
Else
JudgeClo = JudgeClo + 1
End If
End If
Next If TextNum > 0 Then AveText = TextHz / TextNum
If ObjNum > 0 Then AveObj = ObjHz / ObjNum
LongStr = "文本个数=" & Str(TextNum) & " 实体个数=" & Str(ObjNum) & " 总个数=" & Str(TextNum + ObjNum) & vbCrLf
ThisDrawing.Utility.Prompt LongStr
LongStr = " 最小文本=" & Str(Trim(Format(MinText, "0.000"))) & " 最小实体=" & Str(Trim(Format(MinObj, "0.000"))) & vbCrLf
ThisDrawing.Utility.Prompt LongStr
LongStr = " 最大文本=" & Str(Trim(Format(MaxText, "0.000"))) & " 最大实体=" & Str(Trim(Format(MaxObj, "0.000"))) & vbCrLf
ThisDrawing.Utility.Prompt LongStr
LongStr = " 平均文本值=" & Str(Trim(Format(AveText, "0.000"))) & " 平均实体值=" & Str(Trim(Format(AveObj, "0.000"))) & vbCrLf
ThisDrawing.Utility.Prompt LongStr
LongStr = "总文本值=" & Str(Trim(Format(TextHz, "0.000"))) & " 总实体值=" & Str(Trim(Format(ObjHz, "0.000"))) & " 两项总值=" & Str(Trim(Format(TextHz + ObjHz, "0.000"))) & vbCrLf
ThisDrawing.Utility.Prompt LongStr
If JudgeText <> 0 Then
'LongStr = "另有" & Str(JudgeText) & "个文本设置的现有数值前字符数大于整个文本长，未进行统计" & vbCrLf
ThisDrawing.Utility.Prompt LongStr
End If If JudgeClo <> 0 Then
LongStr = "另有" & Str(JudgeClo) & "条多义线未闭合，未进行面积统计，请处理以免出错" & vbCrLf
ThisDrawing.Utility.Prompt LongStr
End If En:
Exit_Here:
Call UnhookWindowsHookEx(hHook)
Exit Sub
Err_Control:
varCancel = ThisDrawing.GetVariable("LASTPROMPT")
ESC = GetAsyncKeyState(VK_ESCAPE)
Select Case Err.Number
'按了取消键或其它透明命令
Case -2147352567
'如果命令行提示中没有“取消”这样的文字出现
'一般来说在2002中按了回车或空格都不会出现“取消”
'则退出
If InStr(1, varCancel, "*Cancel*") <> 0 And _
InStr(1, varCancel, "*取消*") <> 0 Then
Err.Clear
Resume Exit_Here
'如果按了“取消”键，则退出
ElseIf ESC <> 0 Then
Err.Clear
Resume Exit_Here
'其它情况下，则恢复。如选择了透明命令，则会出现“取消”
'字样，但不是按了“取消”键。
Else
Err.Clear
Resume
End If
'右键单击或回车或空格。
'在这里，-2147467259用于AutoCAD 2000 及2002，
'而-2145320928为2004专用
Case -2147467259, -2145320928
Err.Clear
Resume Exit_Here
'其它情况，一律退出
Case Else
Err.Clear
Resume Exit_Here
End Select
End Sub