Les seuls que je reçoive sont en allemand
y viennent pas de Strasbourg par zarard ? ;-)))))))
Les seuls que je reçoive sont en allemand
y viennent pas de Strasbourg par zarard ? ;-)))))))
Les seuls que je reçoive sont en allemand
y viennent pas de Strasbourg par zarard ? ;-)))))))
Merci ! Muchas Gracias ! Thanks ! Efraristo para poly !
Bon, parlons peu, parlons bien : combien de bouteilles de pastis ?
André
"Anacoluthe" a écrit dans le message de
news:Bonjour André !
'AB' nous a écrit ...Ton algorithme conviendrait très bien si j'avais bien exposé le
problème.
Bon, je te propose de le faire en deux temps comme ça tu seras
plus libre de l'adapter à ton problème.
Dans un premier temps tu sectionnes ton document en plaçant
des sauts de section devant tes repères de découpe :
' _____________________________________________________
Public Sub SectionneDocument()
Dim R As Range
Dim sDebutSection As String
sDebutSection = "F^#^#^#^#^#" ' F puis 5 chiffres
Selection.HomeKey unit:=wdStory
With Selection.Find
.ClearFormatting
.Text = sDebutSection
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
Do While .Execute
Set R = Selection.Range
R.Collapse wdCollapseStart
R.InsertBreak wdSectionBreakNextPage
Selection.Collapse wdCollapseEnd
Loop
End With
Set R = Nothing
End Sub
' _____________________________________________________
Ensuite si le résultat te convient, en particulier au
niveau de la 1ère section, tu enregistres chaque section
dans un document séparé.
C'est une macro classique (utilisée en publipostage notamment)
que je te modifie un peu : le nom du fichier sera composé
des 6 premiers caractères de la section cad ton Fxxxxx
' _____________________________________________________
Sub SectionsDansDocumentsSéparés()
Dim SousDoc As Document
Dim R As Range
Dim S As Section
For Each S In ActiveDocument.Sections
Set R = S.Range: R.End = R.End - 1
Set SousDoc = Documents.Add
With SousDoc
.Content = R
.SaveAs FileName:=Left(R.Text, 6)
.Close
End With
Next S
Set SousDoc = Nothing
Set R = Nothing
Set S = Nothing
End Sub
' _____________________________________________________
Bon dimanche !
Anacoluthe
« Tout problème simple a une solution complexe...
qui ne fonctionne pas. »
- Olivier LOCKERT
Merci ! Muchas Gracias ! Thanks ! Efraristo para poly !
Bon, parlons peu, parlons bien : combien de bouteilles de pastis ?
André
"Anacoluthe" <nopub_anacoluthe@Ouanadoo.fr> a écrit dans le message de
news: OLePbIbwFHA.724@TK2MSFTNGP14.phx.gbl...
Bonjour André !
'AB' nous a écrit ...
Ton algorithme conviendrait très bien si j'avais bien exposé le
problème.
Bon, je te propose de le faire en deux temps comme ça tu seras
plus libre de l'adapter à ton problème.
Dans un premier temps tu sectionnes ton document en plaçant
des sauts de section devant tes repères de découpe :
' _____________________________________________________
Public Sub SectionneDocument()
Dim R As Range
Dim sDebutSection As String
sDebutSection = "F^#^#^#^#^#" ' F puis 5 chiffres
Selection.HomeKey unit:=wdStory
With Selection.Find
.ClearFormatting
.Text = sDebutSection
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
Do While .Execute
Set R = Selection.Range
R.Collapse wdCollapseStart
R.InsertBreak wdSectionBreakNextPage
Selection.Collapse wdCollapseEnd
Loop
End With
Set R = Nothing
End Sub
' _____________________________________________________
Ensuite si le résultat te convient, en particulier au
niveau de la 1ère section, tu enregistres chaque section
dans un document séparé.
C'est une macro classique (utilisée en publipostage notamment)
que je te modifie un peu : le nom du fichier sera composé
des 6 premiers caractères de la section cad ton Fxxxxx
' _____________________________________________________
Sub SectionsDansDocumentsSéparés()
Dim SousDoc As Document
Dim R As Range
Dim S As Section
For Each S In ActiveDocument.Sections
Set R = S.Range: R.End = R.End - 1
Set SousDoc = Documents.Add
With SousDoc
.Content = R
.SaveAs FileName:=Left(R.Text, 6)
.Close
End With
Next S
Set SousDoc = Nothing
Set R = Nothing
Set S = Nothing
End Sub
' _____________________________________________________
Bon dimanche !
Anacoluthe
« Tout problème simple a une solution complexe...
qui ne fonctionne pas. »
- Olivier LOCKERT
Merci ! Muchas Gracias ! Thanks ! Efraristo para poly !
Bon, parlons peu, parlons bien : combien de bouteilles de pastis ?
André
"Anacoluthe" a écrit dans le message de
news:Bonjour André !
'AB' nous a écrit ...Ton algorithme conviendrait très bien si j'avais bien exposé le
problème.
Bon, je te propose de le faire en deux temps comme ça tu seras
plus libre de l'adapter à ton problème.
Dans un premier temps tu sectionnes ton document en plaçant
des sauts de section devant tes repères de découpe :
' _____________________________________________________
Public Sub SectionneDocument()
Dim R As Range
Dim sDebutSection As String
sDebutSection = "F^#^#^#^#^#" ' F puis 5 chiffres
Selection.HomeKey unit:=wdStory
With Selection.Find
.ClearFormatting
.Text = sDebutSection
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
Do While .Execute
Set R = Selection.Range
R.Collapse wdCollapseStart
R.InsertBreak wdSectionBreakNextPage
Selection.Collapse wdCollapseEnd
Loop
End With
Set R = Nothing
End Sub
' _____________________________________________________
Ensuite si le résultat te convient, en particulier au
niveau de la 1ère section, tu enregistres chaque section
dans un document séparé.
C'est une macro classique (utilisée en publipostage notamment)
que je te modifie un peu : le nom du fichier sera composé
des 6 premiers caractères de la section cad ton Fxxxxx
' _____________________________________________________
Sub SectionsDansDocumentsSéparés()
Dim SousDoc As Document
Dim R As Range
Dim S As Section
For Each S In ActiveDocument.Sections
Set R = S.Range: R.End = R.End - 1
Set SousDoc = Documents.Add
With SousDoc
.Content = R
.SaveAs FileName:=Left(R.Text, 6)
.Close
End With
Next S
Set SousDoc = Nothing
Set R = Nothing
Set S = Nothing
End Sub
' _____________________________________________________
Bon dimanche !
Anacoluthe
« Tout problème simple a une solution complexe...
qui ne fonctionne pas. »
- Olivier LOCKERT
Encore une petite question, si ce n'est point abuser.
Comment faire en sorte que le nom de chaque fichier créé soit extrait de
la première ligne de chaque section, et non seulement des 6 premiers
caractères ? (En réalité, chaque section nouvellement créée commence par
Fxxxxx + du texte de longueur variable, qui représente le titre de
l'ancien paragraphe, et que je souhaiterais conserver)
Faut changer cette ligne :
.SaveAs FileName:=Left(R.Text, 6)
Mais la remplacer par quoi ?
Encore une petite question, si ce n'est point abuser.
Comment faire en sorte que le nom de chaque fichier créé soit extrait de
la première ligne de chaque section, et non seulement des 6 premiers
caractères ? (En réalité, chaque section nouvellement créée commence par
Fxxxxx + du texte de longueur variable, qui représente le titre de
l'ancien paragraphe, et que je souhaiterais conserver)
Faut changer cette ligne :
.SaveAs FileName:=Left(R.Text, 6)
Mais la remplacer par quoi ?
Encore une petite question, si ce n'est point abuser.
Comment faire en sorte que le nom de chaque fichier créé soit extrait de
la première ligne de chaque section, et non seulement des 6 premiers
caractères ? (En réalité, chaque section nouvellement créée commence par
Fxxxxx + du texte de longueur variable, qui représente le titre de
l'ancien paragraphe, et que je souhaiterais conserver)
Faut changer cette ligne :
.SaveAs FileName:=Left(R.Text, 6)
Mais la remplacer par quoi ?
Bonjour ABEncore une petite question, si ce n'est point abuser.
Comment faire en sorte que le nom de chaque fichier créé soit extrait de
la première ligne de chaque section, et non seulement des 6 premiers
caractères ? (En réalité, chaque section nouvellement créée commence par
Fxxxxx + du texte de longueur variable, qui représente le titre de
l'ancien paragraphe, et que je souhaiterais conserver)
Faut changer cette ligne :
.SaveAs FileName:=Left(R.Text, 6)
Mais la remplacer par quoi ?
S'il n'y a pas d'espace dans le nom :
.SaveAs FileName:=R.word(1)
--
A+
Bonjour AB
Encore une petite question, si ce n'est point abuser.
Comment faire en sorte que le nom de chaque fichier créé soit extrait de
la première ligne de chaque section, et non seulement des 6 premiers
caractères ? (En réalité, chaque section nouvellement créée commence par
Fxxxxx + du texte de longueur variable, qui représente le titre de
l'ancien paragraphe, et que je souhaiterais conserver)
Faut changer cette ligne :
.SaveAs FileName:=Left(R.Text, 6)
Mais la remplacer par quoi ?
S'il n'y a pas d'espace dans le nom :
.SaveAs FileName:=R.word(1)
--
A+
Bonjour ABEncore une petite question, si ce n'est point abuser.
Comment faire en sorte que le nom de chaque fichier créé soit extrait de
la première ligne de chaque section, et non seulement des 6 premiers
caractères ? (En réalité, chaque section nouvellement créée commence par
Fxxxxx + du texte de longueur variable, qui représente le titre de
l'ancien paragraphe, et que je souhaiterais conserver)
Faut changer cette ligne :
.SaveAs FileName:=Left(R.Text, 6)
Mais la remplacer par quoi ?
S'il n'y a pas d'espace dans le nom :
.SaveAs FileName:=R.word(1)
--
A+
Salut Geo,
Merci de ton aide.
Ca ne marche pas ("erreur de compilation...membre de méthode ou de données
introuvable)
R = ActiveDocument.Paragraphs(1).Range
ActiveDocument.SaveAs FileName:=R & ".doc"
Salut Geo,
Merci de ton aide.
Ca ne marche pas ("erreur de compilation...membre de méthode ou de données
introuvable)
R = ActiveDocument.Paragraphs(1).Range
ActiveDocument.SaveAs FileName:=R & ".doc"
Salut Geo,
Merci de ton aide.
Ca ne marche pas ("erreur de compilation...membre de méthode ou de données
introuvable)
R = ActiveDocument.Paragraphs(1).Range
ActiveDocument.SaveAs FileName:=R & ".doc"
Bonjour !
'AB' nous a écrit ...Salut Geo,
Merci de ton aide.
Ca ne marche pas ("erreur de compilation...membre de méthode ou de
données introuvable)
T'inquiète André, on y est presque :-)
Pour cette 1ère erreur c'est juste qu'il fallait écrire
Filename:= R.Words(1)
Words et non Word : la collection des mots
Mais bon, le premier mot ne te convient pas semble-t-il
tu veux le 1er paragrapheR = ActiveDocument.Paragraphs(1).Range
ActiveDocument.SaveAs FileName:=R & ".doc"
Là ça plante parce que le 1er paragraphe contient aussi la
marque de fin de paragraphe : pas bon dans un nom de fichier !
Dans ma deuxième macro de ce fil remplace
With SousDoc
.Content = R
.SaveAs FileName:=Left(R.Text, 6)
.Close
End With
par
With SousDoc
.Content = R
R.SetRange Start:=R.Start, _
End:=R.Paragraphs(1).Range.End - 1
.SaveAs FileName:=R.Text & ".doc"
.Close
End With
'Tomate' le pastis, n'oublie pas :-)
Anacoluthe
« Tout problème simple a une solution complexe...
qui ne fonctionne pas. »
- Olivier LOCKERT
Bonjour !
'AB' nous a écrit ...
Salut Geo,
Merci de ton aide.
Ca ne marche pas ("erreur de compilation...membre de méthode ou de
données introuvable)
T'inquiète André, on y est presque :-)
Pour cette 1ère erreur c'est juste qu'il fallait écrire
Filename:= R.Words(1)
Words et non Word : la collection des mots
Mais bon, le premier mot ne te convient pas semble-t-il
tu veux le 1er paragraphe
R = ActiveDocument.Paragraphs(1).Range
ActiveDocument.SaveAs FileName:=R & ".doc"
Là ça plante parce que le 1er paragraphe contient aussi la
marque de fin de paragraphe : pas bon dans un nom de fichier !
Dans ma deuxième macro de ce fil remplace
With SousDoc
.Content = R
.SaveAs FileName:=Left(R.Text, 6)
.Close
End With
par
With SousDoc
.Content = R
R.SetRange Start:=R.Start, _
End:=R.Paragraphs(1).Range.End - 1
.SaveAs FileName:=R.Text & ".doc"
.Close
End With
'Tomate' le pastis, n'oublie pas :-)
Anacoluthe
« Tout problème simple a une solution complexe...
qui ne fonctionne pas. »
- Olivier LOCKERT
Bonjour !
'AB' nous a écrit ...Salut Geo,
Merci de ton aide.
Ca ne marche pas ("erreur de compilation...membre de méthode ou de
données introuvable)
T'inquiète André, on y est presque :-)
Pour cette 1ère erreur c'est juste qu'il fallait écrire
Filename:= R.Words(1)
Words et non Word : la collection des mots
Mais bon, le premier mot ne te convient pas semble-t-il
tu veux le 1er paragrapheR = ActiveDocument.Paragraphs(1).Range
ActiveDocument.SaveAs FileName:=R & ".doc"
Là ça plante parce que le 1er paragraphe contient aussi la
marque de fin de paragraphe : pas bon dans un nom de fichier !
Dans ma deuxième macro de ce fil remplace
With SousDoc
.Content = R
.SaveAs FileName:=Left(R.Text, 6)
.Close
End With
par
With SousDoc
.Content = R
R.SetRange Start:=R.Start, _
End:=R.Paragraphs(1).Range.End - 1
.SaveAs FileName:=R.Text & ".doc"
.Close
End With
'Tomate' le pastis, n'oublie pas :-)
Anacoluthe
« Tout problème simple a une solution complexe...
qui ne fonctionne pas. »
- Olivier LOCKERT
Bonjour à tous,
dans le message ,
| Autre problème : s'il y a un caractère interdit dans le titre "(",
| "/", ",", etc.), ça plante (ce qui est normal).
| Il faut donc que je reparcourre tout le document pour faire la
| chasse aux caractères indésirables. C'est un peu barbant, mais
| faisable.
Je prends le fil en marche...
Tu dis que ce problème concerne le titre, donc a priori une chaîne
définie : il est donc inutile de parcourir le document pour en évacuer
les caractères "interdits". Pour ma part je dispose de deux outils qui
me permettent de faire cela :
- une fonction fstrRemplaceTous, qui remplace toutes les occurences d'un
caractère dans une chaîne,
- une fonction Splitter, qui a besoin de fstrRemplaceTous, et qui
découpe une chaîne en fonction d'une liste de séparateurs qui peuvent
être tes catactères interdits. Cette fonction fournit une collection
dont il suffit de concaténer les membres pour obtenir la chaîne
débarassée de ses caractères indésirables.
============= >
Private Sub Splitter(ByVal strTexte As String, colListeDeMots As
Collection, ParamArray Separateurs() As Variant)
' Découpe le Texte en entrée, en mots, en fonction du ou des
séparateurs désignés
' Elimine les blancs non significatifs (gauche et droite) des mots
' Fournit une collection des mots
' Il est impératif d'avoir vbCR ou VBVerticalTab comme séparateur
' pour régler le cas où le texte à traiter incorpore une fin de ligne.
'Syntaxe pour Separateurs()
' a) "c1","c2", ... liste de caractères ou liste de
chaînes
' b) "[c1,c2-c9,c10]" énumération de caractères avec c2-c9 > de c2 à c9, c2<c9 ou c2>É
' c) "{k1,k2-k9,k10}" énumération de codes ASCII
'Attention : il y a peu de vérifications de syntaxe
Dim CharSep As String, strMarqueur As String, strMot As String
Dim intIndex As Integer, intPos As Integer, iBoucle As Integer, jBoucle
As Integer
Dim CodeAscii1 As Integer, CodeAscii2 As Integer
Dim colSeparateurs As New Collection, ColTemp As Collection, colTemp1 As
Collection, Mot As Variant
Dim DebTab As Integer, FinTab As Integer
Dim Bid As Integer
'Teste la validité de la chaîne entrée
If strTexte = "" Then
MsgBox "La chaîne à découper est vide", vbOKOnly + vbCritical,
"Découpage d'une chaîne"
Exit Sub
End If
'Teste la présence du tableau de paramètres
If IsMissing(Separateurs()) Then
colListeDeMots.Add strTexte
MsgBox "Aucun séparateur valide n'a été spécifié", vbOKOnly +
vbCritical, "Découpage d'une chaîne"
Exit Sub
End If
'Taille du tableau de paramètres
DebTab = LBound(Separateurs)
FinTab = UBound(Separateurs)
'Traitement éventuel des énumérations
For iBoucle = DebTab To FinTab
If Separateurs(iBoucle) Like Chr(0) Or Separateurs(iBoucle) Like
Chr(1) Then
MsgBox "Chr(0) et Chr(1) sont des séparateurs interdits.",
vbOKOnly + vbCritical, "Découpage d'une chaîne"
Exit Sub
End If
If Separateurs(iBoucle) Like "[[]*[]]" Then
' Enumérations de caractères
Set ColTemp = New Collection
'Il y a un problème avec les énumérations et les espaces en tant
que séparateurs.
'Comme les blancs non significatifs sont éliminés, c'est vrai
aussi dans la liste
'des paramètres, puisque Splitter fait appel à lui-même.
Provisoirement on remplace les espaces par chr(0).
Separateurs(iBoucle) = fstrRemplaceTous(1, Chr(32), Chr(1),
Separateurs(iBoucle))
Splitter Separateurs(iBoucle), ColTemp, "[", "]", ","
For Each Mot In ColTemp
''On rétablit les espaces
Mot = fstrRemplaceTous(1, Chr(1), Chr(32), Mot)
If Mot Like "?-?" Then
Set colTemp1 = New Collection
Splitter Mot, colTemp1, "-"
CodeAscii1 = Asc(colTemp1(1))
CodeAscii2 = Asc(colTemp1(2))
'On range dans l'ordre croissant
If CodeAscii1 > CodeAscii2 Then
Bid = CodeAscii1
CodeAscii1 = CodeAscii2
CodeAscii2 = Bid
End If
For jBoucle = CodeAscii1 To CodeAscii2
colSeparateurs.Add Chr(jBoucle)
Next jBoucle
Set colTemp1 = Nothing
Else
colSeparateurs.Add Mot
End If
Next Mot
Set ColTemp = Nothing
ElseIf Separateurs(iBoucle) Like "[{]*[}]" Then
' Enumération de codes ASCII
Set ColTemp = New Collection
Splitter Separateurs(iBoucle), ColTemp, "{", "}", ","
For Each Mot In ColTemp
strMot = CStr(Mot)
If strMot Like "*-*" Then
Set colTemp1 = New Collection
Splitter strMot, colTemp1, "-"
CodeAscii1 = colTemp1(1)
CodeAscii2 = colTemp1(2)
'On range dans l'ordre croissant
If CodeAscii1 > CodeAscii2 Then
Bid = CodeAscii1
CodeAscii1 = CodeAscii2
CodeAscii2 = Bid
End If
For jBoucle = CodeAscii1 To CodeAscii2
colSeparateurs.Add Chr(jBoucle)
Next jBoucle
Set colTemp1 = Nothing
Else
colSeparateurs.Add Chr(strMot)
End If
Next Mot
Set ColTemp = Nothing
Else
colSeparateurs.Add Separateurs(iBoucle)
End If
Next iBoucle
' Pour un simple découpage, on ne différencie pas les séparateurs.
' On les remplace par un seul. Pour accepter des mots comme séparateur,
' on remplace tous les séparateurs par un caractère qu'il est
impossible
' de trouver dans une chaîne : chr(0)
strMarqueur = Chr(0)
For iBoucle = 1 To colSeparateurs.Count
CharSep = CStr(colSeparateurs(iBoucle))
strTexte = fstrRemplaceTous(1, CharSep, strMarqueur, strTexte)
Next iBoucle
'On vide la collection de séparateurs
Set colSeparateurs = Nothing
' Maintenant on peut découper
intPos = 1
intIndex = 1
While intIndex <> 0
intIndex = InStr(intPos, strTexte, strMarqueur)
Select Case intIndex
Case 0 ' Il n'y a pas de séparateur
strMot = Trim(Mid(strTexte, intPos, Len(strTexte) - intPos + 1))
If strMot <> "" Then colListeDeMots.Add strMot
Case Else ' Il y a un séparateur
strMot = Trim(Mid(strTexte, intPos, intIndex - intPos))
If strMot <> "" Then colListeDeMots.Add strMot
intPos = intIndex + 1
End Select
Wend
End Sub
Private Function fstrRemplaceTous(lngDépart As Long, strVieilleChaine As
String, strNouvelleChaine As String, ByVal strTexte As String) As String
Dim TailleVieilleChn As Integer
Dim Index As Integer, Pos As Integer, TailleNouvelChn As Integer,
taillestrTexte As Integer
'Remplace toutes les occurences de la chaîne strVieilleChaine par la
chaîne
'strNouvelleChaine dans strTexte
'Peut donc être utilisée pour des suppressions, strNouvelleChaine="",
'ou pour compter les caractères :
'nbcar = Len(Texte) - Len(fstrReplace(char, "", Texte))
' Noter que strTexte n'est pas modifié.
fstrRemplaceTous = strTexte
If lngDépart < 1 Or lngDépart > Len(strTexte) - Len(strVieilleChaine) +
1 Then
Exit Function
End If
If strVieilleChaine = "" Or strVieilleChaine = strNouvelleChaine Then
Exit Function
TailleVieilleChn = Len(strVieilleChaine)
TailleNouvelChn = Len(strNouvelleChaine)
Index = 1
Pos = lngDépart
While Index <> 0
taillestrTexte = Len(strTexte)
Index = InStr(Pos, strTexte, strVieilleChaine)
Select Case Index
Case 0 '
rien à remplacer
Case taillestrTexte - TailleVieilleChn + 1 ' une seule
chaîne à droite
strTexte = Left(strTexte, Index - 1) & strNouvelleChaine
Index = 0
Case Else '
au moins une chaîne
strTexte = Left(strTexte, Index - 1) & strNouvelleChaine &
Mid(strTexte, Index + TailleVieilleChn)
Pos = Index + TailleNouvelChn
End Select
Wend
fstrRemplaceTous = strTexte
End Function
--
Bonjour à tous,
dans le message ekB1M0gwFHA.3860@TK2MSFTNGP09.phx.gbl,
| Autre problème : s'il y a un caractère interdit dans le titre "(",
| "/", ",", etc.), ça plante (ce qui est normal).
| Il faut donc que je reparcourre tout le document pour faire la
| chasse aux caractères indésirables. C'est un peu barbant, mais
| faisable.
Je prends le fil en marche...
Tu dis que ce problème concerne le titre, donc a priori une chaîne
définie : il est donc inutile de parcourir le document pour en évacuer
les caractères "interdits". Pour ma part je dispose de deux outils qui
me permettent de faire cela :
- une fonction fstrRemplaceTous, qui remplace toutes les occurences d'un
caractère dans une chaîne,
- une fonction Splitter, qui a besoin de fstrRemplaceTous, et qui
découpe une chaîne en fonction d'une liste de séparateurs qui peuvent
être tes catactères interdits. Cette fonction fournit une collection
dont il suffit de concaténer les membres pour obtenir la chaîne
débarassée de ses caractères indésirables.
============= >
Private Sub Splitter(ByVal strTexte As String, colListeDeMots As
Collection, ParamArray Separateurs() As Variant)
' Découpe le Texte en entrée, en mots, en fonction du ou des
séparateurs désignés
' Elimine les blancs non significatifs (gauche et droite) des mots
' Fournit une collection des mots
' Il est impératif d'avoir vbCR ou VBVerticalTab comme séparateur
' pour régler le cas où le texte à traiter incorpore une fin de ligne.
'Syntaxe pour Separateurs()
' a) "c1","c2", ... liste de caractères ou liste de
chaînes
' b) "[c1,c2-c9,c10]" énumération de caractères avec c2-c9 > de c2 à c9, c2<c9 ou c2>É
' c) "{k1,k2-k9,k10}" énumération de codes ASCII
'Attention : il y a peu de vérifications de syntaxe
Dim CharSep As String, strMarqueur As String, strMot As String
Dim intIndex As Integer, intPos As Integer, iBoucle As Integer, jBoucle
As Integer
Dim CodeAscii1 As Integer, CodeAscii2 As Integer
Dim colSeparateurs As New Collection, ColTemp As Collection, colTemp1 As
Collection, Mot As Variant
Dim DebTab As Integer, FinTab As Integer
Dim Bid As Integer
'Teste la validité de la chaîne entrée
If strTexte = "" Then
MsgBox "La chaîne à découper est vide", vbOKOnly + vbCritical,
"Découpage d'une chaîne"
Exit Sub
End If
'Teste la présence du tableau de paramètres
If IsMissing(Separateurs()) Then
colListeDeMots.Add strTexte
MsgBox "Aucun séparateur valide n'a été spécifié", vbOKOnly +
vbCritical, "Découpage d'une chaîne"
Exit Sub
End If
'Taille du tableau de paramètres
DebTab = LBound(Separateurs)
FinTab = UBound(Separateurs)
'Traitement éventuel des énumérations
For iBoucle = DebTab To FinTab
If Separateurs(iBoucle) Like Chr(0) Or Separateurs(iBoucle) Like
Chr(1) Then
MsgBox "Chr(0) et Chr(1) sont des séparateurs interdits.",
vbOKOnly + vbCritical, "Découpage d'une chaîne"
Exit Sub
End If
If Separateurs(iBoucle) Like "[[]*[]]" Then
' Enumérations de caractères
Set ColTemp = New Collection
'Il y a un problème avec les énumérations et les espaces en tant
que séparateurs.
'Comme les blancs non significatifs sont éliminés, c'est vrai
aussi dans la liste
'des paramètres, puisque Splitter fait appel à lui-même.
Provisoirement on remplace les espaces par chr(0).
Separateurs(iBoucle) = fstrRemplaceTous(1, Chr(32), Chr(1),
Separateurs(iBoucle))
Splitter Separateurs(iBoucle), ColTemp, "[", "]", ","
For Each Mot In ColTemp
''On rétablit les espaces
Mot = fstrRemplaceTous(1, Chr(1), Chr(32), Mot)
If Mot Like "?-?" Then
Set colTemp1 = New Collection
Splitter Mot, colTemp1, "-"
CodeAscii1 = Asc(colTemp1(1))
CodeAscii2 = Asc(colTemp1(2))
'On range dans l'ordre croissant
If CodeAscii1 > CodeAscii2 Then
Bid = CodeAscii1
CodeAscii1 = CodeAscii2
CodeAscii2 = Bid
End If
For jBoucle = CodeAscii1 To CodeAscii2
colSeparateurs.Add Chr(jBoucle)
Next jBoucle
Set colTemp1 = Nothing
Else
colSeparateurs.Add Mot
End If
Next Mot
Set ColTemp = Nothing
ElseIf Separateurs(iBoucle) Like "[{]*[}]" Then
' Enumération de codes ASCII
Set ColTemp = New Collection
Splitter Separateurs(iBoucle), ColTemp, "{", "}", ","
For Each Mot In ColTemp
strMot = CStr(Mot)
If strMot Like "*-*" Then
Set colTemp1 = New Collection
Splitter strMot, colTemp1, "-"
CodeAscii1 = colTemp1(1)
CodeAscii2 = colTemp1(2)
'On range dans l'ordre croissant
If CodeAscii1 > CodeAscii2 Then
Bid = CodeAscii1
CodeAscii1 = CodeAscii2
CodeAscii2 = Bid
End If
For jBoucle = CodeAscii1 To CodeAscii2
colSeparateurs.Add Chr(jBoucle)
Next jBoucle
Set colTemp1 = Nothing
Else
colSeparateurs.Add Chr(strMot)
End If
Next Mot
Set ColTemp = Nothing
Else
colSeparateurs.Add Separateurs(iBoucle)
End If
Next iBoucle
' Pour un simple découpage, on ne différencie pas les séparateurs.
' On les remplace par un seul. Pour accepter des mots comme séparateur,
' on remplace tous les séparateurs par un caractère qu'il est
impossible
' de trouver dans une chaîne : chr(0)
strMarqueur = Chr(0)
For iBoucle = 1 To colSeparateurs.Count
CharSep = CStr(colSeparateurs(iBoucle))
strTexte = fstrRemplaceTous(1, CharSep, strMarqueur, strTexte)
Next iBoucle
'On vide la collection de séparateurs
Set colSeparateurs = Nothing
' Maintenant on peut découper
intPos = 1
intIndex = 1
While intIndex <> 0
intIndex = InStr(intPos, strTexte, strMarqueur)
Select Case intIndex
Case 0 ' Il n'y a pas de séparateur
strMot = Trim(Mid(strTexte, intPos, Len(strTexte) - intPos + 1))
If strMot <> "" Then colListeDeMots.Add strMot
Case Else ' Il y a un séparateur
strMot = Trim(Mid(strTexte, intPos, intIndex - intPos))
If strMot <> "" Then colListeDeMots.Add strMot
intPos = intIndex + 1
End Select
Wend
End Sub
Private Function fstrRemplaceTous(lngDépart As Long, strVieilleChaine As
String, strNouvelleChaine As String, ByVal strTexte As String) As String
Dim TailleVieilleChn As Integer
Dim Index As Integer, Pos As Integer, TailleNouvelChn As Integer,
taillestrTexte As Integer
'Remplace toutes les occurences de la chaîne strVieilleChaine par la
chaîne
'strNouvelleChaine dans strTexte
'Peut donc être utilisée pour des suppressions, strNouvelleChaine="",
'ou pour compter les caractères :
'nbcar = Len(Texte) - Len(fstrReplace(char, "", Texte))
' Noter que strTexte n'est pas modifié.
fstrRemplaceTous = strTexte
If lngDépart < 1 Or lngDépart > Len(strTexte) - Len(strVieilleChaine) +
1 Then
Exit Function
End If
If strVieilleChaine = "" Or strVieilleChaine = strNouvelleChaine Then
Exit Function
TailleVieilleChn = Len(strVieilleChaine)
TailleNouvelChn = Len(strNouvelleChaine)
Index = 1
Pos = lngDépart
While Index <> 0
taillestrTexte = Len(strTexte)
Index = InStr(Pos, strTexte, strVieilleChaine)
Select Case Index
Case 0 '
rien à remplacer
Case taillestrTexte - TailleVieilleChn + 1 ' une seule
chaîne à droite
strTexte = Left(strTexte, Index - 1) & strNouvelleChaine
Index = 0
Case Else '
au moins une chaîne
strTexte = Left(strTexte, Index - 1) & strNouvelleChaine &
Mid(strTexte, Index + TailleVieilleChn)
Pos = Index + TailleNouvelChn
End Select
Wend
fstrRemplaceTous = strTexte
End Function
--
Bonjour à tous,
dans le message ,
| Autre problème : s'il y a un caractère interdit dans le titre "(",
| "/", ",", etc.), ça plante (ce qui est normal).
| Il faut donc que je reparcourre tout le document pour faire la
| chasse aux caractères indésirables. C'est un peu barbant, mais
| faisable.
Je prends le fil en marche...
Tu dis que ce problème concerne le titre, donc a priori une chaîne
définie : il est donc inutile de parcourir le document pour en évacuer
les caractères "interdits". Pour ma part je dispose de deux outils qui
me permettent de faire cela :
- une fonction fstrRemplaceTous, qui remplace toutes les occurences d'un
caractère dans une chaîne,
- une fonction Splitter, qui a besoin de fstrRemplaceTous, et qui
découpe une chaîne en fonction d'une liste de séparateurs qui peuvent
être tes catactères interdits. Cette fonction fournit une collection
dont il suffit de concaténer les membres pour obtenir la chaîne
débarassée de ses caractères indésirables.
============= >
Private Sub Splitter(ByVal strTexte As String, colListeDeMots As
Collection, ParamArray Separateurs() As Variant)
' Découpe le Texte en entrée, en mots, en fonction du ou des
séparateurs désignés
' Elimine les blancs non significatifs (gauche et droite) des mots
' Fournit une collection des mots
' Il est impératif d'avoir vbCR ou VBVerticalTab comme séparateur
' pour régler le cas où le texte à traiter incorpore une fin de ligne.
'Syntaxe pour Separateurs()
' a) "c1","c2", ... liste de caractères ou liste de
chaînes
' b) "[c1,c2-c9,c10]" énumération de caractères avec c2-c9 > de c2 à c9, c2<c9 ou c2>É
' c) "{k1,k2-k9,k10}" énumération de codes ASCII
'Attention : il y a peu de vérifications de syntaxe
Dim CharSep As String, strMarqueur As String, strMot As String
Dim intIndex As Integer, intPos As Integer, iBoucle As Integer, jBoucle
As Integer
Dim CodeAscii1 As Integer, CodeAscii2 As Integer
Dim colSeparateurs As New Collection, ColTemp As Collection, colTemp1 As
Collection, Mot As Variant
Dim DebTab As Integer, FinTab As Integer
Dim Bid As Integer
'Teste la validité de la chaîne entrée
If strTexte = "" Then
MsgBox "La chaîne à découper est vide", vbOKOnly + vbCritical,
"Découpage d'une chaîne"
Exit Sub
End If
'Teste la présence du tableau de paramètres
If IsMissing(Separateurs()) Then
colListeDeMots.Add strTexte
MsgBox "Aucun séparateur valide n'a été spécifié", vbOKOnly +
vbCritical, "Découpage d'une chaîne"
Exit Sub
End If
'Taille du tableau de paramètres
DebTab = LBound(Separateurs)
FinTab = UBound(Separateurs)
'Traitement éventuel des énumérations
For iBoucle = DebTab To FinTab
If Separateurs(iBoucle) Like Chr(0) Or Separateurs(iBoucle) Like
Chr(1) Then
MsgBox "Chr(0) et Chr(1) sont des séparateurs interdits.",
vbOKOnly + vbCritical, "Découpage d'une chaîne"
Exit Sub
End If
If Separateurs(iBoucle) Like "[[]*[]]" Then
' Enumérations de caractères
Set ColTemp = New Collection
'Il y a un problème avec les énumérations et les espaces en tant
que séparateurs.
'Comme les blancs non significatifs sont éliminés, c'est vrai
aussi dans la liste
'des paramètres, puisque Splitter fait appel à lui-même.
Provisoirement on remplace les espaces par chr(0).
Separateurs(iBoucle) = fstrRemplaceTous(1, Chr(32), Chr(1),
Separateurs(iBoucle))
Splitter Separateurs(iBoucle), ColTemp, "[", "]", ","
For Each Mot In ColTemp
''On rétablit les espaces
Mot = fstrRemplaceTous(1, Chr(1), Chr(32), Mot)
If Mot Like "?-?" Then
Set colTemp1 = New Collection
Splitter Mot, colTemp1, "-"
CodeAscii1 = Asc(colTemp1(1))
CodeAscii2 = Asc(colTemp1(2))
'On range dans l'ordre croissant
If CodeAscii1 > CodeAscii2 Then
Bid = CodeAscii1
CodeAscii1 = CodeAscii2
CodeAscii2 = Bid
End If
For jBoucle = CodeAscii1 To CodeAscii2
colSeparateurs.Add Chr(jBoucle)
Next jBoucle
Set colTemp1 = Nothing
Else
colSeparateurs.Add Mot
End If
Next Mot
Set ColTemp = Nothing
ElseIf Separateurs(iBoucle) Like "[{]*[}]" Then
' Enumération de codes ASCII
Set ColTemp = New Collection
Splitter Separateurs(iBoucle), ColTemp, "{", "}", ","
For Each Mot In ColTemp
strMot = CStr(Mot)
If strMot Like "*-*" Then
Set colTemp1 = New Collection
Splitter strMot, colTemp1, "-"
CodeAscii1 = colTemp1(1)
CodeAscii2 = colTemp1(2)
'On range dans l'ordre croissant
If CodeAscii1 > CodeAscii2 Then
Bid = CodeAscii1
CodeAscii1 = CodeAscii2
CodeAscii2 = Bid
End If
For jBoucle = CodeAscii1 To CodeAscii2
colSeparateurs.Add Chr(jBoucle)
Next jBoucle
Set colTemp1 = Nothing
Else
colSeparateurs.Add Chr(strMot)
End If
Next Mot
Set ColTemp = Nothing
Else
colSeparateurs.Add Separateurs(iBoucle)
End If
Next iBoucle
' Pour un simple découpage, on ne différencie pas les séparateurs.
' On les remplace par un seul. Pour accepter des mots comme séparateur,
' on remplace tous les séparateurs par un caractère qu'il est
impossible
' de trouver dans une chaîne : chr(0)
strMarqueur = Chr(0)
For iBoucle = 1 To colSeparateurs.Count
CharSep = CStr(colSeparateurs(iBoucle))
strTexte = fstrRemplaceTous(1, CharSep, strMarqueur, strTexte)
Next iBoucle
'On vide la collection de séparateurs
Set colSeparateurs = Nothing
' Maintenant on peut découper
intPos = 1
intIndex = 1
While intIndex <> 0
intIndex = InStr(intPos, strTexte, strMarqueur)
Select Case intIndex
Case 0 ' Il n'y a pas de séparateur
strMot = Trim(Mid(strTexte, intPos, Len(strTexte) - intPos + 1))
If strMot <> "" Then colListeDeMots.Add strMot
Case Else ' Il y a un séparateur
strMot = Trim(Mid(strTexte, intPos, intIndex - intPos))
If strMot <> "" Then colListeDeMots.Add strMot
intPos = intIndex + 1
End Select
Wend
End Sub
Private Function fstrRemplaceTous(lngDépart As Long, strVieilleChaine As
String, strNouvelleChaine As String, ByVal strTexte As String) As String
Dim TailleVieilleChn As Integer
Dim Index As Integer, Pos As Integer, TailleNouvelChn As Integer,
taillestrTexte As Integer
'Remplace toutes les occurences de la chaîne strVieilleChaine par la
chaîne
'strNouvelleChaine dans strTexte
'Peut donc être utilisée pour des suppressions, strNouvelleChaine="",
'ou pour compter les caractères :
'nbcar = Len(Texte) - Len(fstrReplace(char, "", Texte))
' Noter que strTexte n'est pas modifié.
fstrRemplaceTous = strTexte
If lngDépart < 1 Or lngDépart > Len(strTexte) - Len(strVieilleChaine) +
1 Then
Exit Function
End If
If strVieilleChaine = "" Or strVieilleChaine = strNouvelleChaine Then
Exit Function
TailleVieilleChn = Len(strVieilleChaine)
TailleNouvelChn = Len(strNouvelleChaine)
Index = 1
Pos = lngDépart
While Index <> 0
taillestrTexte = Len(strTexte)
Index = InStr(Pos, strTexte, strVieilleChaine)
Select Case Index
Case 0 '
rien à remplacer
Case taillestrTexte - TailleVieilleChn + 1 ' une seule
chaîne à droite
strTexte = Left(strTexte, Index - 1) & strNouvelleChaine
Index = 0
Case Else '
au moins une chaîne
strTexte = Left(strTexte, Index - 1) & strNouvelleChaine &
Mid(strTexte, Index + TailleVieilleChn)
Pos = Index + TailleNouvelChn
End Select
Wend
fstrRemplaceTous = strTexte
End Function
--
Je prends le fil en marche...
Je prends le fil en marche...
Je prends le fil en marche...
