Mise en forme de paragraphe (justifie) en police a largeur fixe

Télécharger le projet
Commenter

Description

Description _________________
Ce module vous fournit une fonction simple et riche pour mettre en forme un texte en police a largeur fixe (Courier ou Lucida).

Fonctionnement ______________
Les polices a largeur fixe utilise la meme largeur pour tous les caracteres alors que les polices a largeur variable adapte la largeur pour chaque caractere ce qui fait qu'un "M" sera plus large qu'un "I".
Mettre en forme de tels paragraphes repose sur l'ajout d'espaces pour donner aux lignes une certaine largeur.

Exemple _________________
Voir image et formulaire.

Source / Exemple : 


'************************************************************************'
'************************************************************************'
'**                                                                    **'
'**            LUCIDA (FIXED-WIDTH FONT) TEXT SETUP MODULE             **'
'**                                                                    **'
'************************************************************************'
'************************************************************************'

'----------------------------   ATTRIBUTES   ----------------------------'
'Author = Santiago Diez (santiago.diez@free.fr)
'Website = http://santiago.diez.free.fr
'Webpage = http://www.vbfrance.com/code.aspx?ID=38468
'Date = 10 JULY 2006  14:13
'Version = 2.0

'----------------------------   COPYRIGHT   -----------------------------'
'I worked on  that module for  me and for  you. You are  allowed to do the
'following  as long  as you  specify my  name and  website  (please  don't
'laught, one day it will be a real website):
'- use the code, partially or totally
'- change the code partially
'If you ever improve the features of  that module, fix any bug or find any
'way to make it better, please write to me for feedback.

'---------------------------   DESCRIPTION   ----------------------------'
'This module provides you  with functions to setup the layout  of texts to
'display with fixed-width fonts (Courier or Lucida).

'---------------------------   HOW IT WORKS   ---------------------------'
'Fixed-width  fonts   use  the   same  width   for  any   character,  when
'variable-width fonts adapt the size for each character which makes an "M"
'larger than an "I".
'Setting the  layout of  such texts is  only based  on adding  or removing
'space characters to make a line reach a certain size.

'-----------------   PUBLIC PROCEDURES AND FUNCTIONS   ------------------'
'String = LucidaTextSetup(Text As String, Length As Long, [ParagraphStyle
'         As LucidaStyle], [IsOneParagraph As Boolean], [ParagraphTab],
'         [FirstLineTab], [LineSeparator As String = vbCrLf])

'-----------------------------   EXAMPLES   -----------------------------'
'    Text = "I have a dream that one day this nation will rise up and" & _
'           " live out the true meaning of its creed : ""We hold thes" & _
'           "e truths to be self-evident that all men are created equ" & _
'           "al."""
'    Debug.Print LucidaTextSetup(Text, 40, , , 3, 6)
'    Text = "I have a dream that one day on the red hills of Georgia " & _
'           "the sons of former slaves and the sons of former slaveow" & _
'           "ners will be able to sit down together at a table of bro" & _
'           "therhood."
'    Debug.Print LucidaTextSetup(Text, 40, LucidaCenter)
'    Text = "I have a dream that one day even the state of Mississipp" & _
'           "i, a desert state, sweltering with the heat of injustice" & _
'           " and oppression, will be transformed into an oasis of fr" & _
'           "eedom and justice."
'    Debug.Print LucidaTextSetup(Text, 40, LucidaRight)
'    Text = "I have a dream that my four children will one day live i" & _
'           "n a nation where they will not be judged by the color of" & _
'           " their skin but by the content of their character."
'    Debug.Print LucidaTextSetup(Text, 40, LucidaJustify, , 4, 2)
'    Debug.Print "I have a dream today."

