- UID
- 812251
- 积分
- 65
- 精华
- 贡献
-
- 威望
-
- 活跃度
-
- D豆
-
- 在线时间
- 小时
- 注册时间
- 2023-12-8
- 最后登录
- 1970-1-1
|
马上注册,结交更多好友,享用更多功能,让你轻松玩转社区。
您需要 登录 才可以下载或查看,没有账号?立即注册
×
本帖最后由 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 |
-
|