Sub Rechcar(Car, Nb) ' ' Recherche Nème car ou ¤ ' Si Nb=0 selection find.execute n'est pas réalise ' Ce qui permet d'introduire dans une boucle en programme principal ' Selection.Find.ClearFormatting With Selection.Find .Text = Car .Replacement.Text = "" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchKashida = False .MatchDiacritics = False .MatchAlefHamza = False .MatchControl = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchWildcards = True End With If Nb > 0 Then For N = 1 To Nb Selection.Find.Execute Next Else End If End Sub 'Rechcar Sub Rechrepcar(cars, carp, wild) ' 'Recherche et remplacement sur la totalite 'car caractere a rechercher carp caractere de remplacement ' Selection.HomeKey Unit:=wdStory 'home inclus Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = cars .Replacement.Text = carp .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchKashida = False .MatchDiacritics = False .MatchAlefHamza = False .MatchControl = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchWildcards = wild End With Selection.Find.Execute Replace:=wdReplaceAll End Sub 'Reprechcar Sub replaceeol(ist, tobe) ' ' remplace "ist" par "tobe" ' ' Selection.Find.Execute Replace:=wdReplaceAll Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = ist .Replacement.Text = tobe .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchKashida = False .MatchDiacritics = False .MatchAlefHamza = False .MatchControl = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll End Sub 'Replaceeol Sub ZTraite_lignes() ' ' Procédure de traitement d'une ligne ' ' Const TBLSPMAX = 9: Const OFSSP = 0 Dim TBLSP(10, 2) TBLSP(1, 1) = 1 + OFSSP: TBLSP(1, 2) = "Anomalie Structure" TBLSP(2, 1) = 2 + OFSSP: TBLSP(2, 2) = "Provenance inconnue" TBLSP(3, 1) = 3 + OFSSP: TBLSP(3, 2) = "Inconnu en table" TBLSP(4, 1) = 4 + OFSSP: TBLSP(4, 2) = "En provenance de : " TBLSP(5, 1) = 5 + OFSSP: TBLSP(5, 2) = "/archives/" TBLSP(6, 1) = 6 + OFSSP: TBLSP(6, 2) = "||" TBLSP(7, 1) = 7 + OFSSP: TBLSP(7, 2) = "\t ""_blank" 'fin zone Hyperlnk provenance TBLSP(8, 1) = 8 + OFSSP: TBLSP(8, 2) = """ \o """ 'Nom d article blog ' ' Recherche si 2 arguments Hyperlink ' Selection.HomeKey Unit:=wdStory 'home Call Rechcar(TBLSP(6, 2), 0) 'recherche si 2 arguments || If Selection.Find.Execute = True Then CodPages = 1 Else CodPages = 0 GoTo ecriture_Code ' End If ' ' Call Rechcar(TBLSP(2, 2), 0) 'Provenance inconnue If Selection.Find.Execute = True Then CodProv = 1 GoTo ZTraitpages 'Provenance inconnue unique Else CodProv = 0 Selection.HomeKey Unit:=wdStory 'home ' 'Recherche 1 er Hyperlink "En provenance de : " ' ' Call Rechcar(TBLSP(4, 2), 0) 'En provenance de : If Selection.Find.Execute = False Then GoTo ecriture_Code Else Selection.MoveRight Unit:=wdCharacter, Count:=1 Selection.Extend End If ' recherche \t blank Call Rechcar(TBLSP(7, 2), 1) Selection.MoveLeft Unit:=wdCharacter, Count:=12 Selection.Copy Selection.Extend Selection.MoveRight Unit:=wdCharacter, Count:=15 Selection.Delete Unit:=wdCharacter, Count:=1 Selection.Paste End If ' ' Traitement des Pages des blogs ' ZTraitpages: Call Rechrepcar(TBLSP(6, 2), "¤", wildtrue) ' recherche || et remplacement par ¤ Selection.MoveRight Unit:=wdCharacter, Count:=1 Selection.Find.ClearFormatting With Selection.Find .Text = TBLSP(8, 2) ' recherche " \o " .Replacement.Text = "" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchKashida = False .MatchDiacritics = False .MatchAlefHamza = False .MatchControl = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False 'Pas possible rechcar cause False obligatoire End With Selection.Find.Execute Selection.MoveRight Unit:=wdCharacter, Count:=1 Selection.Extend Call Rechcar(TBLSP(7, 2), 1) ' recherche " \t _blank " Selection.MoveLeft Unit:=wdCharacter, Count:=12 Selection.Copy Selection.Extend Selection.MoveRight Unit:=wdCharacter, Count:=15 Selection.Delete Unit:=wdCharacter, Count:=1 Selection.Paste ecriture_Code: End Sub ' Z_Traiteligne Sub A_MACRO_BLOG2() '==================================================================================================================== ' Reconnaissance Complémentaire des codes Provenance et Pg visitee ' dans les statistiques "derniers accès" sur Canalblog ' ============================= ' Macro enregistree le 23/04/2008 par bricolsec Version 6 du 10/06/2008 © ' adresse http://bricolsec.canalblog.com ' ============================================================= ' Preparation et mise en forme du fichier WORD 2002 constitue ' a partir de Maxi 5 copier coller a la suite, depuis canablog ' Cela supprime les images et les remplace par du texte ' cela supprimera egalement les hyperlink des adresses IP. ' ou depuis la derniere date connue (Pas de Pb de taille) ' Avec introduction des chiffres complet de l'annee (>=Rev 2) ' Les boucles sont dimensionnees pour un maximum de 100 lignes ' puisque c'est la valeur maxi actuelle ' Introduction du code du blog LOkistagnepas ou BRricolsec ' Cas ou on a plusieurs blog, on donne un code à 2 lettres ' Selection.HomeKey Unit:=wdStory codblog = InputBox("Donner les 2 premiers caractères du Blog BR ou LO", "ENTREE NOM de BLOG", "BR") codblog = UCase(codblog) wildtrue = True wildfalse = False Dim Error, err As Boolean Dim longcc, v1, ptr, N4 As Integer ' ' Save Fichier d'Origine realise en CTRL+C et CTRL+V sous BLOGESS.DOC ' Cela permet de repasser une deuxième fois après avoir ajouté les manques ' et de vérifier que c est OK ' ActiveDocument.SaveAs FileName:="BLOGESS.DOC", FileFormat:= _ wdFormatDocument, LockComments:=False, Password:="", AddToRecentFiles:= _ True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:= _ False, SaveNativePictureFormat:=False, SaveFormsData:=False, _ SaveAsAOCELetter:=False ' ' ' mise en forme avec passage en mode tableau et non codes de champs ' Application.DisplayStatusBar = True Application.ShowWindowsInTaskbar = True Application.ShowStartupDialog = False With ActiveWindow .DisplayHorizontalScrollBar = True .DisplayVerticalScrollBar = True .DisplayLeftScrollBar = False .StyleAreaWidth = CentimetersToPoints(0) .DisplayVerticalRuler = True .DisplayRightRuler = False .DisplayScreenTips = True With .View .ShowAnimation = True .Draft = False .WrapToWindow = False .ShowPicturePlaceHolders = False .ShowFieldCodes = False .ShowBookmarks = True .FieldShading = wdFieldShadingWhenSelected .ShowTabs = False .ShowSpaces = False .ShowParagraphs = False .ShowHyphens = False .ShowHiddenText = False .ShowAll = True .ShowDrawings = True .ShowObjectAnchors = True .ShowTextBoundaries = False .ShowHighlight = True .DisplayPageBoundaries = True .DisplaySmartTags = True End With End With ' ' supression colonne resolution ecran ' Selection.HomeKey Unit:=wdStory 'suppression colonne resolution ecran Selection.MoveRight Unit:=wdCell Selection.MoveRight Unit:=wdCell Selection.MoveRight Unit:=wdCell Selection.MoveRight Unit:=wdCell Selection.SelectColumn Selection.Delete Unit:=wdCharacter, Count:=1 ' 'selection tableau pour conversion en texte ' Application.DefaultTableSeparator = "¤" '=============================séparateur special 207) Selection.Rows.ConvertToText Separator:=wdSeparateByDefaultListSeparator, _ NestedTables:=True ' 'ctrl home puis affichage option code champ ' Selection.HomeKey Unit:=wdStory ActiveWindow.View.ShowFieldCodes = Not ActiveWindow.View.ShowFieldCodes Application.DisplayStatusBar = True Application.ShowWindowsInTaskbar = True Application.ShowStartupDialog = False With ActiveWindow .DisplayHorizontalScrollBar = True .DisplayVerticalScrollBar = True .DisplayLeftScrollBar = False .StyleAreaWidth = CentimetersToPoints(0) .DisplayVerticalRuler = True .DisplayRightRuler = False .DisplayScreenTips = True With .View .ShowAnimation = True .Draft = False .WrapToWindow = False .ShowPicturePlaceHolders = False .ShowFieldCodes = True .ShowBookmarks = True .FieldShading = wdFieldShadingWhenSelected .ShowTabs = False .ShowSpaces = False .ShowParagraphs = False .ShowHyphens = False .ShowHiddenText = False .ShowAll = True .ShowDrawings = True .ShowObjectAnchors = True .ShowTextBoundaries = False .ShowHighlight = True .DisplayPageBoundaries = True .DisplaySmartTags = True End With End With '____________________________ ' Recherches codes à partir d'un tableau de constantes ' Const ZONE1 = 100 ' cette valeur définit le nombre d'entrée en table ET la boucle Dim TBL(ZONE1, 2) ' Codes de PAYS TBL(1, 1) = "/FR.gif""": TBL(1, 2) = "FR" 'France TBL(2, 1) = "/US.gif""": TBL(2, 2) = "US" 'Etats Unis TBL(3, 1) = "/DZ.gif""": TBL(3, 2) = "DZ" 'Algerie TBL(4, 1) = "/MA.gif""": TBL(4, 2) = "MA" 'Maroc TBL(5, 1) = "/BE.gif""": TBL(5, 2) = "BE" 'Belgique TBL(6, 1) = "/AF.gif""": TBL(6, 2) = "AF" 'Afghanistan TBL(7, 1) = "/CA.gif""": TBL(7, 2) = "CA" 'Canada TBL(8, 1) = "/DE.gif""": TBL(8, 2) = "DE" 'Allemagne TBL(9, 1) = "/ES.gif""": TBL(9, 2) = "ES" 'Espagne TBL(10, 1) = "/BF.gif""": TBL(10, 2) = "BF" 'Burkina Fasso TBL(11, 1) = "/SN.gif""": TBL(11, 2) = "SN" 'Senegal TBL(12, 1) = "/QA.gif""": TBL(12, 2) = "QA" 'QATAR TBL(13, 1) = "/IT.gif""": TBL(13, 2) = "IT" 'Italie TBL(14, 1) = "/PF.gif""": TBL(14, 2) = "PF" 'Polynesie Francaise TBL(15, 1) = "/GB.gif""": TBL(15, 2) = "UK" 'Grande Bretagne TBL(16, 1) = "/CH.gif""": TBL(16, 2) = "CH" 'Suisse TBL(17, 1) = "/BJ.gif""": TBL(17, 2) = "BJ" 'Benin TBL(18, 1) = "/BR.gif""": TBL(18, 2) = "BR" 'Bresil TBL(19, 1) = "/GY.gif""": TBL(19, 2) = "GY" 'Guyane TBL(20, 1) = "/TN.gif""": TBL(20, 2) = "TN" 'Tunisie TBL(21, 1) = "/LU.gif""": TBL(21, 2) = "LU" 'Luxembourg TBL(22, 1) = "/NL.gif""": TBL(22, 2) = "NL" 'Pays Bas TBL(23, 1) = "/PL.gif""": TBL(23, 2) = "PL" 'Pologne TBL(24, 1) = "/RE.gif""": TBL(24, 2) = "RE" 'Reunion TBL(25, 1) = "/PT.gif""": TBL(25, 2) = "PT" 'Portugal TBL(26, 1) = "/ZA.gif""": TBL(26, 2) = "ZA" 'Afrique du Sud TBL(27, 1) = "/NC.gif""": TBL(27, 2) = "NC" 'Nouvelle Calédonie TBL(28, 1) = "/EU.gif""": TBL(28, 2) = "EU" 'Union Europeenne TBL(29, 1) = "/MC.gif""": TBL(29, 2) = "MC" 'Monaco 'OPERATING SYSTEMS TBL(30, 1) = "/windows2000.png""": TBL(30, 2) = "WI20" 'Windows 2000 TBL(31, 1) = "/windows2003.png""": TBL(31, 2) = "WI03" 'Windows 2003 TBL(32, 1) = "/windowsxp.png""": TBL(32, 2) = "WIXP" 'Windows XP TBL(33, 1) = "/windowsvista.png""": TBL(33, 2) = "WIVI" 'Windows VISTA TBL(34, 1) = "/linux.png""": TBL(34, 2) = "LINU" 'LINUX TBL(35, 1) = "/macosx.png""": TBL(35, 2) = "MAOS" 'Mac OS TBL(36, 1) = "/windows.png""": TBL(36, 2) = "WINS" 'Windows Standard TBL(37, 1) = "/windows98.png""": TBL(37, 2) = "WI98" 'Windows98 TBL(38, 1) = "/windowsme.png""": TBL(38, 2) = "WIME" 'Windows ME TBL(39, 1) = "/windowsnt.png""": TBL(39, 2) = "WINT" 'Windows NT 'Navigateurs TBL(40, 1) = "/fire.png""": TBL(40, 2) = "FIRE" 'Fire Fox TBL(41, 1) = "/msie.png""": TBL(41, 2) = "MSIE" 'Micro Soft internet Explorer TBL(42, 1) = "/konq.png""": TBL(42, 2) = "KONQ" 'Conqueror TBL(43, 1) = "/oper.png""": TBL(43, 2) = "OPER" 'OPERA TBL(44, 1) = "/safa.png""": TBL(44, 2) = "SAFA" 'Safari TBL(45, 1) = "/mozi.png""": TBL(45, 2) = "MOZI" 'Mozzila TBL(46, 1) = "/avan.png""": TBL(46, 2) = "AVAN" 'AVAN 7.0 TBL(47, 1) = "/pock.png""": TBL(47, 2) = "IEPK" 'Internet Explorer Pocket PC TBL(48, 1) = "/k-me.png""": TBL(48, 2) = "KMEL" 'K-Meeleon 1.1.4 TBL(49, 1) = "/nets.png""": TBL(49, 2) = "NETS" 'Netscape TBL(50, 1) = "/ZZ.gif""": TBL(50, 2) = "ZZ" ' 'Ajouts au TABLEAU dans le desordre TBL(51, 1) = "/RO.gif""": TBL(51, 2) = "RO" 'Roumanie TBL(52, 1) = "/NI.gif""": TBL(52, 2) = "NI" 'Nicaragua TBL(53, 1) = "/AT.gif""": TBL(53, 2) = "AT" 'Autriche TBL(54, 1) = "/NO.gif""": TBL(54, 2) = "NO" 'Norvege TBL(55, 1) = "/CI.gif""": TBL(55, 2) = "CI" 'Cote d'ivoire TBL(56, 1) = "/SA.gif""": TBL(56, 2) = "SA" 'Arabie saoudite TBL(57, 1) = "/SE.gif""": TBL(57, 2) = "SE" 'Suede TBL(58, 1) = "/macosppc.png""": TBL(58, 2) = "MAOC" 'MAC OS ppc TBL(59, 1) = "/CL.gif""": TBL(59, 2) = "CL" 'Chili TBL(60, 1) = "/MQ.gif""": TBL(60, 2) = "MQ" 'Martinique TBL(61, 1) = "/DJ.gif""": TBL(61, 2) = "DJ" 'Djibouti TBL(62, 1) = "/MR.gif""": TBL(62, 2) = "MR" 'Mauritanie TBL(63, 1) = "/CN.gif""": TBL(63, 2) = "CN" 'Chine TBL(64, 1) = "/PE.gif""": TBL(64, 2) = "PE" 'Perou TBL(65, 1) = "/bsd.png""": TBL(65, 2) = "BSD" 'BSD O/S TBL(66, 1) = "/CO.gif""": TBL(66, 2) = "CO" 'Colombie TBL(67, 1) = "/AD.gif""": TBL(67, 2) = "AD" 'ANDORRE sans drapeau pour l'instant TBL(68, 1) = "/NG.gif""": TBL(68, 2) = "NG" 'Nigeria TBL(69, 1) = "/NE.gif""": TBL(69, 2) = "NE" 'Niger TBL(70, 1) = "/GQ.gif""": TBL(70, 2) = "GQ" 'GUINEE Equatoriale TBL(71, 1) = "/RW.gif""": TBL(71, 2) = "RW" 'RWANDA TBL(72, 1) = "/MX.gif""": TBL(72, 2) = "MX" 'Mexique TBL(73, 1) = "/windowsce.png""": TBL(73, 2) = "WIPK" 'Windows Pocket PC TBL(74, 1) = "/HR.gif""": TBL(74, 2) = "HR" 'Croatie TBL(75, 1) = "/cami.png""": TBL(75, 2) = "CAMI" 'Camino 0.8.1 TBL(76, 1) = "/IN.gif""": TBL(76, 2) = "IN" 'Inde TBL(77, 1) = "/IL.gif""": TBL(77, 2) = "IL" 'Israel TBL(78, 1) = "/windows95.png""": TBL(78, 2) = "WI95" ' TBL(79, 1) = "/freebsd.png""": TBL(79, 2) = "FREE" 'Freebsd TBL(80, 1) = "/AR.gif""": TBL(80, 2) = "AR" 'Argentine TBL(81, 1) = "/RS.gif""": TBL(81, 2) = "RS" 'Republique de SERBIE TBL(82, 1) = "/IR.gif""": TBL(82, 2) = "IR" 'IRAN Republique Islamique TBL(83, 1) = "/HT.gif""": TBL(83, 2) = "HT" 'HAITI TBL(84, 1) = "/GR.gif""": TBL(84, 2) = "GR" 'Grece TBL(85, 1) = "/CZ.gif""": TBL(85, 2) = "CZ" 'TCHEQUE Republique TBL(86, 1) = "/HK.gif""": TBL(86, 2) = "HK" 'Hongkong TBL(87, 1) = "/CM.gif""": TBL(87, 2) = "CM" 'Cameroun TBL(88, 1) = "/GA.gif""": TBL(88, 2) = "GA" 'Gabon TBL(89, 1) = "/UA.gif""": TBL(89, 2) = "UA" 'Ukraine TBL(90, 1) = "/sunos.png""": TBL(90, 2) = "SUNO" 'Sun O/S TBL(91, 1) = "/TW.gif""": TBL(91, 2) = "TW" 'TAIWAN TBL(92, 1) = "/LA.gif""": TBL(92, 2) = "LA" 'LAOS TBL(93, 1) = "/xx.gif""": TBL(93, 2) = "xx" ' TBL(94, 1) = "/xx.gif""": TBL(94, 2) = "xx" ' TBL(95, 1) = "/xx.gif""": TBL(95, 2) = "xx" ' TBL(96, 1) = "/xx.gif""": TBL(96, 2) = "xx" ' TBL(97, 1) = "/xx.gif""": TBL(97, 2) = "xx" ' TBL(98, 1) = "/xx.gif""": TBL(98, 2) = "xx" ' TBL(99, 1) = "/xx.gif""": TBL(99, 2) = "xx" ' TBL(100, 1) = "/xx.gif""": TBL(100, 2) = "xx" ' For Line = 1 To ZONE1 'Ne pas oublier de corriger ZONE1 si augmentation de taille tableau Selection.HomeKey Unit:=wdStory Selection.Find.ClearFormatting With Selection.Find .Text = TBL(Line, 1) + " \" + Chr(42) + " MERGEFORMATINET " .Replacement.Text = "" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchKashida = False .MatchDiacritics = False .MatchAlefHamza = False .MatchControl = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Do If Selection.Find.Execute = True Then trouv = True Selection.Extend Selection.MoveRight Unit:=wdCharacter, Count:=1 Selection.Delete Unit:=wdCharacter, Count:=1 Selection.TypeText Text:=TBL(Line, 2) windfindmatch = windfindmatch + 1 Else trouv = False End If Loop While trouv = True Next ' 'sequence de fin 'OUTILS options aff codes de champs ' ActiveWindow.View.ShowFieldCodes = Not ActiveWindow.View.ShowFieldCodes Application.DisplayStatusBar = True Application.ShowWindowsInTaskbar = True Application.ShowStartupDialog = False With ActiveWindow .DisplayHorizontalScrollBar = True .DisplayVerticalScrollBar = True .DisplayLeftScrollBar = False .StyleAreaWidth = CentimetersToPoints(0) .DisplayVerticalRuler = True .DisplayRightRuler = False .DisplayScreenTips = True With .View .ShowAnimation = True .Draft = False .WrapToWindow = False .ShowPicturePlaceHolders = False .ShowFieldCodes = False .ShowBookmarks = True .FieldShading = wdFieldShadingWhenSelected .ShowTabs = False .ShowSpaces = False .ShowParagraphs = False .ShowHyphens = False .ShowHiddenText = False .ShowAll = True .ShowDrawings = True .ShowObjectAnchors = True .ShowTextBoundaries = False .ShowHighlight = True .DisplayPageBoundaries = True .DisplaySmartTags = True End With End With ' ' Mise en place du code de blog (2 Caractères) colonne 4 ' Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting codblog = "¤" + codblog + "¤" With Selection.Find .Text = "¤¤" 'Ce qu il y avait avant mise en place .Replacement.Text = codblog .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchKashida = False .MatchDiacritics = False .MatchAlefHamza = False .MatchControl = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll 'assure remplacement toutes les lignes ' ' Remplacement fin de lignes imposés par || ' Selection.HomeKey Unit:=wdStory Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "^l" .Replacement.Text = "||" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchKashida = False .MatchDiacritics = False .MatchAlefHamza = False .MatchControl = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchWildcards = True End With Selection.Find.Execute Replace:=wdReplaceAll ' ' OMIT dernier CRLF ' Selection.EndKey Unit:=wdStory Selection.TypeBackspace ' ' Passage en mode affichage des champs ' ActiveWindow.View.ShowFieldCodes = Not ActiveWindow.View.ShowFieldCodes Application.DisplayStatusBar = True Application.ShowWindowsInTaskbar = True Application.ShowStartupDialog = False With ActiveWindow .DisplayHorizontalScrollBar = True .DisplayVerticalScrollBar = True .DisplayLeftScrollBar = False .StyleAreaWidth = CentimetersToPoints(0) .DisplayVerticalRuler = True .DisplayRightRuler = False .DisplayScreenTips = True With .View .ShowAnimation = True .Draft = False .WrapToWindow = False .ShowPicturePlaceHolders = False .ShowFieldCodes = True .ShowBookmarks = True .FieldShading = wdFieldShadingWhenSelected .ShowTabs = False .ShowSpaces = False .ShowParagraphs = False .ShowHyphens = False .ShowHiddenText = False .ShowAll = True .ShowDrawings = True .ShowObjectAnchors = True .ShowTextBoundaries = False .ShowHighlight = True .DisplayPageBoundaries = True .DisplaySmartTags = True End With End With ' ' Recherche des champs HYPERLINK des IP (rouge) ' suppress champ et mise de l'IP seule ' Selection.HomeKey Unit:=wdStory 'home Do Call Rechcar(" HYPERLINK ""http://www.canalblog.com/cf/my/*&ip=", 0) 'ligne des &IP If Selection.Find.Execute = True Then ' recherche HYPERLINK avec IP =trouvé ! trouv = True Selection.Delete Unit:=wdCharacter, Count:=1 Selection.Extend Selection.MoveRight Unit:=wdCharacter, Count:=1 ' Call Rechcar("""", 1) ' Selection.MoveLeft Unit:=wdCharacter, Count:=1 Selection.Copy Selection.Extend Selection.MoveRight Unit:=wdCharacter, Count:=3 Selection.Delete Unit:=wdCharacter, Count:=1 Selection.PasteAndFormat (wdPasteDefault) Selection.MoveDown Unit:=wdParagraph, Count:=1 Else trouv = False End If Loop While trouv = True ' ' ' Introduction de "20" dans l'annee ' Car la date d'origine ne le comprend pas ' Selection.HomeKey Unit:=wdStory NBLINES = 0 ' Call Rechcar("/??/??¤", 0) ' Do If Selection.Find.Execute = True Then trouv = True Selection.MoveRight Unit:=wdCharacter, Count:=1 Selection.MoveLeft Unit:=wdCharacter, Count:=3 Selection.Extend Selection.MoveLeft Unit:=wdCharacter, Count:=1 Selection.TypeText Text:="/20" 'Introduction Annee milliers et cent NBLINES = NBLINES + 1 Else trouv = False End If Loop While trouv = True Selection.HomeKey Unit:=wdStory 'CTRL Home ' ' Remplacement www. par rien ' Call Rechrepcar("www.", "", wildtrue) ' ' Remplacement "http:// par rien ' Call Rechrepcar("""http://", "", wildtrue) ' ' Remplacement "¤ " par "¤"| ' Call Rechrepcar("¤ ", "¤", wildtrue) '======================================================== ' Boucle de recherche provenance et Page '======================================================== ' 'ouverture fichier de manoeuvre BLOGTEMP.DOC (il devra exister) Documents.Open FileName:="BLOGTEMP.doc", ConfirmConversions:=True, _ ReadOnly:=False, AddToRecentFiles:=False, PasswordDocument:="", _ PasswordTemplate:="", Revert:=False, WritePasswordDocument:="", _ WritePasswordTemplate:="", Format:=wdOpenFormatAuto, DocumentDirection:= _ wdLeftToRight Selection.HomeKey Unit:=wdStory 'RAZ éventuel fichier Selection.Extend Selection.EndKey Unit:=wdStory Selection.Delete Unit:=wdCharacter, Count:=1 Windows(1).Activate 'retour fenêtre 1 For N1 = 1 To NBLINES Selection.Extend 'selection paragraphe Selection.MoveDown Unit:=wdParagraph, Count:=1 Selection.Copy 'copie Windows(2).Activate ' changement fenetre Selection.PasteAndFormat (wdPasteDefault) 'copie Selection.TypeBackspace 'enleve return en trop ' ================================================================================ 'Traitement réel avec ZTraite_lignes =================== ' ================================================================================ Call ZTraite_lignes Selection.MoveUp Unit:=wdParagraph, Count:=1 'tete de paragr Selection.Extend Selection.MoveDown Unit:=wdParagraph, Count:=1 Selection.Cut 'selection paragraphe modifié complet. Windows(1).Activate 'changement fenetre Selection.PasteAndFormat (wdPasteDefault) 'copie fenetre origine Next ' ' Supression des espaces en trop et des / de fin URL ' Call Rechrepcar("¤ ", "¤", wildtrue) Call Rechrepcar(" ¤", "¤", wildtrue) Call Rechrepcar("/¤", "¤", wildtrue) Call replaceeol("Provenance inconnue ^p", "Provenance inconnue ¤ ^p") 'ajout dernière colonne manquante '============================================================= ' Mise en place des codes provenance / Pages destination '============================================================= Const TBL_LIGNMAX = 100 'ce tableau qui suit contient les codes Provenance ASCII pour chaque ligne du fichier 'chaque code est issu du tableau Tblprov(n) suivant la comparaison effectuée avec Tblprovm(n). Dim CODEPROVE(TBL_LIGNMAX) As String 'chaine code provenance de 4 caractères par ligne 'ce tableau qui suit contient les codes Des pages ascii visitée pour chaque ligne du fichier 'et chaque code est issu du tableau TBLPAGESN(n) suivant la comparaison effectuée avec TBLPAGES(N). Dim CODEPAGES(TBL_LIGNMAX) As String 'chaine code Pages de 4 caractères par ligne Const TBLPROVMAX = 100 Dim Tblprov(TBLPROVMAX) As Integer Dim Tblprovm(TBLPROVMAX) As String Tblprov(1) = 0: Tblprovm(1) = "Code Prov inconnu" Tblprov(2) = 2: Tblprovm(2) = "Provenance inconnue" 'pas de valeur 1 (reserve) Tblprov(3) = 3: Tblprovm(3) = "bricolsec.canalblog.com" Tblprov(4) = 4: Tblprovm(4) = "lokistagnepas.canalblog.com" Tblprov(5) = 5: Tblprovm(5) = "google.lu" Tblprov(6) = 6: Tblprovm(6) = "fr.search.yahoo.com" Tblprov(7) = 7: Tblprovm(7) = "google.fr" Tblprov(8) = 8: Tblprovm(8) = "google.be" Tblprov(9) = 9: Tblprovm(9) = "search.ke.voila.fr" Tblprov(10) = 10: Tblprovm(10) = "google.co.ma" Tblprov(11) = 11: Tblprovm(11) = "bricolage.bricovideo.com" Tblprov(12) = 12: Tblprovm(12) = "commeunpro.com" Tblprov(13) = 13: Tblprovm(13) = "forums.futura-sciences.com" Tblprov(14) = 14: Tblprovm(14) = "cyberbricoleur.com" Tblprov(15) = 15: Tblprovm(15) = "varsable.canalblog.com" Tblprov(16) = 16: Tblprovm(16) = "exalead.fr" Tblprov(17) = 17: Tblprovm(17) = "photovoltaique.pureforum.net" Tblprov(18) = 18: Tblprovm(18) = "search.mywebsearch.com" Tblprov(19) = 19: Tblprovm(19) = "fr.siteexplorer.search.yahoo.com" Tblprov(20) = 20: Tblprovm(20) = "plomberie.per.free.fr" Tblprov(21) = 21: Tblprovm(21) = "google.com" 'ATTENTION UPDT2 VERSION 5 Tblprov(22) = 22: Tblprovm(22) = "fr.answers.yahoo.com" Tblprov(23) = 23: Tblprovm(23) = "eauxpotables.canalblog.com" Tblprov(24) = 24: Tblprovm(24) = "google.es" Tblprov(25) = 25: Tblprovm(25) = "blogsearch.google.fr" Tblprov(26) = 26: Tblprovm(26) = "google.ca" Tblprov(27) = 27: Tblprovm(27) = "recherche.aol.fr" Tblprov(28) = 28: Tblprovm(28) = "canalblog.com" Tblprov(29) = 29: Tblprovm(29) = "altavista.com" Tblprov(30) = 30: Tblprovm(30) = "google.gp" Tblprov(31) = 31: Tblprovm(31) = "bricolage.region-nord.com" Tblprov(32) = 32: Tblprovm(32) = "blogsearch.google.co.ma" Tblprov(33) = 33: Tblprovm(33) = "google.cl" Tblprov(34) = 34: Tblprovm(34) = "google.de" Tblprov(35) = 35: Tblprovm(35) = "search.live.com" Tblprov(36) = 36: Tblprovm(36) = "search.myway." Tblprov(37) = 37: Tblprovm(37) = "fuji.is.scarlet.be" Tblprov(38) = 38: Tblprovm(38) = "del.icio.us" Tblprov(39) = 39: Tblprovm(39) = "fr.altavista.com" Tblprov(40) = 40: Tblprovm(40) = "google.ch" Tblprov(41) = 41: Tblprovm(41) = "bricozone.be" Tblprov(42) = 42: Tblprovm(42) = "bl108w.blu108.mail.live" Tblprov(43) = 43: Tblprovm(43) = "search.sweetim.com" Tblprov(44) = 44: Tblprovm(44) = "search.yahoo.com" Tblprov(45) = 45: Tblprovm(45) = "cyberbricoleur.fr" Tblprov(46) = 46: Tblprovm(46) = "search.conduit.com" Tblprov(47) = 47: Tblprovm(47) = "notify.bluecoat.com" Tblprov(48) = 48: Tblprovm(48) = "aolrecherche.aol.fr" Tblprov(49) = 49: Tblprovm(49) = "www5.google.com" Tblprov(50) = 50: Tblprovm(50) = "search.msn.fr" Tblprov(51) = 51: Tblprovm(51) = "Hidden-Referrer" Tblprov(52) = 52: Tblprovm(52) = "google.nl" Tblprov(53) = 53: Tblprovm(53) = "209.85.135.104" Tblprov(54) = 54: Tblprovm(54) = "vazigo.com" Tblprov(55) = 55: Tblprovm(55) = "veosearch.com" Tblprov(56) = 56: Tblprovm(56) = "rechercher.aliceadsl.fr" Tblprov(57) = 57: Tblprovm(57) = "64.233.183.104" Tblprov(58) = 58: Tblprovm(58) = "209.85.129.99" Tblprov(59) = 59: Tblprovm(59) = "search.free.fr" Tblprov(60) = 60: Tblprovm(60) = "google.ma" Tblprov(61) = 61: Tblprovm(61) = "google.ci" Tblprov(62) = 62: Tblprovm(62) = "lo.st" Tblprov(63) = 63: Tblprovm(63) = "fr.ask.com" Tblprov(64) = 64: Tblprovm(64) = "mx.search.yahoo.com" Tblprov(65) = 65: Tblprovm(65) = "search.hp.my.aol.fr" Tblprov(66) = 66: Tblprovm(66) = "google.hr" Tblprov(67) = 67: Tblprovm(67) = "webmail15.orange.fr" Tblprov(68) = 68: Tblprovm(68) = "forum.canalblog.com" Tblprov(69) = 69: Tblprovm(69) = "gogole.fr" Tblprov(70) = 70: Tblprovm(70) = "webmail1a.orange.fr" Tblprov(71) = 71: Tblprovm(71) = "fr.yhs.search.yahoo.com" Tblprov(72) = 72: Tblprovm(72) = "teloos.fr" Tblprov(73) = 73: Tblprovm(73) = "fr.hs.search.yahoo.com" Tblprov(74) = 74: Tblprovm(74) = "google.co.il" Tblprov(75) = 75: Tblprovm(75) = "209.85.129.104" Tblprov(76) = 76: Tblprovm(76) = "search.msn.be" Tblprov(77) = 77: Tblprovm(77) = "google.sn" 'sénégal Tblprov(78) = 78: Tblprovm(78) = "bligg.fr" Tblprov(79) = 79: Tblprovm(79) = "by117w.bay117.mail.live.com" Tblprov(80) = 80: Tblprovm(80) = "eu2.ixquick.com" Tblprov(81) = 81: Tblprovm(81) = "google.ae" Tblprov(82) = 82: Tblprovm(82) = "webmail22.orange.fr" Tblprov(83) = 83: Tblprovm(83) = "ar.search.yahoo.com" Tblprov(84) = 84: Tblprovm(84) = "bricodesign.com" Tblprov(85) = 85: Tblprovm(85) = "74.125.39.104" Tblprov(86) = 86: Tblprovm(86) = "fr.mg1.mail.yahoo.com" Tblprov(87) = 87: Tblprovm(87) = "alltheweb.com" Tblprov(88) = 88: Tblprovm(88) = "related.msn.com" Tblprov(89) = 89: Tblprovm(89) = "webmail.laposte.net" Tblprov(90) = 90: Tblprovm(90) = "chfr.search.yahoo.com" Tblprov(91) = 91: Tblprovm(91) = "10.81.2.38" Tblprov(92) = 92: Tblprovm(92) = "google.it" Tblprov(93) = 93: Tblprovm(93) = "xx" Tblprov(94) = 94: Tblprovm(94) = "xx" Tblprov(95) = 95: Tblprovm(95) = "xx" Tblprov(96) = 96: Tblprovm(96) = "xx" Tblprov(97) = 97: Tblprovm(97) = "xx" Tblprov(98) = 98: Tblprovm(98) = "xx" Tblprov(99) = 99: Tblprovm(99) = "xx" Tblprov(100) = 100: Tblprovm(100) = "xx" Const TBLPAGESMAX = 80 Dim TBLPAGES(TBLPAGESMAX) Dim TBLPAGESN(TBLPAGESMAX) ' '0 à 399 BRICOLSEC et 400 à 799 LOKISTAGNEPAS TBLPAGESN(1) = 1: TBLPAGES(1) = "BRICOLSEC " TBLPAGESN(2) = 2: TBLPAGES(2) = "ACCUEIL BRICOLSEC et INDEX" TBLPAGESN(3) = 3: TBLPAGES(3) = "EAU de pluie pour les WC" TBLPAGESN(4) = 4: TBLPAGES(4) = "EAU CHAUDE SOLAIRE en POURSUITE du SOLEIL" TBLPAGESN(5) = 5: TBLPAGES(5) = "Renvoi loki réducteurs" TBLPAGESN(6) = 6: TBLPAGES(6) = "JE RACCORDE MA MAISON AU RESEAU PUBLIC d'EAU POTABLE" TBLPAGESN(7) = 7: TBLPAGES(7) = "I Connect my House TO Public Network of DRINKING WATER" TBLPAGESN(8) = 8: TBLPAGES(8) = "LES GROUPES DE SECURITE DES CHAUFFE-EAU" TBLPAGESN(9) = 9: TBLPAGES(9) = "CARRIERE DE CALCAIRE DANS TOUS LES ROBINETS ET APPAREILS MENAGERS " TBLPAGESN(10) = 10: TBLPAGES(10) = "DEUX CHAUDIERES BOIS et FUEL en SERIE ET PARALLELE " TBLPAGESN(11) = 11: TBLPAGES(11) = "Renvoi loki FAQ" TBLPAGESN(12) = 12: TBLPAGES(12) = "Renvoi loki fuites" TBLPAGESN(13) = 13: TBLPAGES(13) = "Compteur Horaire et Nombre de démarrages Moteurs" TBLPAGESN(14) = 14: TBLPAGES(14) = "EAU CHAUDE SANITAIRE BOIS FUEL SOLEIL" TBLPAGESN(15) = 15: TBLPAGES(15) = "ÉNERGIE, PUISSANCE, TARIFS, Cos-Phi, HARMONIQUES " TBLPAGESN(16) = 16: TBLPAGES(16) = "EAU CHAUDE POUR LA MACHINE A LAVER " TBLPAGESN(17) = 17: TBLPAGES(17) = "Récupérateurs d'Eau de Pluie" TBLPAGESN(18) = 18: TBLPAGES(18) = "Renvoi Chloration" TBLPAGESN(19) = 19: TBLPAGES(19) = "Le GEL des COMPTEURS d'EAU" TBLPAGESN(20) = 20: TBLPAGES(20) = "LES GROUPES ELECTROGENES Calculs Puissances" TBLPAGESN(21) = 21: TBLPAGES(21) = "Les BATTERIES d' ACCUMULATEURS au Plomb, Cd-Ni, Cyclage " TBLPAGESN(22) = 22: TBLPAGES(22) = "Récupération CALORIES SALLE de BAINS (douche)" TBLPAGESN(23) = 23: TBLPAGES(23) = "Confinement de CALORIES aux WC" TBLPAGESN(24) = 24: TBLPAGES(24) = "Panneau Solaire à AIR" TBLPAGESN(25) = 25: TBLPAGES(25) = "Ouvre Portail ""CONFORMATIQUE"" Problème clignotant" TBLPAGESN(26) = 26: TBLPAGES(26) = "Renvoi Niveau Citerne" TBLPAGESN(27) = 27: TBLPAGES(27) = "Applications éventuelles d'un compteur de vélo (odomètre)" TBLPAGESN(28) = 28: TBLPAGES(28) = "STATISTIQUES ETENDUES" TBLPAGESN(29) = 29: TBLPAGES(29) = "LA PINCE à CROTTE de CHIEN" TBLPAGESN(30) = 400: TBLPAGES(30) = "LOKISTAGNEPAS (eau potable AEP)" TBLPAGESN(31) = 401: TBLPAGES(31) = "ACCUEIL LOKISTAGNEPAS et INDEX" TBLPAGESN(32) = 402: TBLPAGES(32) = "Le CHAMPIGNON COMPTEUR (Borne en Béton)" TBLPAGESN(33) = 403: TBLPAGES(33) = "Ventouses AEP" TBLPAGESN(34) = 404: TBLPAGES(34) = "QUALITE DE L'EAU DANS LES BOUCLAGES ou INTERCONNEXIONS" TBLPAGESN(35) = 405: TBLPAGES(35) = "QUALITÄT des WASSERS in den ABRIEGELUNGEN Kanalizationen " TBLPAGESN(36) = 406: TBLPAGES(36) = "La CALIDAD del AGUA en los circuitos o interconexiones" TBLPAGESN(37) = 407: TBLPAGES(37) = "LES REDUCTEURS de PRESSION" TBLPAGESN(38) = 408: TBLPAGES(38) = "PRESSURE REDUCER (or regulator)" TBLPAGESN(39) = 409: TBLPAGES(39) = "DIE DRUCKES REDUZIEREND" TBLPAGESN(40) = 410: TBLPAGES(40) = "Renvoi Je raccorde" TBLPAGESN(41) = 411: TBLPAGES(41) = "Renvoi récup eau pluie" TBLPAGESN(42) = 412: TBLPAGES(42) = "LE CLAPET ANTI-RETOUR d'EAU" TBLPAGESN(43) = 413: TBLPAGES(43) = "Les Poteaux d'Incendie (PI)" TBLPAGESN(44) = 414: TBLPAGES(44) = "FAQ Eau Potable et TERMINOLOGIE AEP (V3)" TBLPAGESN(45) = 415: TBLPAGES(45) = "Un ANTI-BELIER" TBLPAGESN(46) = 416: TBLPAGES(46) = "LA RECHERCHE DES FUITES D'EAU AEP" TBLPAGESN(47) = 417: TBLPAGES(47) = "PARAMETRES QUALITE de l'EAU POTABLE (France)" TBLPAGESN(48) = 418: TBLPAGES(48) = "LA RECHERCHE des CANALISATIONS en PLASTIQUE" TBLPAGESN(49) = 419: TBLPAGES(49) = "LÉGISLATION sur Les Travaux pour l'eau Potable : Domaines Publics et Privés" TBLPAGESN(50) = 420: TBLPAGES(50) = "La CHLORATION de l'EAU" TBLPAGESN(51) = 421: TBLPAGES(51) = "La POTABILISATION de l'eau des ADDUCTEURS" TBLPAGESN(52) = 422: TBLPAGES(52) = "L'utilisation du GPS en Eau Potable (AEP)" TBLPAGESN(53) = 423: TBLPAGES(53) = "Le 'SILENCE' du pompage de l'eau " TBLPAGESN(54) = 424: TBLPAGES(54) = "Repasser du ""PRIVE"" au ""PUBLIC"" en EAU POTABLE" TBLPAGESN(55) = 425: TBLPAGES(55) = "VOIR le FOND d'un PUITS en NAPPE ALLUVIALE" TBLPAGESN(56) = 426: TBLPAGES(56) = "Renvoi GE" TBLPAGESN(57) = 427: TBLPAGES(57) = "Renvoi Accumulateurs" TBLPAGESN(58) = 428: TBLPAGES(58) = "Une solution de MARNAGE de RESERVOIR d'eau Potable" TBLPAGESN(59) = 429: TBLPAGES(59) = "Remorques en 12 et" TBLPAGESN(60) = 430: TBLPAGES(60) = "Assurances fuites Eau Potable" TBLPAGESN(61) = 431: TBLPAGES(61) = "Mesure de Niveau d'eau (citerne)" TBLPAGESN(62) = 432: TBLPAGES(62) = "EAU POTABLE - LOKI" TBLPAGESN(63) = 433: TBLPAGES(63) = "INDEX - LOKI" TBLPAGESN(64) = 434: TBLPAGES(64) = "BRICOLAGES DIVERS - LOKI" TBLPAGESN(65) = 30: TBLPAGES(65) = "accueil et Index" TBLPAGESN(66) = 31: TBLPAGES(66) = "BRICOLAGE BASIC" TBLPAGESN(67) = 32: TBLPAGES(67) = "BRICOLAGE ET ECOLOGIE" TBLPAGESN(68) = 33: TBLPAGES(68) = "ÉNERGIE" TBLPAGESN(69) = 34: TBLPAGES(69) = "TRUCS et DIVERS" TBLPAGESN(70) = 435: TBLPAGES(70) = "Les Regards de compteurs d'eau" TBLPAGESN(71) = 35: TBLPAGES(71) = "PODOMETRE TRONIC" TBLPAGESN(72) = 436: TBLPAGES(72) = "Les Puits" TBLPAGESN(73) = 36: TBLPAGES(73) = "NEWSLETTERS CANALBLOG Principes Généraux" TBLPAGESN(74) = 999: TBLPAGES(74) = "A propos de l'auteur" TBLPAGESN(75) = 437: TBLPAGES(75) = "PLUVIOMETRE Automatique" TBLPAGESN(76) = 37: TBLPAGES(76) = "Alarme Simple pour Citerne à Fuel" TBLPAGESN(77) = 438: TBLPAGES(77) = "MONOPHASÉ ou TRIPHASÉ ?" TBLPAGESN(78) = 439: TBLPAGES(78) = "INVESTISSEMENTS et MAINTENANCE en Collectivités Territoriales" TBLPAGESN(79) = 0: TBLPAGES(79) = "zz" TBLPAGESN(80) = 0: TBLPAGES(80) = "zz" Selection.HomeKey Unit:=wdStory For N1 = 1 To NBLINES Selection.Extend Selection.MoveDown Unit:=wdParagraph, Count:=1 Selection.Copy fullline$ = Selection ' ' recherche d'une image non traduite ' avec mémorisation pour impression finale en BLOGTEMP ' If InStr(fullline$, "INCLUDEPICTURE") <> 0 Then Error = True Else Error = False End If Call Rechcar("¤", 7) '=====================================recherche debut PROVENANCE Selection.MoveRight Unit:=wdCharacter, Count:=1 Selection.Extend Call Rechcar("¤", 1) Selection.MoveLeft Unit:=wdCharacter, Count:=1 bb$ = Selection lng = InStr(bb$, "/") If lng = 0 Then AA$ = bb$ Else AA$ = Mid$(bb$, 1, lng - 1) End If N2 = 1 Do ' If Mid$(AA$, 1, Len(Tblprovm(N2))) = Tblprovm(N2) Then trouv = 1 CODEPROVE(N1) = Str$(Tblprov(N2)) Else trouv = 0 CODEPROVE(N1) = "0" End If N2 = N2 + 1 Loop While (N2 <= TBLPROVMAX And trouv = 0) Selection.Cut 'Effacement dans la ligne et remplacement par le code ASCII Selection = CODEPROVE(N1) ' ---------------------------------------------------------------------------------------- 'recherche separateur 207 et corection Pb des prove IP avec : due à WORD + modif sur ligne après ' Selection.MoveRight Unit:=wdCharacter, Count:=1 Call Rechcar("¤", 1) '------------------------------------------------------------------------------------------ 'Remplacement dénomination page par son code ' Selection.MoveRight Unit:=wdCharacter, Count:=1 'ancienne valeur =3 Selection.Extend Selection.Find.ClearFormatting With Selection.Find .Text = "^p" ' recherche return .Replacement.Text = "" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchKashida = False .MatchDiacritics = False .MatchAlefHamza = False .MatchControl = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False 'Pas possible rechcar cause False obligatoire End With Selection.Find.Execute Selection.MoveLeft Unit:=wdCharacter, Count:=1 cc$ = Selection If Len(cc$) > 0 Then ' ' correction anomalie CANALBLOG qui renvoie \" pour le seul caractère " en nom de blog ' ptr = 1 If InStr(ptr, cc$, "\""") > 0 Then 'AVEC traitement des doubles " longcc = Len(cc$) z$ = "" Do v1 = InStr(ptr, cc$, "\""") If v1 > 0 Then z$ = z$ + Mid$(cc$, ptr, (v1 - ptr)) ptr = v1 + 1 Else 'V1 z$ = z$ + Mid$(cc$, ptr, (longcc - ptr + 1)) ptr = longcc End If 'v1 Loop While ptr < longcc cc$ = z$ Else 'instr End If 'instr ' fin correction canalblog pour \" ' 'Mise en place du code de page ' N2 = 1 Do dd$ = Mid$(cc$, 1, Len(TBLPAGES(N2))) If dd$ = TBLPAGES(N2) Then trouv = 1 CODEPAGES(N1) = Str$(TBLPAGESN(N2)) Else trouv = 0 CODEPAGES(N1) = "0" End If N2 = N2 + 1 Loop While (N2 <= TBLPAGESMAX And trouv = 0) Selection.Cut 'Effacement dans la ligne et remplacement par le code ASCII Selection = CODEPAGES(N1) Else CODEPAGES(N1) = "0" End If 'len cc$ ' ' ' Traitement des erreurs sur le fichier BLOGTEMP ' err = False Header$ = "" 'tete de message RAZ N4 = (Val(CODEPROVE(N1)) * 10) + Val(CODEPAGES(N1)) If N4 = 20 Then 'ATTENTION le 20 est prévu pour "provenance inconnue" seule sur une ligne GoTo PROVINCO Else 'if N4 If Val(CODEPROVE(N1)) = 0 Then err = True Header$ = "Err Prov |" Else If Val(CODEPAGES(N1)) = 0 Then err = True Header$ = Header$ + "Err Pages |" Else End If 'codeprov(N1) End If 'codepages(N1) End If 'N4 PROVINCO: ' provenance inconnue unique, test si Error (erreurs des images) If Error = True Then err = True Header$ = Header$ + "Err Image |" Else End If If err = True Then ' ' affichage + fichier BLOG ' Windows(2).Activate Selection.TypeText Text:=Header$ + "-" '======================= Selection.HomeKey Unit:=wdLine Selection.Extend Selection.EndKey Unit:=wdLine Selection.MoveLeft Unit:=wdCharacter, Count:=2 With Selection.Font .Name = "Times New Roman" .Size = 12 .Bold = True .Italic = False .Underline = wdUnderlineDouble .UnderlineColor = wdColorRed .StrikeThrough = False .DoubleStrikeThrough = False .Outline = False .Emboss = False .Shadow = False .Hidden = False .SmallCaps = False .AllCaps = False .Color = wdColorRed .Engrave = False .Superscript = False .Subscript = False .Spacing = 0 .Scaling = 100 .Position = 0 .Kerning = 0 .Animation = wdAnimationNone .SizeBi = 10 .NameBi = "Courier New" .BoldBi = True .ItalicBi = False End With Selection.EndKey Unit:=wdLine '======================= Selection.TypeParagraph Selection.TypeText Text:=fullline$ Selection.TypeParagraph Windows(1).Activate Error = False 'reset error image non trouvée memorise err = False 'reste flag erreur Else 'err End If 'err Selection.MoveDown Unit:=wdParagraph, Count:=1 Next N1 ' ------------------------------------------------------------- fin Call replaceeol(" ", "") Call replaceeol("¤", ";") 'remplace le code 207 par ; Call replaceeol(";N/A", ";N/") 'remplace N/A par N/ surtout utile pour les Pays Selection.EndKey Unit:=wdStory 'enleve return en trop a la fin Selection.TypeBackspace Selection.HomeKey Unit:=wdStory 'affiche début fichier ' ' Save format BLOGSTAT.TXT (les images inconnues sont automatiquement eliminees ici ' ActiveDocument.SaveAs FileName:="BLOGSTAT.txt", FileFormat:=wdFormatText, _ LockComments:=False, Password:="", AddToRecentFiles:=True, WritePassword _ :="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _ SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _ False, Encoding:=1252, InsertLineBreaks:=False, AllowSubstitutions:=False _ , LineEnding:=wdCRLF, AddBiDiMarks:=False ActiveDocument.Close ' ' fermeture fichiers ouverture BLOGSTAT.TXT ' Selection et CTRL+C pour inserer dans ACCESS ' Macro enregistree le 07/04/2008 par CT ' ActiveDocument.Close Documents.Open FileName:="BLOGSTAT.TXT", ConfirmConversions:=True, _ ReadOnly:=False, AddToRecentFiles:=False, PasswordDocument:="", _ PasswordTemplate:="", Revert:=False, WritePasswordDocument:="", _ WritePasswordTemplate:="", Format:=wdOpenFormatAuto, Encoding:=1252, _ DocumentDirection:=wdLeftToRight Selection.WholeStory Selection.Copy ' Basculement en mode sans code de champs visibles ' ActiveWindow.View.ShowFieldCodes = Not ActiveWindow.View.ShowFieldCodes Application.DisplayStatusBar = True Application.ShowWindowsInTaskbar = True Application.ShowStartupDialog = False With ActiveWindow .DisplayHorizontalScrollBar = True .DisplayVerticalScrollBar = True .DisplayLeftScrollBar = False .StyleAreaWidth = CentimetersToPoints(0) .DisplayVerticalRuler = True .DisplayRightRuler = False .DisplayScreenTips = True With .View .ShowAnimation = True .Draft = False .WrapToWindow = False .ShowPicturePlaceHolders = False .ShowFieldCodes = False .ShowBookmarks = True .FieldShading = wdFieldShadingWhenSelected .ShowTabs = False .ShowSpaces = False .ShowParagraphs = False .ShowHyphens = False .ShowHiddenText = False .ShowAll = True .ShowDrawings = True .ShowObjectAnchors = True .ShowTextBoundaries = False .ShowHighlight = True .DisplayPageBoundaries = True .DisplaySmartTags = True End With End With MsgBox ("Fin de traitement complétez éventuellement") End Sub 'A_MACRO_BLOG2