Soyez le premier à donner votre avis sur cette source.
Vue 13 455 fois - Téléchargée 433 fois
'************************************************************************' '************************************************************************' '** **' '** 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 _
Option Base 1
C'est une erreur de ma part, d'habitude je met Option Base 0 qui ne sert a rien puisque c'est la valeur par defaut.
Pourquoi ?
La fonction Split() renvoi TOUJOURS un tableau qui commence a 0.
La fonction Array() renvoi un tableau qui comment a Option Base.
De plus la fontion Split renvoi un tableau vide si la chaine a decoupe est vide ("").
Donc pour ne pas avoir d'erreur lorsque je ne sais pas si la chaine est vide (par exemple un ligne vide qu'on essaierait de decouper en mots), j'effectue les actions suivantes
If Text = "" Then
Tableau = Array("")
Else
Tableau = Split(Text)
End If
En l'occurence, j'ai oublie d'ecrire ca dans ce code.
Option Compare Text
L'option par defaut est Option Compare Binary, en precisant Option Compare Text, on evite de reecrire ce choix dans les fonctions suivantes : Split(), InStr(), Replace(), etc...
En simple, Option Compare Binary est sensible a la casse, pas Option Compare Text.
Ce module n'utilise que Split() et a ma connaissance, l'espace et le retour a la ligne sont de toute facon non sensibles a la casse ;o)
A<E<a<e
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.