Reinventiamo il word processor

Un pezzo di codice divertente, senza alcuna utilità pratica... rispolverato dai meandri dei miei archivi, frutto di un passatempo di diverso tempo fa.
Una funzione che fa niente di particolare: riceve in input un testo e un margine (in numero di caratteri), quindi restituisce il testo formattato in modo da rispettare i margini indicati. E' possibile specificare l'allineamento (bandiera a sinistra, a destra, al centro o giustificato) e la presenza o meno del righello e dei margini (per default viene disegnato un piccolo righello orizzontale che ricorda quello di Wordstar).

L'allineamento default è quello giustificato, che riempie le parole di spazi per adattarle ai margini. Il futuro della routine? Ma perbacco, un sillabatore! :)

L'utilizzo è davvero semplice e poiché utilizza VBA puro si può utilizzare in qualunque strumento Office. Il codice ci sta tutto in un modulo.

Un breve test in finestra immediata?

?text_wrap("Tanto va la gatta al lardo che ci lascia lo zampino", 21, at_right)

+---------------------+
          1         2
 123456789012345678901
+---------------------+
  tanto va la gatta al
   lardo che ci lascia
            lo zampino
+---------------------+

?text_wrap("Tanto va la gatta al lardo che ci lascia lo zampino", 21, , False)

tanto  va la gatta al
lardo  che  ci lascia
lo            zampino

p.s. manoli.net, che utilizzavo per formattare il codice dei miei articoli, sembra scomparso... ne ho trovato uno simile, speriamo che funzioni :)



Option Explicit

Public Enum align
    at_left = 0
    at_right = 1
    at_center = 2
    at_justify = 3
End Enum

Function text_wrap(s As String, limit As Integer, Optional ByVal which_alignment As align = align.at_justify, Optional rules As Boolean = True) As String
Dim v As Variant, m As String, token As String, my_coll As Collection, line_rule As String
Dim t As String, i As Integer

    line_rule = "+" & String(limit, "-") & "+"
    For i = 1 To limit \ 10
        t = t & Space(9) & i
    Next
    
    s = trim_spaces(s)
    s = Replace(s, vbCrLf, "")
    
    Set my_coll = New Collection
    
    If IsMissing(which_alignment) Then which_alignment = align.at_justify
    For Each v In lines_collection(s, limit)
        token = alignment(CStr(v), limit, which_alignment)
        my_coll.Add token
    Next
    For Each v In my_coll
        m = m & IIf(rules, " ", "") & v & Chr(10)
    Next
    If rules Then
        m = line_rule & Chr(10) & " " & t & Chr(10) & " " & Left(Replace(Space(100), " ", "1234567890"), limit) & Chr(10) & line_rule & Chr(10) & m & line_rule
    End If
    text_wrap = m
End Function


Private Function alignment(s As String, line_length As Integer, Optional ByVal my_align As Integer = 0) As String
Dim v As Variant, returned_line As String, d As Integer, u As Integer, i As Integer, l As Integer

    returned_line = ""
    d = line_length - Len(s)
    If d < 0 Then d = 0
    
    Select Case my_align
    Case align.at_left
        returned_line = s
    
    Case align.at_right
        returned_line = Space(line_length - Len(s)) & s
    
    Case align.at_center
        l = line_length - Len(s)
        If l < 0 Then l = 0
        returned_line = Space(d \ 2) & s & Space(l + (d \ 2))
    
    Case align.at_justify
        v = Split(s, " ")
        u = UBound(v)
        If u > 0 Then
            For i = 0 To u - 1
                v(i) = v(i) + Space(d \ u)
                If i < (d Mod u) Then v(i) = v(i) + Space(1)
            Next
        End If
        returned_line = Join(v, " ")
    
    End Select

    alignment = returned_line
End Function


Private Function lines_collection(ByVal phrase As String, char_limit As Integer) As Collection
Dim tmp_coll As Collection, i As Integer, v As Variant, s As String, m As String
Dim arr() As String

    Set tmp_coll = New Collection
    
    arr = Split(phrase, " ")
    
    For i = 0 To UBound(arr)
        If Len(m & arr(i)) < char_limit Then
            m = m & arr(i) & " "
        Else
            If m <> "" Then tmp_coll.Add Trim(m)
            m = arr(i) & " "
        End If
    Next
    If Trim(m) <> "" Then tmp_coll.Add Trim(m)
    Set lines_collection = tmp_coll

End Function


Private Function trim_spaces(s As String) As String
    Do
        s = Replace(s, "  ", " ")
    Loop Until InStr(s, "  ") = 0
    
    trim_spaces = s

End Function

posted @ sabato 15 settembre 2018 17:37

Print

Comments on this entry:

No comments posted yet.

Your comment:



 (will not be displayed)


 
 
 
Please add 7 and 8 and type the answer here:
 

Live Comment Preview: