Grazie per il suggerimento, Migliorabile.
A dire il vero, io ho già scritto una routine per il calcolo dello spazio di un testo in punti. La allego, così magari la valutate.
Il problema è che non c'è corrispondenza tra il risultato e la
column.width; voglio dire, io riesco a calcolare (credo, se la routine è corretta) lo spazio occupato dal testo, ma non quello disponibile nel range delle celle unite.
Magari qualcuno può "illuminarmi"...
Questa è la routine:
Dim mDimensCarattere(32 To 127) As Double ' widths of printing characters
Dim msNomeFont As String ' font name having these widths
Sub testo()
'Debug.Print ActiveCell.Font.Name, ActiveCell.Font.Size
'Debug.Print sLarghezzaInPunti(Cells(45, 18), "Arial", 7)
End Sub
Function sLarghezzaInPunti(sDatoTesto As String, sNomeFont As String, sDimensioneFont As Double) As Double
' ---- restituisce la larghezza approssimativa in punti di una stringa di testo
' di un font specifico avente una specifica dimensione ----
' ---> esempio: sLarghezzaInPunti("Hello, World", "Arial", 10) (ritorna 55.78) <---
Dim i As Long
Dim j As Long
If Len(sNomeFont) = 0 Then Exit Function
If sNomeFont <> msNomeFont Then
If Not inizialDimCarattere(sNomeFont) Then Exit Function
End If
For i = 1 To Len(sDatoTesto)
j = Asc(Mid(sDatoTesto, i, 1))
If j >= 32 Then
sLarghezzaInPunti = sLarghezzaInPunti + sDimensioneFont * mDimensCarattere(j)
End If
Next i
End Function
Function inizialDimCarattere(sNomeFont As String) As Boolean
Dim i As Long
'in base al font, determina la larghezza in punti per il singolo carattere
' e lo restituisce nella variabile 'mDimensCarattere' dichiarata a livello di modulo.
'la funzione restituisce il valore VERO solo se il testo è stato trovato nell'elenco
Select Case sNomeFont
Case "Arial"
For i = 32 To 127
Select Case i
Case 39, 106, 108
mDimensCarattere(i) = 0.1902
Case 105, 116
mDimensCarattere(i) = 0.2526
Case 32, 33, 44, 46, 47, 58, 59, 73, 91 To 93, 102, 124
mDimensCarattere(i) = 0.3144
Case 34, 40, 41, 45, 96, 114, 123, 125
mDimensCarattere(i) = 0.3768
Case 42, 94, 118, 120
mDimensCarattere(i) = 0.4392
Case 107, 115, 122
mDimensCarattere(i) = 0.501
Case 35, 36, 48 To 57, 63, 74, 76, 84, 90, 95, 97 To 101, 103, 104, 110 To 113, 117, 121
mDimensCarattere(i) = 0.5634
Case 43, 60 To 62, 70, 126
mDimensCarattere(i) = 0.6252
Case 38, 65, 66, 69, 72, 75, 78, 80, 82, 83, 85, 86, 88, 89, 119
mDimensCarattere(i) = 0.6876
Case 67, 68, 71, 79, 81
mDimensCarattere(i) = 0.7494
Case 77, 109, 127
mDimensCarattere(i) = 0.8118
Case 37
mDimensCarattere(i) = 0.936
Case 64, 87
mDimensCarattere(i) = 1.0602
End Select
Next i
Case "Consolas"
For i = 32 To 127
Select Case i
Case 32 To 127
mDimensCarattere(i) = 0.5634
End Select
Next i
Case "Calibri"
For i = 32 To 127
Select Case i
Case 32, 39, 44, 46, 73, 105, 106, 108
mDimensCarattere(i) = 0.2526
Case 40, 41, 45, 58, 59, 74, 91, 93, 96, 102, 123, 125
mDimensCarattere(i) = 0.3144
Case 33, 114, 116
mDimensCarattere(i) = 0.3768
Case 34, 47, 76, 92, 99, 115, 120, 122
mDimensCarattere(i) = 0.4392
Case 35, 42, 43, 60 To 63, 69, 70, 83, 84, 89, 90, 94, 95, 97, 101, 103, 107, 118, 121, 124, 126
mDimensCarattere(i) = 0.501
Case 36, 48 To 57, 66, 67, 75, 80, 82, 88, 98, 100, 104, 110 To 113, 117, 127
mDimensCarattere(i) = 0.5634
Case 65, 68, 86
mDimensCarattere(i) = 0.6252
Case 71, 72, 78, 79, 81, 85
mDimensCarattere(i) = 0.6876
Case 37, 38, 119
mDimensCarattere(i) = 0.7494
Case 109
mDimensCarattere(i) = 0.8742
Case 64, 77, 87
mDimensCarattere(i) = 0.936
End Select
Next i
Case "Tahoma"
For i = 32 To 127
Select Case i
Case 39, 105, 108
mDimensCarattere(i) = 0.2526
Case 32, 44, 46, 102, 106
mDimensCarattere(i) = 0.3144
Case 33, 45, 58, 59, 73, 114, 116
mDimensCarattere(i) = 0.3768
Case 34, 40, 41, 47, 74, 91 To 93, 124
mDimensCarattere(i) = 0.4392
Case 63, 76, 99, 107, 115, 118, 120 To 123, 125
mDimensCarattere(i) = 0.501
Case 36, 42, 48 To 57, 70, 80, 83, 95 To 98, 100, 101, 103, 104, 110 To 113, 117
mDimensCarattere(i) = 0.5634
Case 66, 67, 69, 75, 84, 86, 88, 89, 90
mDimensCarattere(i) = 0.6252
Case 38, 65, 71, 72, 78, 82, 85
mDimensCarattere(i) = 0.6876
Case 35, 43, 60 To 62, 68, 79, 81, 94, 126
mDimensCarattere(i) = 0.7494
Case 77, 119
mDimensCarattere(i) = 0.8118
Case 109
mDimensCarattere(i) = 0.8742
Case 64, 87
mDimensCarattere(i) = 0.936
Case 37, 127
mDimensCarattere(i) = 1.0602
End Select
Next i
Case "Lucida Console"
For i = 32 To 127
Select Case i
Case 32 To 127
mDimensCarattere(i) = 0.6252
End Select
Next i
Case "Times New Roman"
For i = 32 To 127
Select Case i
Case 39, 124
mDimensCarattere(i) = 0.1902
Case 32, 44, 46, 59
mDimensCarattere(i) = 0.2526
Case 33, 34, 47, 58, 73, 91 To 93, 105, 106, 108, 116
mDimensCarattere(i) = 0.3144
Case 40, 41, 45, 96, 102, 114
mDimensCarattere(i) = 0.3768
Case 63, 74, 97, 115, 118, 122
mDimensCarattere(i) = 0.4392
Case 94, 98 To 101, 103, 104, 107, 110, 112, 113, 117, 120, 121, 123, 125
mDimensCarattere(i) = 0.501
Case 35, 36, 42, 48 To 57, 70, 83, 84, 95, 111, 126
mDimensCarattere(i) = 0.5634
Case 43, 60 To 62, 69, 76, 80, 90
mDimensCarattere(i) = 0.6252
Case 65 To 67, 82, 86, 89, 119
mDimensCarattere(i) = 0.6876
Case 68, 71, 72, 75, 78, 79, 81, 85, 88
mDimensCarattere(i) = 0.7494
Case 38, 109, 127
mDimensCarattere(i) = 0.8118
Case 37
mDimensCarattere(i) = 0.8742
Case 64, 77
mDimensCarattere(i) = 0.936
Case 87
mDimensCarattere(i) = 0.9984
End Select
Next i
Case Else
MsgBox "Font name """ & sNomeFont & """ not available!", vbCritical, "sLarghezzaInPunti"
Exit Function
End Select
msNomeFont = sNomeFont
inizialDimCarattere = True
End Function
La subroutine "testo" serve per eseguire una prova.
La routine non tiene conto della risoluzione dello schermo.
Fatemi sapere.