'           +-------------------------------+
'           |      I have a dream that one  |
'           |   day this nation will rise   |
'           |   up and live out the true    |
'           |   meaning of its creed : "We  |
'           |   hold these truths to be     |
'           |   self-evident that all men   |
'           |   are created equal."         |
'           |                               |
'           |I have a dream that one day on |
'           | the red hills of Georgia the  |
'           |sons of former slaves and the  |
'           |  sons of former slaveowners   |
'           |   will be able to sit down    |
'           |    together at a table of     |
'           |         brotherhood.          |
'           |                               |
'           |   I have a dream that one day |
'           |even the state of Mississippi, |
'           |    a desert state, sweltering |
'           |with the heat of injustice and |
'           |           oppression, will be |
'           |  transformed into an oasis of |
'           |          freedom and justice. |
'           |                               |
'           |  I have a dream  that my four |
'           |    children will one day live |
'           |    in  a  nation  where  they |
'           |    will not be  judged by the |
'           |    color of their skin but by |
'           |    the   content   of   their |
'           |    character.                 |
'           |                               |
'           |I have a dream today.          |
'           +-------------------------------+

'-------------------------------   BUGS   -------------------------------'
'No bug reported.

'-----------------------------   SEE ALSO   -----------------------------'
'http://www.vbfrance.com/code.aspx?ID=36370 (by jean_marc_n2)

'------------------------   REQUIRED LIBRARIES   ------------------------'
'msvbvm60.dll, VB6.OLB, VB6FR.DLL (Always required)

'--------------------   REQUIRED MODULES AND FORMS   --------------------'
'None

'-----------------------------   OPTIONS   ------------------------------'
Option Base 0
Option Compare Text
Option Explicit

'+----------------------------------------------------------------------+'
'+                           TYPES AND ENUMS                            +'
'+----------------------------------------------------------------------+'
'Enum: ParagraphStyle
'   Enumeration of the paragraph styles.
'------------------------------------------------------------------------'
Enum LucidaStyle
    LucidaLeft = &H0
    LucidaJustify = &H1
    LucidaRight = &H2
    LucidaCenter = &H4
End Enum

'+----------------------------------------------------------------------+'
'+                             LAYOUT SETUP                             +'
'+----------------------------------------------------------------------+'
'Function: LucidaTextSetup
'   Returns a  string expression containing a  text setup with  a specific
'   layout.
'   Parameters: Text: A String expression specifying the text to setup the
'                   layout. If "Text" contains "Null", "Null" is returned.
'               Length: A numeric  expression specifying the width  of the
'                   layout. If  "Length" is not  greater than 0,  an error
'                   occurs.
'               ParagraphStyle (Optional): Specify the type of layout used
'                   to   setup   the   paragraphs    in   the   text.   If
'                   "ParagraphStyle" is  omitted, paragraphs  in text  are
'                   setup with left-style.
'               IsOneParagraph (Optional): A Boolean expression specifying
'                   if "Text" is considered as only one paragraph. Default
'                   value  is  "False":  Each   line  in  "Text"  makes  a
'                   paragraph.
'               ParagraphTab (Optional):  A numeric  expression specifying
'                   the number  of spaces to add  on the left side  of the
'                   text to  return. If "ParagraphTab"  is less than  0 or
'                   greater   than   "Length",   an   error   occurs.   If
'                   "ParagraphTab"   is   omitted,   two  cases:   1)   If
'                   "IsOneParagraph" is set to  "True" and "Text" contains
'                   more than  one line, "ParagraphTab"  is assumed  to be
'                   the tab of the second line. 2) In any other case, 0 is
'                   assumed.
'               FirstLineTab (Optional):  A numeric  expression specifying
'                   the number  of spaces to add  on the left side  of the
'                   first line  of each paragraph  of the text  to return.
'                   "FirstLineTab"     includes     "ParagraphTab".     If
'                   "FirstLineTab"  is   less  than  0  or   greater  than
'                   "Length",  an  error   occurs.  If  "FirstLineTab"  is
'                   omitted, it is assumed to be the tab of the first line
'                   for each paragraph in "Text".
'               LineSeparator (Optional): A string expression specifying a
'                   substring that represent a line separation. Default is
'                   vbCrLf (Chr(13) + Chr(10)).
'------------------------------------------------------------------------'
Function LucidaTextSetup(Text, Length As Long, Optional ParagraphStyle _
As LucidaStyle, Optional IsOneParagraph As Boolean, Optional _
ParagraphTab, Optional FirstLineTab, Optional LineSeparator As String = _
vbCrLf)
    Dim i As Long
    Dim Temp As String
    Dim Lines
    Dim PTab As Long
    'Split text into lines
    If IsNull(Text) Then
        LucidaTextSetup = Null
        Exit Function
    ElseIf Len(Text) = 0 Then
        Temp = Array("")
    Else
        Lines = Split(Text, LineSeparator)
    End If
    'If text is one paragraph...
    If IsOneParagraph Then
        'Calculate paragraph tab from second line
        If Not IsMissing(ParagraphTab) Then
            PTab = ParagraphTab
        ElseIf UBound(Lines) > 0 Then
            PTab = Len(Lines(1)) - Len(LTrim$(Lines(1)))
        End If
        'Concatenate lines into one paragraph
        Temp = Replace(Text, LineSeparator, " ")
        'Setup paragraph layout
        SetUpParagraph Temp, Length, ParagraphStyle, PTab, _
                       FirstLineTab, LineSeparator
    'If each line is a paragraph...
    Else
        'Setup layout for each line
        Temp = ""
        For i = 0 To UBound(Lines)
            SetUpParagraph Lines(i), Length, ParagraphStyle, _
                           ParagraphTab, FirstLineTab, LineSeparator
            Temp = Temp & IIf(i = 0, "", LineSeparator) & Lines(i)
        Next
    End If
    'Return value
    LucidaTextSetup = Temp
