Коэффициент сжатия

Option Explicit
Sub TEST()
     Dim ar As Variant, _
         e As AcadEntity, _
         t As AcadTable, _
         p As Variant, _
         ip As Variant, _
         r As Long, _
         c As Long, _
         st As String, _
         ns As String, _
         d As Double
     With ThisDrawing.Utility
          .GetEntity e, ip, "Select table"
          p = .GetPoint(, "Pick a point inside the desired cell")
     End With
     Set t = e
     ar = GetTableCell(t, p, r, c)
     r = ar(0)
     c = ar(1)
'     debug only:
'     MsgBox "Row " & r & ", Column " & c & vbCr & _
'            "Value: " & t.GetText(r, c)
            st = t.GetCellTextStyle(r, c)
            d = CDbl(InputBox("Enter width factor for this cell:", "Cell Text Width", "0.75"))
            CopyTextStyle st, d, ns
            t.SetCellTextStyle r, c, ns
            t.Update
End Sub
Function GetTableCell(ByVal oTable As AcadTable, ByVal varPt As Variant, _
                      ByRef rowIndex As Long, ByRef colIndex As Long) As Variant
     Dim wviewVec As Variant
     Dim resVar(1) As Long
     wviewVec = ThisDrawing.GetVariable("VIEWDIR")
     oTable.HitTest varPt, wviewVec, rowIndex, colIndex
     resVar(0) = rowIndex
     resVar(1) = colIndex
     GetTableCell = resVar
End Function
Public Function TextStyleExists(styleName As String) As Boolean
'// Frank Oquendo's technic
Dim obj As AcadTextStyle
On Error Resume Next
Set obj = ThisDrawing.TextStyles.Item(styleName)
TextStyleExists = (Err.Number = 0)
End Function
Public Function CopyTextStyle(stlName As String, dblWidth As Double, ByRef newname As String) As Boolean
   On Error GoTo Err_Handler
   Dim oTxtStyle As AcadTextStyle
   Set oTxtStyle = ThisDrawing.TextStyles(stlName)
   ThisDrawing.ActiveTextStyle = oTxtStyle
   If InStr(1, stlName, "-", vbTextCompare) <> 0 Then
   newname = Left(stlName, InStr(1, stlName, "-", vbTextCompare) - 1) & "-" & CStr(dblWidth * 100)
   Else
   newname = stlName & "-" & CStr(dblWidth * 100)
   End If
   If Not TextStyleExists(newname) Then
   Set oTxtStyle = ThisDrawing.TextStyles.Add(newname)
   oTxtStyle.width = dblWidth
   ThisDrawing.Save
   CopyTextStyle = True
   End If
Exit_Here:
   Exit Function
Err_Handler:
   Select Case Err.Number
      Case -2145320861
         CopyTextStyle = False
         Resume Exit_Here
      Case Else
         CopyTextStyle = False
         MsgBox "Error " & Err.Description, "CopyTextStyle", Err.Number
         Resume Exit_Here
   End Select
End Function
Function GetCellText(ByRef rowMax As Long, ByRef rowMin As Long, _
                     ByRef ColMax As Long, ByRef ColMin As Long) As Variant
     Dim pfSet As AcadSelectionSet
     Set pfSet = ThisDrawing.PickfirstSelectionSet
     Dim oTable As AcadTable
     If pfSet.Count = 1 Then
               Set oTable = pfSet.Item(0)
          oTable.GetSubSelection rowMin, rowMax, ColMin, ColMax
     Else
Exit Function
End If
pfSet.Clear
GetCellText = oTable.GetText(rowMin, ColMin)
End Function

 vl = "{\W" & CStr(d) & ";" & vl & "}"

"{\W0.5;текст ячейки}"