Keresés

Részletes keresés

pimre Creative Commons License 2019.08.21 0 0 762

Sheri ten eredetileg szerintem akart lenni. Hülye okostelefon.

Előzmény: pimre (761)
pimre Creative Commons License 2019.08.21 0 0 761

Sheri ten Wordben az ilyesmi túl bonyolult, ha egyáltalán megoldható. Ez tipikusan Excel feladat.

Írd le pontosan, hogy mit szeretnél, és ehhez most van most!

 

Hátha tudunk megoldást rá.

 

 

Előzmény: tammmy4 (760)
tammmy4 Creative Commons License 2019.08.21 0 0 760

Jobb lenne ha word-ből lehetne word-re hivatkozni. Nem szeretnék külön excel táblázatot készíteni. Így megoldható valahogyan?

Előzmény: m54-b (747)
m54-b Creative Commons License 2019.08.20 0 0 759

A probababa@-tól nem kell, valamiért bent maradt!

Előzmény: m54-b (758)
m54-b Creative Commons License 2019.08.20 0 0 758

Átváltod a mezőkódok mutatását (753) 3. ábra alapján? 

 

ActiveWindow.View.ShowFieldCodes = True
ActiveWindow.View.ShowFieldCodes = False

és a HYPERLINK "http://mailto:email@teszt.com" alapján makrózol?

probababa@citromail.hu

Normal 0 21 false false false HU X-NONE X-NONE /* Style Definitions */ table.MsoNormalTable {mso-style-name:"Normál táblázat"; mso-tstyle-rowband-size:0; mso-tstyle-colband-size:0; mso-style-noshow:yes; mso-style-priority:99; mso-style-qformat:yes; mso-style-parent:""; mso-padding-alt:0cm 5.4pt 0cm 5.4pt; mso-para-margin-top:0cm; mso-para-margin-right:0cm; mso-para-margin-bottom:10.0pt; mso-para-margin-left:0cm; line-height:115%; mso-pagination:widow-orphan; font-size:11.0pt; font-family:"Calibri","sans-serif"; mso-ascii-font-family:Calibri; mso-ascii-theme-font:minor-latin; mso-fareast-font-family:"Times New Roman"; mso-fareast-theme-font:minor-fareast; mso-hansi-font-family:Calibri; mso-hansi-theme-font:minor-latin; mso-bidi-font-family:"Times New Roman"; mso-bidi-theme-font:minor-bidi;}
Előzmény: pimre (757)
pimre Creative Commons License 2019.08.20 0 0 757

Így van, és arra kerestem volna a megoldást, hogy ezt a bezavarást hogy kerülhetném el/meg.

Előzmény: m54-b (755)
pimre Creative Commons License 2019.08.20 0 0 756

A dolog gyakorlati részét tekintve a makród jó, Jimmy makrója is. Engem most nem a konkrét feladat megoldása érdekelt, hanem általában a Word programozás az adott példán keresztül.

És ezen belül is sokáig tartott, amíg egyáltalán találtam olyan szakirodalmat, ami a szöveg keresésével, módosítgatásával is foglalkozik, és a formázási kérdések csak ez után érdekelnének. Amit találtam, az ez volt: http://www.susandoreydesigns.com/software/WordVBATechniques.pdf

 

Amit nem találtam meg, csak megrendelhetően, az a következő volt: https://www.amazon.com/Microsoft-Word-Guidebook-Allen-Wyatt/dp/1613591977. Ez ugyan megvehető kb. 7-8000 Ft-ért, de addig nem költenék rá, amíg legalább a tartalomjegyzékét nem látom, hogy tényleg olyan-e, ami valóban megtanítja a használatát. De sajnos ilyet nem sikerült találnom.

Előzmény: m54-b (752)
m54-b Creative Commons License 2019.08.20 0 0 755

Viszont a Hyperlink biztosan bezavar, mint a 753 mutatja.

Előzmény: pimre (754)
pimre Creative Commons License 2019.08.20 0 0 754

Ezek valóban nem oldják meg, de érdekesek, kösz. Lehet, hogy még valamire jó lehet ezt tudni.

Előzmény: m54-b (750)
m54-b Creative Commons License 2019.08.20 0 0 753

Két futtatás eredménye:

 

 

 

 

A különbség annyi a dokumentumban, hogy a második esetben az email cím nem hyperlink volt!

 

 

([ALT] + [F9]-el lehet váltani.)

Előzmény: pimre (748)
m54-b Creative Commons License 2019.08.20 0 0 752

(Ezek persze csak a file szerkezetére vonatkoznak, aztán, hogy a memóriában mi van arról lövésem sincs. De ha nem találod megfelelőnek a keresés - csere buta makrómat, akkor  Jimmy the Hand 741-es szavankénti darabolás lesz a járható.)

Előzmény: m54-b (751)
m54-b Creative Commons License 2019.08.20 0 0 751

Az alábbi két hsz. természetesen nem oldja meg a kérdésedet

"Az első email cím a 16.pozíción kezdődik, de a következő karaktere a 62-re esik, tehát 46-ot ugrik. A második email cím a 111. pozíción kezdődik, majd a második karaktere a 150-re ugrik. Itt már csak 39 a növekedés."

de talán hoz valami fényt, hogyan működhet.

 

