求助，如何使用这个统计程序！-将数字求和的程序 - VBA/VB/ActiveX/API 编程技术 - AutoCAD论坛 - 明经CAD社区 - 第2页

zxj_76 发表于 2004-7-27 16:23:00

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

zgyxn 发表于 2004-7-28 10:14:00

我常用的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

页: 1 [2]

明经CAD社区's Archiver