社区 › VBA/VB/ActiveX/API 编程技术 › 【VBA源码】【红日原创】【代发】CAD算式求值源代码，用于绘图时轻量计算

fzlong 发表于 2025-8-16 13:38:33

【VBA源码】【红日原创】【代发】CAD算式求值源代码，用于绘图时轻量计算

本帖最后由 fzlong 于 2025-8-16 13:53 编辑

代码功能：
    运行此宏程序后,在CAD绘图中需要输入尺寸的时候，可以方便快捷的支持算式求值（四则运算&括号）。如启动命令“LINE”绘制直线，在动态输入框中输入“(50+100)*2”并按空格或回车键，程序将自动把输入框内的计算式“(50+100)*2”转换成计算结果“300”，用户确认无误后再次敲击空格或回车则CAD接受计算结果并继续下一步绘制，或按ESC取消继续绘制。

运行环境：
    仅在CAD2020中测试，理论上没有太多的版本限制。
    运行Sub StartCalculator启动，再次运行Sub StopCalculator停止并卸载键盘钩子，键盘钩子有可能导致CAD崩溃，需要做其它复杂操作时请务必先停止程序 (直接运行Sub StopCalculator)。




代码来源：
    此VBA程序的核心代码如API声明、程序逻辑、键盘钩子等皆为红日原创，由俺抛砖引玉并稍加整理。在征得红日的许可后，代为发布到明经论坛，再次对红日大佬的奉献精神献上俺的敬意，也谢谢明经论坛这个优秀的开发者平台使俺获益良多。此代码无任何使用限制，但搬运时请注明出处为明经论坛及原创版权为红日所有。

补充说明：
    CAD在64位VBA中已不再支持Evaluate函数，红日大佬指出可以在TwinBasic内使用32位VBA编程后编译成DLL再调用，因小弟能力有限目前未能实现，诸君功力深厚者请自行完善，红日大佬已验证此方案是完全可行的。下图为红日大佬的32位VBA的Evaluate函数使用方法示例，使用此函数可以充分拓展程序能够支持的运算规则。
    小弟作为初学者眼高手低，程序难免有错漏之处，请不吝赐教。

红日大佬：“CAD那里不能有空格,我在TwinBasic里把运算符都给分开进行求值”


Option Explicit

' Windows API函数声明
Private Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare PtrSafe Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