Előzmény: pimre (748)
m54-b Creative Commons License 2019.08.20 0 0 750

A "document.xml"-t kimásolhatod, szerkesztheted, majd mented, és visszamásolod. A fájlt eredeti kiterjesztésre visszaállítva megnyithatod a worddel, és a változás szépen megjelenik. (Amennyiben nem az xml részt változtatod. Tehát a formázások is megmaradnak. Nekem eddig bevált, bár szövegszerkesztésre nem szoktam használni, a "settings.xml"-t szerkesztve levehető a lapvédelem...)

Előzmény: m54-b (749)
m54-b Creative Commons License 2019.08.20 0 0 749

Az ügye megvan, hogy a word tömörített xml-t használ?

Elmented a dokudat, commanderrel lemásolod, a .docm helyett mondjuk .docm- kiterjesztéssel. Így, ha ráklikkelsz/entert ütsz nem a wordöt indítja el. Tehát a commanderben ráállsz, enter. A commander felismeri, hogy ez egy valami, amit ki kell bontania (hasonlóan egy .zip-hez), és megteszi. Ez a kép következik:

 

 

A "word" könyvtárba lépve pedig ez:

 

Lemész a "document.xml"-re, ott [F3]-ra ez a kép tárul eléd (aláhúzás nélkül):

 

 

Előzmény: pimre (748)
pimre Creative Commons License 2019.08.20 0 0 748

A korábbi emailcím átíró program kapcsán arra gondoltam, hogy elmélyedek egy kicsit a Word programozásában (akkor is, ha a kérdezőt a következő években várhatóan nem fogjuk itt látni).

Azt megtaláltam, hogy a szövegek manipulálásának elsődleges eszköze - az Excellel ellentétben - a kijelölést kezelő Selection parancs.

 

Aztán beleütköztem egy furcsaságba: Egy egyszerű szöveget készítettem, benne 2 fiktív email címmel. A szöveg a következő (az idézőjel nincs benne az eredetiben):

 

"Első email cím: probababa@citromail.hu, Aztán jön egy másik cím: email@teszt.com."

Az első cím a 17. (nullával indítva a 16.) karakteren kezdődik, a második a 66. helyen.

 

De a számláló nem így működik. Ezért készítettem hozzá egy nyúlfarknyi programot, ami számolja a karakterpozíciókat 0-tól kezdve, mindig 1-et léptetve, és mellé kiírja a hozzátartozó karaktert.

 

Option Explicit

Sub karakterhely_szamolas()

Dim i As Long

ThisDocument.Activate ' Ha véletlenül nem ezen állnánk

Selection.HomeKey unit:=wdStory ' Küldés a szöveg elejére

For i = 0 To 80

    Debug.Print Selection.Start & " " & Selection.Characters.Last & ", ";

    If i > 0 And i Mod 10 = 0 Then Debug.Print

    Selection.MoveRight unit:=wdCharacter, Count:=1

Next i

End Sub

 

A futtatás eredménye a következő:

 

0 E, 1 l, 2 s, 3 ő, 4 , 5 e, 6 m, 7 a, 8 i, 9 l, 10 ,
11 c, 12 í, 13 m, 14 :, 15 , 16 p, 62 r, 63 o, 64 b, 65 a,
66 b, 67 a, 68 b, 69 a, 70 @, 71 c, 72 i, 73 t, 74 r, 75 o,
76 m, 77 a, 78 i, 79 l, 80 ., 81 h, 82 u, 84 ,, 85 , 86 A,
87 z, 88 t, 89 á, 90 n, 91 , 92 j, 93 ö, 94 n, 95 , 96 e,
97 g, 98 y, 99 , 100 m, 101 á, 102 s, 103 i, 104 k, 105 , 106 c,
107 í, 108 m, 109 :, 110 , 111 e, 150 m, 151 a, 152 i, 153 l, 154 @,
155 t, 156 e, 157 s, 158 z, 159 t, 160 ., 161 c, 162 o, 163 m, 165 .

 

Az első email cím a 16.pozíción kezdődik, de a következő karaktere a 62-re esik, tehát 46-ot ugrik. A második email cím a 111. pozíción kezdődik, majd a második karaktere a 150-re ugrik. Itt már csak 39 a növekedés.

 

Próbáltam rákeresni, egyelőre nem találtam magyarázatot a dologra. Így aztán baromira nem lehet számolgatni a karakterek pontos helyét. 

 

Amit nem szeretnék, az a formázások megszüntetése. Ha kézből adok ilyen feladatokat a Wordnek, ott nem szükséges a formázásokkal törődni, nyilván a VBA-ban is kell, hogy legyen megoldás rá.

 

Tud valaki valamit erről?

m54-b Creative Commons License 2019.08.15 0 0 747

A körlevél készítés nem megfelelő?

 