End Function

'------------------------------------------------------------------------'
'Sub: SetUpParagraph
'   Setup the layout of a paragraph.
'   Parameters: Text (Read/Write):  A  String  expression  specifying  the
'                   paragraph to setup the layout.
'               Length: A numeric  expression specifying the width  of the
'                   layout.
'               ParagraphStyle (Optional): Specify the type of layout used
'                   to  setup   the  paragraph.  If   "ParagraphStyle"  is
'                   omitted, paragraph is setup with left-style.
'               ParagraphTab (Optional):  A numeric  expression specifying
'                   the number  of spaces to add  on the left side  of the
'                   paragraph. If "ParagraphTab" is less than 0 or greater
'                   than "Length",  an error occurs. If  "ParagraphTab" is
'                   omitted, 0 is assumed.
'               FirstLineTab (Optional):  A numeric  expression specifying
'                   the number  of spaces to add  on the left side  of the
'                   first line  of the paragraph.  "FirstLineTab" includes
'                   "ParagraphTab". If  "FirstLineTab" is  less than  0 or
'                   greater   than   "Length",   an   error   occurs.   If
'                   "FirstLineTab" is omitted, it is assumed to be the tab
'                   of the first line of "Text".
'               LineSeparator (Optional): A string expression specifying a
'                   substring that represent a line separation. Default is
'                   vbCrLf (Chr(13) + Chr(10)).
'------------------------------------------------------------------------'
Private Sub SetUpParagraph(Text, Length As Long, ParagraphStyle As _
LucidaStyle, Optional ParagraphTab, Optional FirstLineTab, Optional _
LineSeparator As String)
    Dim Words
    Dim Position As Long
    Dim FLTab As Long
    Dim PTab As Long
    'Calculate first line tab
    If IsMissing(FirstLineTab) _
    Then FLTab = Len(Text) - Len(LTrim$(Text)) _
    Else: FLTab = CLng(FirstLineTab)
    'Calculate paragraph tab
    If IsMissing(ParagraphTab) _
    Then PTab = 0 _
    Else: PTab = CLng(ParagraphTab)
    'Remove left and right spaces
    Text = Trim$(Text)
    'Remove double-spaces
    Do While InStr(Text, "  ") > 0
        Text = Replace(Text, "  ", " ")
    Loop
    'Split text into an array of words
    If Len(Text) = 0 Then
        Words = Array("")
    Else
        Words = Split(Text)
    End If
    'Build first line
    Text = "": Position = 0
    AddLine Text, Words, Position, Length, _
            ParagraphStyle, FLTab, LineSeparator
    'Build other lines
    Do While Position <= UBound(Words)
        AddLine Text, Words, Position, Length, _
                ParagraphStyle, PTab, LineSeparator
    Loop
End Sub