' 钩子相关API声明
#If Win64 And VBA7 Then
    Dim m_hHook As LongPtr
    Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _
      (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
    Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hhk As LongPtr) As Long
    Declare PtrSafe Function CallNextHookEx Lib "user32" _
      (ByVal hhk As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
    Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
    Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
      (Destination As Any, Source As Any, ByVal Length As LongPtr)
#Else
    Dim m_hHook As Long
    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
    Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hhk As Long) As Long
    Declare Function CallNextHookEx Lib "user32" _
      (ByVal hhk As Long, ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Declare Function GetCurrentThreadId Lib "kernel32" () As Long
    Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
    Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
      (Destination As Any, Source As Any, ByVal Length As Long)
#End If

' 常量定义
Const WH_KEYBOARD_LL = 13
Const WM_KEYDOWN = &H100
Const VK_SPACE = 32
Const VK_ENTER = 13
Const WM_SETTEXT = &HC

' 钩子结构体
#If Win64 And VBA7 Then
Type KBDLLHOOKSTRUCT
    vkCode As Long
    scanCode As Long
    flags As Long
    time As Long
    dwExtraInfo As LongPtr
End Type
#Else
Type KBDLLHOOKSTRUCT
    vkCode As Long
    scanCode As Long
    flags As Long
    time As Long
    dwExtraInfo As Long
End Type
#End If

' 全局变量
Dim m_bHookActive As Boolean
Dim m_bCalculationDone As Boolean' 标记是否已完成计算
Dim m_lastCalculatedHwnd As Long   ' 记录上次计算的窗口句柄
Dim m_bMonitorActive As Boolean    ' 监控器激活状态
Dim m_timerID As Long            ' 定时器ID (检测CAD窗口存在性)
Dim m_bInTimerProc As Boolean      ' 防止定时器递归调用

' 定时器相关API声明
Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As Long
Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long

' 启动计算器监控 - 简化为单一检测
Public Sub StartCalculator()
    If m_bMonitorActive = True Then Exit Sub
   
    ' 启动定时检测，每1秒检测一次CAD窗口是否存在
    m_timerID = SetTimer(0, 1, 1000, AddressOf CADWindowMonitor)
    If m_timerID <> 0 Then
      m_bMonitorActive = True
      Debug.Print "CAD计算器监控器已启动 (每1秒检测窗口存在性)"
    Else
      MsgBox "定时器创建失败"
    End If
End Sub

' 停止计算器监控
Public Sub StopCalculator()
    On Error GoTo ErrorHandler
   
    Debug.Print "开始停止计算器监控..."
   
    ' 首先卸载钩子
    Call UninstallHook
   
    ' 停止定时器
    If m_timerID <> 0 Then
      KillTimer 0, m_timerID
      m_timerID = 0
      Debug.Print "定时器已停止"
    End If
   
    ' 重置所有状态
    m_bMonitorActive = False
    m_bCalculationDone = False
    m_lastCalculatedHwnd = 0
    m_bInTimerProc = False
   
    Debug.Print "CAD计算器监控器已完全停止"
    Exit Sub
   
ErrorHandler:
    Debug.Print "StopCalculator错误: " & Err.Description
    ' 强制重置所有状态
    m_bMonitorActive = False
    m_bHookActive = False
    m_bCalculationDone = False
    m_lastCalculatedHwnd = 0
    m_bInTimerProc = False
    m_timerID = 0
End Sub

' CAD窗口监控函数 - 简化逻辑
Public Sub CADWindowMonitor(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)
    ' 防止递归调用
    If m_bInTimerProc Then Exit Sub
    m_bInTimerProc = True
   
    On Error GoTo ErrorHandler
   
    Dim cadHwnd As Long
   
    ' 查找CAD动态输入窗口控件
    cadHwnd = FindWindow(vbNullString, "CAcDynInputWndControl")
   
    If cadHwnd <> 0 Then
      ' CAD动态输入窗口存在，安装钩子（如果尚未安装）
      If Not m_bHookActive Then
            Call InstallHook
            Debug.Print "检测到CAD动态输入窗口，钩子已安装"
      End If
    Else
      ' CAD动态输入窗口不存在，卸载钩子（如果已安装）
      If m_bHookActive Then
            Call UninstallHook
            Debug.Print "CAD动态输入窗口消失，钩子已卸载"
      End If
    End If
   
    m_bInTimerProc = False
    Exit Sub
   
ErrorHandler:
    Debug.Print "CADWindowMonitor错误: " & Err.Description
    m_bInTimerProc = False
End Sub

' 安装钩子 - 添加错误处理
Private Sub InstallHook()
    On Error GoTo ErrorHandler
   
    If m_bHookActive = True Then Exit Sub
   
    m_hHook = SetWindowsHookEx(WH_KEYBOARD_LL, AddressOf CalculatorKeyboardProc, GetModuleHandle(vbNullString), 0)
    m_bHookActive = (m_hHook <> 0)
   
    If m_bHookActive Then
      Debug.Print "钩子已安装"
    Else
      Debug.Print "钩子安装失败"
    End If
    Exit Sub
   
ErrorHandler:
    Debug.Print "InstallHook错误: " & Err.Description
    m_bHookActive = False
End Sub

' 卸载钩子 - 添加错误处理
Private Sub UninstallHook()
    On Error GoTo ErrorHandler
   
    If m_bHookActive = True Then
      UnhookWindowsHookEx m_hHook
      m_bHookActive = False
      Debug.Print "钩子已安全卸载"
      
      ' 重置计算状态
      m_bCalculationDone = False
      m_lastCalculatedHwnd = 0
    End If
    Exit Sub
   
ErrorHandler:
    Debug.Print "UninstallHook错误: " & Err.Description
    m_bHookActive = False
    m_bCalculationDone = False
    m_lastCalculatedHwnd = 0
End Sub

' 键盘钩子回调函数 - 添加错误处理
#If Win64 And VBA7 Then
    Public Function CalculatorKeyboardProc(ByVal nCode As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
#Else
    Public Function CalculatorKeyboardProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
#End If
   
    On Error GoTo ErrorHandler
   
    If nCode >= 0 Then
      Dim kbStruct As KBDLLHOOKSTRUCT
      CopyMemory kbStruct, ByVal lParam, LenB(kbStruct)
      
      If wParam = WM_KEYDOWN Then
            If kbStruct.vkCode = VK_SPACE Or kbStruct.vkCode = VK_ENTER Then
                ' 处理CAD输入，返回True表示拦截按键
                If ProcessCADInput() Then
                  ' 拦截按键，不让其传递到CAD
                  CalculatorKeyboardProc = 1
                  Exit Function
                End If
            End If
      End If
    End If
   
    CalculatorKeyboardProc = CallNextHookEx(m_hHook, nCode, wParam, lParam)
    Exit Function
   
ErrorHandler:
    Debug.Print "CalculatorKeyboardProc错误: " & Err.Description
    CalculatorKeyboardProc = CallNextHookEx(m_hHook, nCode, wParam, lParam)
End Function

' 处理CAD输入 - 简化逻辑，只在表达式时处理
Private Function ProcessCADInput() As Boolean
    On Error GoTo ErrorHandler
   
    Dim hwnd As Long, strText As String, L As Long
    Dim result As Double
   
    ProcessCADInput = False' 默认不拦截
   
    ' 查找CAD动态输入窗口控件
    hwnd = FindWindow(vbNullString, "CAcDynInputWndControl")
    If hwnd = 0 Then Exit Function
   
    ' 查找其中的Edit控件
    hwnd = FindWindowEx(hwnd, 0, "Edit", vbNullString)
    If hwnd = 0 Then Exit Function
   
    ' 获取Edit控件中的文本
    strText = String(255, " ")
    L = GetWindowText(hwnd, strText, 255)
    strText = Trim(Left(strText, L))
   
    ' 检查当前状态
    If m_bCalculationDone And m_lastCalculatedHwnd = hwnd Then
      ' 已经计算过了，这次是确认，重置状态让按键正常传递
      m_bCalculationDone = False
      m_lastCalculatedHwnd = 0
      Debug.Print "用户确认计算结果，继续执行CAD命令"
      Exit Function' 返回False，让按键正常传递给CAD
    End If
   
    ' 只有在检测到表达式时进行计算和拦截
    If IsExpression(strText) Then
      result = EvaluateExpression(strText)
      If result <> -999999 Then' 检查是否计算成功
            ' 将结果设置回Edit控件
            SendMessage hwnd, WM_SETTEXT, 0, ByVal CStr(result)
            ' 设置状态标记
            m_bCalculationDone = True
            m_lastCalculatedHwnd = hwnd
            ProcessCADInput = True' 拦截这次按键
            Debug.Print "计算完成: " & strText & " = " & result & "，等待用户确认"
      End If
    End If
    ' 如果是纯数值，不做任何处理，让按键正常传递
   
    Exit Function
   
ErrorHandler:
    Debug.Print "ProcessCADInput错误: " & Err.Description
    ProcessCADInput = False
End Function

' 判断是否为表达式（包含运算符或括号且不是纯数值）
Private Function IsExpression(text As String) As Boolean
    IsExpression = False
    If Len(text) = 0 Then Exit Function
   
    ' 检查是否包含运算符或括号
    If InStr(text, "+") > 0 Or InStr(text, "-") > 0 Or InStr(text, "*") > 0 Or InStr(text, "/") > 0 Or InStr(text, "(") > 0 Or InStr(text, ")") > 0 Then
      ' 检查是否不是纯数值
      If Not IsNumeric(text) Then
            IsExpression = True
      End If
    End If
End Function

' 四则运算计算函数
Private Function EvaluateExpression(expression As String) As Double
    On Error GoTo ErrorHandler
   
    Dim cleanExpr As String
    Dim result As Double
   
    ' 清理表达式
    cleanExpr = Replace(expression, " ", "")
   
    ' 简单的四则运算解析
    result = ParseExpression(cleanExpr)
    EvaluateExpression = result
    Exit Function
   
ErrorHandler:
    EvaluateExpression = -999999' 使用特殊值表示错误
End Function

' 解析表达式（支持加减乘除和括号）
Private Function ParseExpression(expr As String) As Double
    On Error GoTo ErrorHandler
   
    Dim pos As Integer
    pos = 1
    ParseExpression = ParseAddSub(expr, pos)
    Exit Function
   
ErrorHandler:
    ParseExpression = -999999' 返回错误值
End Function

' 解析加减运算（最低优先级）
Private Function ParseAddSub(expr As String, ByRef pos As Integer) As Double
    On Error GoTo ErrorHandler
   
    Dim result As Double
    Dim op As String
   
    result = ParseMulDiv(expr, pos)
   
    Do While pos <= Len(expr)
      op = GetNextOperator(expr, pos)
      If op = "+" Or op = "-" Then
            pos = pos + 1' 跳过运算符
            Select Case op
                Case "+"
                  result = result + ParseMulDiv(expr, pos)
                Case "-"
                  result = result - ParseMulDiv(expr, pos)
            End Select
      Else
            Exit Do
      End If
    Loop
   
    ParseAddSub = result
    Exit Function
   
ErrorHandler:
    ParseAddSub = -999999
End Function

' 解析乘除运算（中等优先级）
Private Function ParseMulDiv(expr As String, ByRef pos As Integer) As Double
    On Error GoTo ErrorHandler
   
    Dim result As Double
    Dim op As String
    Dim rightOperand As Double
   
    result = ParseFactor(expr, pos)
   
    Do While pos <= Len(expr)
      op = GetNextOperator(expr, pos)
      If op = "*" Or op = "/" Then
            pos = pos + 1' 跳过运算符
            rightOperand = ParseFactor(expr, pos)
            Select Case op
                Case "*"
                  result = result * rightOperand
                Case "/"
                  If rightOperand <> 0 Then
                        result = result / rightOperand
                  Else
                        Err.Raise vbObjectError + 1, , "除数不能为零"
                  End If
            End Select
      Else
            Exit Do
      End If
    Loop
   
    ParseMulDiv = result
    Exit Function
   
ErrorHandler:
    ParseMulDiv = -999999
End Function

' 解析因子（数字或括号表达式，最高优先级）
Private Function ParseFactor(expr As String, ByRef pos As Integer) As Double
    On Error GoTo ErrorHandler
   
    Dim result As Double
    Dim numStr As String
    Dim char As String
    Dim isNegative As Boolean
   
    ' 跳过空格
    Do While pos <= Len(expr) And Mid(expr, pos, 1) = " "
      pos = pos + 1
    Loop
   
    If pos > Len(expr) Then
      Err.Raise vbObjectError + 2, , "表达式不完整"
    End If
   
    char = Mid(expr, pos, 1)
   
    ' 处理负号
    If char = "-" Then
      isNegative = True
      pos = pos + 1
      If pos > Len(expr) Then
            Err.Raise vbObjectError + 2, , "表达式不完整"
      End If
      char = Mid(expr, pos, 1)
    ElseIf char = "+" Then
      pos = pos + 1
      If pos > Len(expr) Then
            Err.Raise vbObjectError + 2, , "表达式不完整"
      End If
      char = Mid(expr, pos, 1)
    End If
   
    If char = "(" Then
      ' 括号表达式
      pos = pos + 1' 跳过左括号
      result = ParseAddSub(expr, pos)' 递归解析括号内容
      
      ' 跳过空格
      Do While pos <= Len(expr) And Mid(expr, pos, 1) = " "
            pos = pos + 1
      Loop
      
      If pos > Len(expr) Or Mid(expr, pos, 1) <> ")" Then
            Err.Raise vbObjectError + 3, , "缺少右括号"
      End If
      pos = pos + 1' 跳过右括号
    Else
      ' 数字
      numStr = ""
      Do While pos <= Len(expr)
            char = Mid(expr, pos, 1)
            If IsNumeric(char) Or char = "." Then
                numStr = numStr & char
                pos = pos + 1
            Else
                Exit Do
            End If
      Loop
      
      If numStr = "" Then
            Err.Raise vbObjectError + 4, , "无效的数字"
      End If
      
      result = CDbl(numStr)
    End If
   
    If isNegative Then
      result = -result
    End If
   
    ParseFactor = result
    Exit Function
   
ErrorHandler:
    ParseFactor = -999999
End Function

' 获取下一个运算符
Private Function GetNextOperator(expr As String, pos As Integer) As String
    ' 跳过空格
    Do While pos <= Len(expr) And Mid(expr, pos, 1) = " "
      pos = pos + 1
    Loop
   
    If pos <= Len(expr) Then
      GetNextOperator = Mid(expr, pos, 1)
    Else
      GetNextOperator = ""
    End If
End Function

' 自动清理函数
Private Sub Auto_Close()
    Debug.Print "执行自动清理..."
    Call StopCalculator
End Sub

你有种再说一遍 发表于 2025-8-16 14:17:40

本帖最后由 你有种再说一遍 于 2025-8-16 14:46 编辑

红日的号没了吗
钩子有进程和全局两款,进程钩子先被桌子用了所以我们没得用.
钩子的安装和卸载是不需要管输入窗口是否存在的,
应该进程启动后就安装,进程关闭前卸载.
键入时候判断输入窗口是否存在,然后再进行接下来的操作.

wuyunpeng888 发表于 2025-8-16 15:14:50

表达式求值的我给你附上 attach://144743.rar

wuyunpeng888 发表于 2025-8-16 15:20:45

你写得好复杂呀

wuyunpeng888 发表于 2025-8-16 15:33:10

本帖最后由 wuyunpeng888 于 2025-8-16 15:38 编辑

钩子回调函数 attach://144744.jpg

fzlong 发表于 2025-8-16 17:25:37

wuyunpeng888 发表于 2025-8-16 15:14
表达式求值的我给你附上 attach://144743.rar

:lol谢谢红日大佬

fzlong 发表于 2025-8-16 17:27:08

你有种再说一遍 发表于 2025-8-16 14:17
红日的号没了吗
钩子有进程和全局两款,进程钩子先被桌子用了所以我们没得用.
钩子的安装和卸载是不需要管 ...

;P谢谢惊惊大佬

czb203 发表于 2025-8-18 09:15:47

虽然用不到，但是还是感谢大佬的热心分享

查看完整版本: 【VBA源码】【红日原创】【代发】CAD算式求值源代码，用于绘图时轻量计算