(Ha nem ismered Google

https://www.google.hu/search?source=hp&ei=x09VXfKvKfHDrgTsi7sQ&q=word+k%C3%B6rlev%C3%A9l)

Előzmény: tammmy4 (746)
tammmy4 Creative Commons License 2019.08.15 0 0 746

Sziasztok!

 

Segítséget kérnék az alábbi problémával kapcsolatban:

Van egy "fő" word doksim és azt szeretném hogy az ebben a dokumentumban megadott adatok (név, cím) több másik word dokumentumban automatikusan "kitöltésre" kerüljenek.

Vagyis ne kelljen több dokumentumban ugyanazon az adatokat kitöltenem.

Hogyan tudnám ezt megoldani?

m54-b Creative Commons License 2019.08.06 0 0 745

Az e-mail cím helyi része az ASCII-karakterek bármelyikét használhatja:    

  • nagybetűs és kisbetűs latin betűkA -Z ésa -z; 
  • számok0 és9; 
  • speciális karakterek!#$%&'*+-/=?^_'{|}~; 
  • pont., feltéve, hogy az nem az első vagy utolsó karakter, hacsak nincs idézve, és feltéve, hogy nem jelenik meg egymás után, hacsak nincs idézve (pl.John..Doe@example.com nem megengedett, de "John..Doe"@example.com megengedett)

Innen: https://nixlog.info/questions/35821/milyen-karaktereket-engedelyeznek-egy-e-mail-cim

 

Tehát az időzőjelek közti címeket is kell kezelni.

 

Feltételezem, hogy azért kell törölni a címeket, mert nem kívánatos azok terjesztése. Ha marad a hyperlink, akkor ez sem teljesül.

 

 

A T. felhasználó ráereszti valami dokura, ami nem feltétlenül egy átlagos szöveg. Meglepetések érhetik az embert. Letöltöttem az eredeti pattern-t , és dupláztam az idézőjeleket, de sikerült egy "Szövegparaméter túl hosszú"-t produkálni (persze, lehet a pattern-t elrontottam!?), a myWord 263 hosszú.

Egyikünk sem foglalkozott a jsmith@[192.168.2.1] formátumú címekkel...

Itt vannak:

http://eletmod.atw.hu/email-csere_pimre.docm

http://eletmod.atw.hu/email-csere_jimmythehand.docm

http://eletmod.atw.hu/email_csere_m54-b.docm

 

 

Előzmény: Törölt nick (741)
pimre Creative Commons License 2019.08.06 0 0 744

Igen, így már működik. Ahogy írod a sor elején és végén lévő email címeket békén hagyja.

 

Időközben nekem sikerült egy olyan makrót írnom, amely az ezeket is átalakítja, miközben a Word eredeti formátumbeállításait nem módosítja, a hiperhivatkozás formátumot meghagyja, és az érvényes email címek karaktereit a @ és a pontok kivételével x-re javítja.

Lehet, hogy teli van primitív megoldásokkal, de Word-ben eddig nem programoztam. Például nem tudtam megoldani, hogy a megtalált email cím karaktereit csak ott cserélje ki, ahol megtaláltam. Kénytelen voltam kijelölni a teljes szöveget, és a keresés/csere funkcióval átírni. Tartok tőle, hogy ebből még adódhatnak problémák, például ha teljes egészében azonos szerkezetű (karakterszám és pontok helye) címek kerülnek bele, de ezt már nem volt energiám tesztelni. Javítani meg úgysem tudnám. (Ezért kerestem Word utasításkészletet, de eddig nem találtam olyat, ami az ilyen problémák megoldásában segítene)

 

Az email validáló részlet nem saját találmányom, hanem innen van: http://www.vbaexpress.com/kb/getarticle.php?kb_id=281 Máshol is használom, és úgy látom, hogy hibátlanul működik. Eredetileg Excelben készült, egy ponton javítottam. A szerző 2 helyen a substitute függvényt használta, amit a Word nem fogadott el. Ezért itt átjavítottam replace-re, ami működni látszik. Remélem, hogy a változtatás nem okoz majd gondot.

 

Option Explicit

'

' Word szövegekben email címek karaktereinek cseréje x-re

'

Const TESZT As Boolean = False ' teszteléskor átállítjuk True értékre, ekkor nem módosítja az adatokat, csak kiírja immediate-ba az eredeti és alá a módosított sort

Sub cimtorles()

Dim szoveg As String, modszoveg As String, paraformat As ParagraphFormat, sor As Long, hely As Long, i As Long, _

    emailcim As String, atirtemailcim As String, emailkezdet As Long, emailveg As Long, vegatm As Long, megvan As Boolean, valid As Boolean

For sor = 1 To ActiveDocument.Paragraphs.Count

    szoveg = ActiveDocument.Paragraphs(sor).Range.Text

    If TESZT Then Debug.Print Left(szoveg, Len(szoveg) - 1) ' Ez csak teszteléskor kell

    modszoveg = ""

    If InStr(szoveg, "@") > 0 Then ' Csak ha van a sorban @, akkor tesztelünk

        While InStr(szoveg, "@") > 0 ' Ciklus végég a sorban megtalálható @ karaktereken

            hely = InStr(szoveg, "@")

            If hely = 1 Then ' Ha az első helyen van a @, akkor nem lehet email cím

                modszoveg = modszoveg & Left(szoveg, 1) ' ez maga a @ karakter

                szoveg = Mid(szoveg, 2) ' így a @ után folytatjuk majd a keresést

            ElseIf hely = Len(szoveg) Then  ' Ha az utolsó helyen van a @, akkor nem lehet email cím

                modszoveg = modszoveg & szoveg ' Ekkor mégsincs a szövegben emailcím, így befejeztük az adott sor vizsgálatát

                szoveg = "" ' így befejezzük a keresést

            Else

                emailkezdet = hely ' Kerssük az email cím első karakterét

                megvan = False

                While Not megvan ' A @ előtti szóköz keresése

                    If Mid(szoveg, emailkezdet - 1, 1) = " " Then

                        megvan = True

                    Else

                        emailkezdet = emailkezdet - 1

                        If emailkezdet = 1 Then megvan = True ' Ez így még nem biztos, hogy jó

                    End If

                Wend

                emailveg = hely ' Kerssük az email cím első karakterét

                megvan = False

                While Not megvan ' A @ előtti szóköz keresése

                    If Mid(szoveg, emailveg + 1, 1) = " " Then

                        megvan = True

                    Else

                        emailveg = emailveg + 1

                        If emailveg = Len(szoveg) Then megvan = True ' Ez így még nem biztos, hogy jó

                    End If

                Wend

            End If

            emailcim = Mid(szoveg, emailkezdet, emailveg - emailkezdet + 1)

            valid = IsEmailValid(emailcim)

            If Not valid Then

                vegatm = emailveg

                While Not valid And Right(emailcim, 1) <> "@"

                    emailveg = emailveg - 1 ' ' ha mondatvége, vagy pont, vagy más karakterek kerültek volna a végére

                    emailcim = Mid(szoveg, emailkezdet, emailveg - emailkezdet + 1) '  Akkor javítjuk és újra teszteljük

                    valid = IsEmailValid(emailcim)

                Wend

            End If

            If valid Then

                atirtemailcim = ""

                For i = 1 To Len(emailcim)

                    If Mid(emailcim, i, 1) = "@" Or Mid(emailcim, i, 1) = "." Then

                       atirtemailcim = atirtemailcim & Mid(emailcim, i, 1)

                    Else

                       atirtemailcim = atirtemailcim & "x"

                    End If

                Next i

                modszoveg = modszoveg & Left(szoveg, emailkezdet - 1) & atirtemailcim ' az emailcím kezdete előtti rész

                szoveg = Mid(szoveg, emailveg + 1) ' Az emailcím utáni rész

                If Not TESZT Then

                    ActiveDocument.Select

                    Selection.Find.ClearFormatting

                    Selection.Find.Replacement.ClearFormatting

                    With Selection.Find

                        .Text = emailcim

                        .Replacement.Text = atirtemailcim

                        .Forward = True

                        .format = False

                        .MatchCase = True

                        .MatchWholeWord = True

                        .MatchWildcards = False

                        .MatchSoundsLike = False

                        .MatchAllWordForms = False

                        .Execute Replace:=wdReplaceOne

                   End With

                End If

            Else

                modszoveg = modszoveg & Left(szoveg, emailveg)  ' a vélt emailcímmel záruló rész

                szoveg = Mid(szoveg, emailveg + 1) ' A vélt emailcím utáni rész

            End If

        Wend

    End If

    modszoveg = modszoveg & szoveg ' A maradékot hozzáfűzzük

    If TESZT Then

        Debug.Print Left(modszoveg, Len(modszoveg) - 1) ' Ez csak teszteléskor kell

    End If

Next sor

Application.Selection.StartOf

End Sub

'*******************************************************************************************************

'                        E-mail cím helyességének ellenőrzése

'*******************************************************************************************************

Function IsEmailValid(strEmail) ' Email cím ellenőrzés

Dim strArray As Variant

Dim strItem As Variant

Dim i As Long, c As String, blnIsItValid As Boolean

blnIsItValid = True

i = Len(strEmail) - Len(Replace(strEmail, "@", ""))

If i <> 1 Then IsEmailValid = False: Exit Function

ReDim strArray(1 To 2)

strArray(1) = Left(strEmail, InStr(1, strEmail, "@", 1) - 1)

strArray(2) = Replace(Right(strEmail, Len(strEmail) - Len(strArray(1))), "@", "")

For Each strItem In strArray

    If Len(strItem) <= 0 Then

        blnIsItValid = False

        IsEmailValid = blnIsItValid

        Exit Function

    End If

    For i = 1 To Len(strItem)

        c = LCase(Mid(strItem, i, 1))

        If InStr("abcdefghijklmnopqrstuvwxyz_-.", c) <= 0 And Not IsNumeric(c) Then

            blnIsItValid = False

            IsEmailValid = blnIsItValid

            Exit Function

        End If

    Next i

    If Left(strItem, 1) = "." Or Right(strItem, 1) = "." Then

        blnIsItValid = False

        IsEmailValid = blnIsItValid

        Exit Function

    End If

Next strItem

If InStr(strArray(2), ".") <= 0 Then

    blnIsItValid = False

    IsEmailValid = blnIsItValid

    Exit Function

End If

i = Len(strArray(2)) - InStrRev(strArray(2), ".")

If i <> 2 And i <> 3 Then

    blnIsItValid = False

    IsEmailValid = blnIsItValid

    Exit Function

End If

If InStr(strEmail, "..") > 0 Then

    blnIsItValid = False

    IsEmailValid = blnIsItValid

    Exit Function

End If

IsEmailValid = blnIsItValid

End Function

 

Előzmény: Törölt nick (743)
Törölt nick Creative Commons License 2019.08.06 -1 0 743

Nem gondolkdodtam a beillesztés előtt. A fórummotor természetesen kiszedte a backslash karaktereket, talán mást is.

Próbáld ki úgy, hogy a lenti linkről másolod ki és illeszted be a kódba az eredeti pattern-t. Arra figyelj, hogy az eredeti pattern-ben lévő idézőjeleket a VBA-ban duplázni kell.

Előzmény: pimre (742)
pimre Creative Commons License 2019.08.06 0 0 742

Inkább kösz. A hivatkozást bekapcsoltam. Mégsem tudtam lefuttatni, mert a If myRegExp.Test(myWord) = True Then soron nálam megáll 5117-es hibával:

 

"Method 'Test' of object 'IRegExp2' failed"

 

Előzmény: Törölt nick (741)
Törölt nick Creative Commons License 2019.08.06 -1 0 741

Bocs, hogy belekotyogok, szerintem egyszerűbb lenne regular expressions segítségével megoldani a feladatot.

Ezt a makrót raktam össze:

 

Sub Email_Csere()
    Dim myRegExp As New RegExp
    Dim D As Document, myWords() As String, myWord As String, i As Long
    
    With myRegExp
        .Global = False
        .IgnoreCase = True
        .MultiLine = False
        .Pattern = "(?:[a-z0-9!#$%&'*+/=?^_`{|}~-]+(?:.[a-z0-9!#$%&'*+/=?^_`{|}~-]+)*|""(?:[x01-x08x0bx0cx0e-x1fx21x23-x5bx5d-x7f]|\[x01-x09x0bx0cx0e-x7f])*"")@(?:(?:[a-z0-9](?:[a-z0-9-]*[a-z0-9])?.)+[a-z0-9](?:[a-z0-9-]*[a-z0-9])?|[(?:(?:25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?).){3}(?:25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?|[a-z0-9-]*[a-z0-9]:(?:[x01-x08x0bx0cx0e-x1fx21-x5ax53-x7f]|\[x01-x09x0bx0cx0e-x7f])+)])"
        'Pattern forrás: https://emailregex.com/"
    End With
    Set D = ActiveDocument
    myWords = Split(D.Content, " ")
    For i = LBound(myWords) To UBound(myWords)
        myWord = Trim(myWords(i))
        If myRegExp.Test(myWord) = True Then
            Stop
            D.Content.Find.Execute FindText:=myWord, ReplaceWith:="xxxxx", Replace:=wdReplaceAll
        End If
    Next
End Sub

 

A makró a dokumentumot szóközök mentén darabolja szavakra, és vizsgálja az így kapott szavak szerkezetét. Ha előfordulhat olyan, hogy egy email cím után nem szóköz jön, hanem pl. írásjel, a RegExp azt is az email cím részeként értelmezi, s így az is áldozatul esik a cserének.

 

Futtatás előtt a Tools/References-ben be kell kapcsolni a hivatkozást a Microsoft VBScript Regular Expressions 5.5 elemre.

 

Előzmény: pimre (740)
pimre Creative Commons License 2019.08.06 0 0 740

Szia, most nem vagyok gépközelben, majd délután, vagy este. De amit egyelőre nem találok, az egy szövegresz törlése//beszúrása//cseréje  egy bekezdésen belül.  Ezekkel talán tudnék jobb megoldást találni.

Előzmény: m54-b (739)
m54-b Creative Commons License 2019.08.06 0 0 739

Átvettem az enyimból a hyperlink törlését (igaz ez select-el történik). Működik.

 

'        ActiveDocument.Paragraphs(sor).Range.Text = modszoveg
             If atirtemailcim <> "" Then
                    
                    ActiveDocument.Paragraphs(sor).Range.Characters(emailkezdet).Select
                            If Selection.Hyperlinks.Count = 1 Then
                                Selection.Range.Hyperlinks(1).Delete
                             End If
                    
                    ActiveDocument.Paragraphs(sor).Range.Characters(emailkezdet).Text = atirtemailcim
                    For i = 1 To Len(emailcim) - 1
                    ActiveDocument.Paragraphs(sor).Range.Characters(emailkezdet + Len(emailcim)).Delete
                    Next i
                    atirtemailcim = ""
            End If

 

Előzmény: m54-b (738)
m54-b Creative Commons License 2019.08.06 0 0 738

Formázásról: te minden egyes bekezdést lecserélsz, ezért törlődik a formázás. Ha az email cím nélküli bekezdéseket békén hagynád, az emailosokban pedig csak a címet cserélnéd, akkor kevesebb lenne a probléma. Valahogy így:

 

'        ActiveDocument.Paragraphs(sor).Range.Text = modszoveg --> ez volt eddig
            If atirtemailcim <> "" Then
                    ActiveDocument.Paragraphs(sor).Range.Characters(emailkezdet).Text = atirtemailcim
                    For i = 1 To Len(emailcim) - 1
                    ActiveDocument.Paragraphs(sor).Range.Characters(emailkezdet + Len(emailcim)).Delete
                    Next i
                    atirtemailcim = ""
            End If

Ez sem tökéletes, mert, ha az emailcím hyperlinkként van akkor kiakad.

Előzmény: pimre (736)
m54-b Creative Commons License 2019.08.06 0 0 737

Talán még annyi kifogás a működésével kapcsolatban, hogy ha a local-part (a @ előtti rész) idézőjelek közt van, vagy különleges karaktereket tartalmaz, azzal nem foglalkozik.

(A 730 elején levő linkek szerint engedélyezett az ilyen is!)

Előzmény: pimre (736)
pimre Creative Commons License 2019.08.06 0 0 736

Időközben sikerült átírnom a makrót úgy, hogy Word alatt is működjön. Mégiscsak szebb, mint Excelen keresztül. Egy dolgot nem tudok megoldani, hogy a formázást megtartsa. Amilyen az adott bekezdés első karakterének formátuma, olyanra formázódik a teljes bekezdés. Ha valaki tudna erre megoldást, hálás lennék. 

 

És akkor íme a makró:

 

Option Explicit

'

' Word szövegekben email címek karaktereinek cseréje x-re

'

Const TESZT As Boolean = False ' teszteléskor átállítjuk True értékre, ekkor nem módosítja az adatokat, csak kiírja immediate-ba az eredeti és alá a módosított sort

Sub cimtorles()

Dim szoveg As String, modszoveg As String, paraformat As ParagraphFormat, sor As Long, hely As Long, i As Long, _

    emailcim As String, atirtemailcim As String, emailkezdet As Long, emailveg As Long, megvan As Boolean, valid As Boolean

For sor = 1 To ActiveDocument.Paragraphs.Count

    szoveg = ActiveDocument.Paragraphs(sor).Range.Text

    If TESZT Then Debug.Print Left(szoveg, Len(szoveg) - 1) ' Ez csak teszteléskor kell

    modszoveg = ""

    If InStr(szoveg, "@") > 0 Then ' Csak ha van a sorban @, akkor tesztelünk

        While InStr(szoveg, "@") > 0 ' Ciklus végég a sorban megtalálható @ karaktereken

            hely = InStr(szoveg, "@")

            If hely = 1 Then ' Ha az első helyen van a @, akkor nem lehet email cím

                modszoveg = modszoveg & Left(szoveg, 1) ' ez maga a @ karakter

                szoveg = Mid(szoveg, 2) ' így a @ után folytatjuk majd a keresést

            ElseIf hely = Len(szoveg) Then  ' Ha az utolsó helyen van a @, akkor nem lehet email cím

                modszoveg = modszoveg & szoveg ' Ekkor mégsincs a szövegben emailcím, így befejeztük az adott sor vizsgálatát

                szoveg = "" ' így befejezzük a keresést

            Else

                emailkezdet = hely ' Kerssük az email cím első karakterét

                megvan = False

                While Not megvan ' A @ előtti szóköz keresése

                    If Mid(szoveg, emailkezdet - 1, 1) = " " Then

                        megvan = True

                    Else

                        emailkezdet = emailkezdet - 1

                        If emailkezdet = 1 Then megvan = True ' Ez így még nem biztos, hogy jó

                    End If

                Wend

                emailveg = hely ' Kerssük az email cím első karakterét

                megvan = False

                While Not megvan ' A @ előtti szóköz keresése

                    If Mid(szoveg, emailveg + 1, 1) = " " Then

                        megvan = True

                    Else

                        emailveg = emailveg + 1

                        If emailveg = Len(szoveg) Then megvan = True ' Ez így még nem biztos, hogy jó

                    End If

                Wend

            End If

            emailcim = Mid(szoveg, emailkezdet, emailveg - emailkezdet + 1)

            valid = IsEmailValid(emailcim) ' ez egyelőre nem működik

            If Not valid Then

                emailveg = emailveg - 1 - IIf(emailveg = Len(szoveg), 1, 0) ' ha mondatvégi pont, vagy valami egyéb nem odaillő kerület volna a végére, vagy

                                                                            ' bekezdésjel (word esetén ez is van, ezért ekkor még 1-el csökkentjük az emailvéget)

                emailcim = Mid(szoveg, emailkezdet, emailveg - emailkezdet + 1) '  Akkor javítjuk és újra teszteljük

                valid = IsEmailValid(emailcim)

                If Not valid Then emailveg = emailveg + 1 ' Ha ezután is érvénytelen, akkor visszaállítjuk a végét, és ejtjük

            End If

            If valid Then

                atirtemailcim = ""

                For i = 1 To Len(emailcim)

                    If Mid(emailcim, i, 1) = "@" Or Mid(emailcim, i, 1) = "." Then

                       atirtemailcim = atirtemailcim & Mid(emailcim, i, 1)

                    Else

                       atirtemailcim = atirtemailcim & "x"

                    End If

                Next i

                modszoveg = modszoveg & Left(szoveg, emailkezdet - 1) & atirtemailcim ' az emailcím kezdete előtti rész

                szoveg = Mid(szoveg, emailveg + 1) ' Az emailcím utáni rész

            Else

                modszoveg = modszoveg & Left(szoveg, emailveg)  ' a vélt emailcímmel záruló rész

                szoveg = Mid(szoveg, emailveg + 1) ' A vélt emailcím utáni rész

           End If

        Wend

    End If

    modszoveg = modszoveg & szoveg ' A maradékot hozzáfűzzük

    If TESZT Then

        Debug.Print Left(modszoveg, Len(modszoveg) - 1) ' Ez csak teszteléskor kell

    Else

        ActiveDocument.Paragraphs(sor).Range.Text = modszoveg

    End If

Next sor

End Sub

'*******************************************************************************************************

'                        E-mail cím helyességének ellenőrzése

'*******************************************************************************************************

Function IsEmailValid(strEmail) ' Email cím ellenőrzés

Dim strArray As Variant

Dim strItem As Variant

Dim i As Long, c As String, blnIsItValid As Boolean

blnIsItValid = True

i = Len(strEmail) - Len(Replace(strEmail, "@", ""))

If i <> 1 Then IsEmailValid = False: Exit Function

ReDim strArray(1 To 2)

strArray(1) = Left(strEmail, InStr(1, strEmail, "@", 1) - 1)

strArray(2) = Replace(Right(strEmail, Len(strEmail) - Len(strArray(1))), "@", "")

For Each strItem In strArray

    If Len(strItem) <= 0 Then

        blnIsItValid = False

        IsEmailValid = blnIsItValid

        Exit Function

    End If

    For i = 1 To Len(strItem)

        c = LCase(Mid(strItem, i, 1))

        If InStr("abcdefghijklmnopqrstuvwxyz_-.", c) <= 0 And Not IsNumeric(c) Then

            blnIsItValid = False

            IsEmailValid = blnIsItValid

            Exit Function

        End If

    Next i

    If Left(strItem, 1) = "." Or Right(strItem, 1) = "." Then

        blnIsItValid = False

        IsEmailValid = blnIsItValid

        Exit Function

    End If

Next strItem

If InStr(strArray(2), ".") <= 0 Then

    blnIsItValid = False

    IsEmailValid = blnIsItValid

    Exit Function

End If

i = Len(strArray(2)) - InStrRev(strArray(2), ".")

If i <> 2 And i <> 3 Then

    blnIsItValid = False

    IsEmailValid = blnIsItValid

    Exit Function

End If

If InStr(strEmail, "..") > 0 Then

    blnIsItValid = False

    IsEmailValid = blnIsItValid

    Exit Function

End If

IsEmailValid = blnIsItValid

End Function

 

Előzmény: pimre (735)
pimre Creative Commons License 2019.08.05 0 0 735

Igen, letöltöttem, de aztán lehet, hogy nem azzal csináltam. Most újra próbálva valóban 5 db x-re cseréli az összes email címet. És az enyémmel ellentétben megtartja a formázásokat.

 

Azért idemásolom az enyémet is: Wordben nem tudtam volna, nincs meg hozzá a Word parancskészletem, és abból is túl időigényes lett volna megkeresni a megfelelő eljárásokat.

 

Ezért ahogy a programszöveg fejlécében megírtam, Kimásoljuk a szöveget és beillesztjük A1-től az aktív munkalapra célformátummal megegyezően. Ha kész, visszamásoljuk Word-be "csak a szöveg megtartása" opcióval. Ezzel ugyan a formázások elvesznek, de az email címek átíródnak

 

És akkor a makró (az emailcím helyességét ellenőrző részlet nem a sajátom, az interneten találtam, de működik):

 

Option Explicit

'

' Szövegekben email címek karaktereinek cseréje x-re

'

' Kimásolás, majd beillesztés az aktív munkalapra az A1-től kezdődően a célformátummal megegyezően

' Ha kész, visszamásolás Word-be csak a szöveg megtartása opcióval

' Ezzel ugyan a formázások elvesznek, de az email címek kitörlődnek

'

Const TESZT As Boolean = False ' teszteléskor átállítjuk True értékre, ekkor nem módosítja az adatokat, csak kiírja immediate-ba az eredeti és alá a módosított sort

Sub cimtorles()

Dim szoveg As String, modszoveg As String, sor As Long, hely As Long, i As Long, _

    emailcim As String, atirtemailcim As String, emailkezdet As Long, emailveg As Long, megvan As Boolean, valid As Boolean

For sor = 1 To ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row

    szoveg = ActiveSheet.Range("A" & sor)

    If TESZT Then Debug.Print szoveg  ' Ez csak teszteléskor kell

    modszoveg = ""

    If InStr(szoveg, "@") > 0 Then ' Csak ha van a sorban @, akkor tesztelünk

        While InStr(szoveg, "@") > 0 ' Ciklus végég a sorban megtalálható @ karaktereken

            hely = InStr(szoveg, "@")

            If hely = 1 Then ' Ha az első helyen van a @, akkor nem lehet email cím

                modszoveg = modszoveg & Left(szoveg, 1) ' ez maga a @ karakter

                szoveg = Mid(szoveg, 2) ' így a @ után folytatjuk majd a keresést

            ElseIf hely = Len(szoveg) Then  ' Ha az utolsó helyen van a @, akkor nem lehet email cím

                modszoveg = modszoveg & szoveg ' Ekkor mégsincs a szövegben emailcím, így befejeztük az adott sor vizsgálatát

                szoveg = "" ' így befejezzük a keresést

            Else

                emailkezdet = hely ' Kerssük az email cím első karakterét

                megvan = False

                While Not megvan ' A @ előtti szóköz keresése

                    If Mid(szoveg, emailkezdet - 1, 1) = " " Then

                        megvan = True

                    Else

                        emailkezdet = emailkezdet - 1

                        If emailkezdet = 1 Then megvan = True ' Ez így még nem biztos, hogy jó

                    End If

                Wend

                emailveg = hely ' Kerssük az email cím első karakterét

                megvan = False

                While Not megvan ' A @ előtti szóköz keresése

                    If Mid(szoveg, emailveg + 1, 1) = " " Then

                        megvan = True

                    Else

                        emailveg = emailveg + 1

                        If emailveg = Len(szoveg) Then megvan = True ' Ez így még nem biztos, hogy jó

                    End If

                Wend

            End If

            emailcim = Mid(szoveg, emailkezdet, emailveg - emailkezdet + 1)

            valid = IsEmailValid(emailcim)

            If Not valid Then

                emailveg = emailveg - 1 ' ha mondatvégi pont,vagy valami egyéb nem odaillő kerület volna a végére

                emailcim = Mid(szoveg, emailkezdet, emailveg - emailkezdet + 1) '  Akkor javítjuk és újra teszteljük

                valid = IsEmailValid(emailcim)

                If Not valid Then emailveg = emailveg + 1 ' Ha ezután is érvénytelen, akkor visszaállítjuk a végét, és ejtjük

            End If

            If valid Then

                atirtemailcim = ""

                For i = 1 To Len(emailcim)

                    If Mid(emailcim, i, 1) = "@" Or Mid(emailcim, i, 1) = "." Then

                       atirtemailcim = atirtemailcim & Mid(emailcim, i, 1)

                    Else

                       atirtemailcim = atirtemailcim & "x"

                    End If

                Next i

                modszoveg = modszoveg & Left(szoveg, emailkezdet - 1) & atirtemailcim ' az emailcím kezdete előtti rész

                szoveg = Mid(szoveg, emailveg + 1) ' Az emailcím utáni rész

            Else

                modszoveg = modszoveg & Left(szoveg, emailveg)  ' a vélt emailcímmel záruló rész

                szoveg = Mid(szoveg, emailveg + 1) ' A vélt emailcím utáni rész

           End If

        Wend

    End If

    modszoveg = modszoveg & szoveg ' A maradékot hozzáfűzzük

    If TESZT Then

        Debug.Print modszoveg   ' Ez csak teszteléskor kell

    Else

        ActiveSheet.Range("A" & sor) = modszoveg ' visszaírás

    End If

Next sor

End Sub

'*******************************************************************************************************

'                        E-mail cím helyességének ellenőrzése

'*******************************************************************************************************

Function IsEmailValid(strEmail) ' Email cím ellenőrzés

Dim strArray As Variant

Dim strItem As Variant

Dim i As Long, c As String, blnIsItValid As Boolean

blnIsItValid = True

i = Len(strEmail) - Len(Application.Substitute(strEmail, "@", ""))

If i <> 1 Then IsEmailValid = False: Exit Function

ReDim strArray(1 To 2)

strArray(1) = Left(strEmail, InStr(1, strEmail, "@", 1) - 1)

strArray(2) = Application.Substitute(Right(strEmail, Len(strEmail) - Len(strArray(1))), "@", "")

For Each strItem In strArray

    If Len(strItem) <= 0 Then

        blnIsItValid = False

        IsEmailValid = blnIsItValid

        Exit Function

    End If

    For i = 1 To Len(strItem)

        c = LCase(Mid(strItem, i, 1))

        If InStr("abcdefghijklmnopqrstuvwxyz_-.", c) <= 0 And Not IsNumeric(c) Then

            blnIsItValid = False

            IsEmailValid = blnIsItValid

            Exit Function

        End If

    Next i

    If Left(strItem, 1) = "." Or Right(strItem, 1) = "." Then

        blnIsItValid = False

        IsEmailValid = blnIsItValid

        Exit Function

    End If

Next strItem

If InStr(strArray(2), ".") <= 0 Then

    blnIsItValid = False

    IsEmailValid = blnIsItValid

    Exit Function

End If

i = Len(strArray(2)) - InStrRev(strArray(2), ".")

If i <> 2 And i <> 3 Then

    blnIsItValid = False

    IsEmailValid = blnIsItValid

    Exit Function

End If

If InStr(strEmail, "..") > 0 Then

    blnIsItValid = False

    IsEmailValid = blnIsItValid

    Exit Function

End If

IsEmailValid = blnIsItValid

End Function

 

Előzmény: m54-b (734)
m54-b Creative Commons License 2019.08.05 0 0 734

A 730 alján van egy link, letölthető, gépelni sem kell.

Előzmény: pimre (732)
m54-b Creative Commons License 2019.08.05 0 0 733

a megtalált email címek végéről 5 karaktert átír x-re

 

??? nekem a teljes email címet törli, és rakja be a helyére az xxxxx-t. (Ez volt: "Ezeket kellene eltüntetni. Helyettük xxxx, vagy szóköz".) Természetesen az xxxxx helyére beírható a szóköz is. (A .Replacement.Text = "xxxxx" --> .Replacement.Text = " ", vagy .Replacement.Text = "" is működik.

 

per jelek () törlését illeti, könnyen kivédheted, ha megduplázod őket

 

Igen, rájöttem, köszönet. De az ábra tűnt biztosnak, nem tudtam előre, melyik mit okozhat. Simán html-ben menne (&#92;), de itt a fórumon nem gyakoroltam.

Előzmény: pimre (732)

Ha kedveled azért, ha nem azért nyomj egy lájkot a Fórumért!