'------------------------------------------------------------------------'
'Sub: AddLine
'   Add as much words as can contain a line to a paragraph.
'   Parameters: Text (Read/Write):  A  String  expression  specifying  the
'                   paragraph to add a line to.
'               Words(): An array  of strings containing the  words to add
'                   to the paragraph.
'               Position: A numeric expression  specifying the position of
'                   the next word to add to the paragraph.
'               Length: A numeric  expression specifying the width  of the
'                   layout.
'               ParagraphStyle: Specify the  type of layout used  to setup
'                   the paragraph.
'               LineTab:  A numeric  expression specifying  the number  of
'                   spaces to add on the left side of the line to add.
'               LineSeparator: A string expression  specifying a substring
'                   that represent a line separation.
'------------------------------------------------------------------------'
Private Sub AddLine(Text, Words, Position As Long, Length As Long, _
ParagraphStyle As LucidaStyle, LineTab As Long, LineSeparator As String)
    Dim Line As String
    Dim EOL As Boolean
    'I need to raise the error myself because:
    '1) If "LineTab" is negative, an error occurs in "Space$(LineTab)"
    '2) If  "LineTab"  is  greater  than  "Length",  an  error  occurs  in
    '   "Left$(Words(Position), Length - LineTab)"
    '3) If "Length" is negative, error (1) or (2) occurs
    '4) If "Length" is positive and  "LineTab" belongs to [0, "Length"[, a
    '   correct paragraph can be returned
    '5) Last  case  is "LineTab"  equal  to  "Length"  which leads  to  an
    '   everlasting loop
    If LineTab = Length Then Err.Raise 5
    'While there is still words to add and it's not the end of the line
    Do While Position <= UBound(Words) And Not EOL
        'If word can be added, add it and move to next
        If Len(Line) + Len(Words(Position)) + IIf(Len(Line) = 0, 0, 1) _
                <= Length - LineTab Then
            Line = Line & IIf(Len(Line) = 0, "", " ") & Words(Position)
            Position = Position + 1
        'If word cannot be added, set end of line
        Else
            EOL = True
        End If
    Loop
    'If no word fits in line
    If Len(Line) = 0 And EOL Then
        'Add length first characters of next word
        Line = Left$(Words(Position), Length - LineTab)
        Words(Position) = Mid$(Words(Position), Length - LineTab + 1)
    'Normal line to be setup
    Else
        'Do not setup justify for the last line
        If Position > UBound(Words) Then
            SetupLine Line, Length - LineTab, _
                      ParagraphStyle And Not LucidaJustify
        Else
            SetupLine Line, Length - LineTab, ParagraphStyle
        End If
    End If
    'Add new line to text
    Text = Text & IIf(Len(Text) = 0, "", LineSeparator) _
                & Space$(LineTab) & Line
End Sub

'------------------------------------------------------------------------'
'Sub: SetupLine
'   Setup the layout of a line.
'   Parameters: Line (Read/Write): A String expression specifying the line
'                   to setup the layout.
'               Length: A numeric  expression specifying the width  of the
'                   layout.
'               ParagraphStyle: Specify the  type of layout used  to setup
'                   the paragraph.
'------------------------------------------------------------------------'
Private Sub SetupLine(Line, Length As Long, ParagraphStyle As LucidaStyle)
    Dim i As Long
    Dim Words() As String
    Dim SpaceInLine As Long
    Dim SpaceToAdd As Long
    Dim SpaceAdded As Long
    Dim Spaces As String
    'If line has to be justified
    If Len(Line) > 0 And CBool(ParagraphStyle And LucidaJustify) Then
        'Split line into array of words
        Words = Split(Line)
        'Calculate number of spaces in line and to add
        SpaceInLine = UBound(Words) - LBound(Words)
        SpaceToAdd = Length - Len(Line)
        'Initialize line to first word
        Line = Words(LBound(Words))
        'Add other words one after the other
        For i = LBound(Words) + 1 To UBound(Words)
            'Build word separator
            Spaces = Space$(SpaceToAdd / SpaceInLine _


                                
  •  (i - LBound(Words)) - SpaceAdded)

            SpaceAdded = SpaceAdded + Len(Spaces)
            'Concatenate line, word separator and word
            Line = Line & " " & Spaces & Words(i)
        Next
    End If
    'Setup line position
    If ParagraphStyle And LucidaRight Then
        Line = Space$(Length - Len(Line)) & Line
    ElseIf ParagraphStyle And LucidaCenter Then
        Line = Space$((Length - Len(Line)) / 2) & Line
    End If
