论坛 › VBA、COM-ActiveX › cad表格公式批量更新

striver 发表于 2023-12-20 09:27:54

cad表格公式批量更新

本帖最后由 striver 于 2023-12-20 09:29 编辑

如图为cad钢筋工程量计算表，带背景的cad单元格中含有计算公式，更改其他单元格数值时，公式单元格的显示结果经常不会自动更新，使用该程序可以批量更新cad表格公式单元格的显示结果。

Sub cad表格公式更新xdcad()
On Error GoTo ErrorHandler
AppActivate Application.Caption '切换到当前文档

Dim Ent As AcadEntity, Pnt As Variant
Do
    ThisDrawing.Utility.GetEntity Ent, Pnt, vbCrLf & "选择表格"
    If TypeOf Ent Is AcadTable Then Exit Do
Loop

Ent.RegenerateTableSuppressed = True

Dim celltextStr As String
Dim myxsws As Integer
Dim CellFormatStr As String
Dim FormulaStr As String

Dim I As Integer
Dim J As Integer
Dim RwH() As Double
ReDim RwH(0 To Ent.Rows - 1)
For I = 0 To Ent.Rows - 1
    RwH(I) = Ent.GetRowHeight(I)
Next

For I = 0 To Ent.Rows - 1
    For J = 0 To Ent.Columns - 1
      celltextStr = Trim(Ent.GetText(I, J))
      If Ent.GetHasFormula(I, J, 0) Then
      myxsws = xsws(celltextStr)
      CellFormatStr = "%pr" & myxsws & "%lu2"
      FormulaStr = Ent.GetFormula(I, J, 0)
      
      Ent.SetFormula I, J, 0, ""
      Ent.SetFormula I, J, 0, "=" & Mid(FormulaStr, 2, Len(FormulaStr) - 2)
      Ent.SetCellFormat I, J, CellFormatStr
      Ent.SetCellFormat I, J, CellFormatStr
      End If
    Next
    Ent.SetRowHeight I, RwH(I)
Next
Ent.RegenerateTableSuppressed = False

ThisDrawing.Utility.Prompt "已更新表格。" & vbCrLf

ErrorHandler:
End Sub

'获取小数位数
Function xsws(numberStr As String) As Integer
    If InStr(numberStr, ".") = 0 Then
      xsws = 0
    ElseIf InStr(numberStr, ".") > 0 Then
      xsws = Len(numberStr) - InStr(numberStr, ".")
    End If
End Function

kmliro_2017 发表于 2023-12-24 08:04:56

谢谢分享！！！！！

kmliro_2017 发表于 2023-12-24 08:10:32

谢谢分享！！！！！

kmliro_2017 发表于 2023-12-24 08:12:38

谢谢分享！！！！！

60ck 发表于 2023-12-24 16:08:08

谢谢分享！
学习一下，看怎么使用

查看完整版本: cad表格公式批量更新