End Sub

'+----------------------------------------------------------------------+'
'+                NON-BREAKING SPACES SMART REPLACEMENT                 +'
'+----------------------------------------------------------------------+'
'Function: NBSPSmartInsert
'   Returns a  string in  which multiple  spaces have  been replaced  by a
'   smart combination of spaces and non-breaking spaces.
'   Solution 1: Replace all spaces by  non-breaking spaces. That makes the
'       change  irreversible.  A  non-breaking  space  between  two  words
'       prevent them to be split in two lines. If all spaces are replaced,
'       it will  be impossible  to tell whether  a non-breaking  space was
'       user-defined or added by the function.
'   Solution 2:  Replace all  double spaces  by a  combination of  space +
'       non-breaking  space.  The  change  is  reversible  as  long  as  a
'       user-defined non-breaking space  combined with a space  is totally
'       useless. The  lack of that solution  is that when displayed  in an
'       editor, it will not be possible to use Ctrl+Arrow (that usualy tab
'       from word to word) because it will tab every two spaces.
'   Solution  3:  Replace  all  groups of  "n"  spaces  by  the  following
'       combination: space  + "n-2" non-breaking  spaces + space.  In case
'       there  are only  2  spaces  in the  group,  they  are replaced  by
'       non-breaking space  + space. This change  is reversible and  it is
'       possible  to   tab  from   word  to  word.   To  achieve   such  a
'       transformation, I  perform the  following replacements.  Caret (^)
'       and tilde  (~) represent  2 non-string  character, underscore  (_)
'       represents a non-breaking space:
'                           Text: "word                    word"
'           Replace "  " by "^~": "word^~^~^~^~^~^~^~^~^~^~word"
'           Replace "~^" by "__": "word^__________________~word"
'           Replace "^"  by " " : "word __________________~word"
'           Replace "~"  by " " : "word __________________ word"
'   Parameters: Text:  A String  expression specifying  the text  in which
'                   multiple space have to be replaced.
'               NBSP:  String  character  representing the  value  of  the
'                   non-breaking space character in the current system.
'------------------------------------------------------------------------'
Function NBSPSmartInsert(Text As String, NBSP As String) As String
    Dim NoStr1 As String, NoStr2 As String
    NoStr1 = Chr$(0)
    NoStr2 = Chr$(1)
    NBSPSmartInsert = Replace(Replace(Replace(Replace(Replace(Replace( _
                              Text, _
                              "  ", NoStr1 & NoStr2), _
                              NoStr2 & NoStr1, NBSP & NBSP), _
                              NoStr1, " "), _
                              NoStr2, " "), _
                              "   ", " " & NBSP & " "), _
                              "  ", NBSP & " ")
End Function

'------------------------------------------------------------------------'
'Function: NBSPSmartRemove
'   Returns  a  string in  which  useless  non-breaking spaces  have  been
'   replaced by spaces.
'   Parameters: Text:  A String  expression specifying  the text  in which
'                   useless non-breaking spaces have to be replaced.
'               NBSP:  String  character  representing the  value  of  the
'                   non-breaking space character in the current system.
'------------------------------------------------------------------------'
Function NBSPSmartReplace(Text As String, NBSP As String) As String
    NBSPSmartReplace = Text
    Do While InStr(NBSPSmartReplace, NBSP & " ") > 0
        NBSPSmartReplace = Replace(NBSPSmartReplace, NBSP & " ", "  ")
    Loop
    Do While InStr(NBSPSmartReplace, " " & NBSP) > 0
        NBSPSmartReplace = Replace(NBSPSmartReplace, " " & NBSP, "  ")
    Loop
End Function

Conclusion :


J'ai tout fait pour que ma fonction soit la plus generale possible. Elle prend en compte ou non les retours a la ligne, et est capable d'analyser la mise en forme precedente pour y coller au mieux. Et elle conserve les espaces insecables (selon les conseils de Jean-Marc). Je vais m'en servir pour un projet de mise en forme de code VB. En attendant, utilisez la, notez la, trouvez les bugs, proposez des ameliorations et surtout dites le moi.
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (cs_santiago69)