Szóköz számlálás

[r4zoli]

Az admin cimre jött levélből:

Forditokent mukodom es OpenOffice-t hasznalok. A munkam elszamolasa leutes alapu, es vannak olyan megrendelok akiknek szokoz nelkuli elszamolassal forditok. Noha van mar statisztika az OpenOffice-ban meg mindig NEM LEHET A SZOKOZ NELKULI LEUTESEK SZAMAT megkapni a statisztikaban. korabban mar ajanlottak, hogy vonjam ki az osszkarakterszambol a szavak szamat es akkor megkapom, amely nagyon orvendetes megoldasnak tunt, de a nem-betu karaktereket nem szamolja es abszolut nem megbizhato ilyen esetekben. VAN MAR ERRE VALAMI BEEPITETT MEGOLDAS? Mert jelenleg minden problemas esetben apamhoz kuldom a fajlokat es WORD-ben szamoltatom a statisztikat...Es ez szegyenletes is meg abszolut nehezkes...ne kelljen mar feltelepitenem a gepemre a Word-ot!!!

Koszonom elore is a segitseget, Eszter

[r4zoli]

Az alábbi makrót találtam az angol fórumon ideiglenes megoldásként, angol szövegekre jó csak és ha nincs tartalom jegyzék (akkor nullát ad az eredményre), magyarítani kellene az lenne az igazi.

Kód: Egész kijelölése

    Sub CharactersCount
       Dim oDoc      As Object
       Dim oText     As Object
       Dim oParser   As Object
       Dim oUrl      As New com.sun.star.util.URL
       Dim b         As String
       Dim t         As String
       ' Counters definition
       Dim sc         As Long   ' sapce
       Dim lc         As Long   ' letter
       Dim dc         As Long   ' digit
       Dim rc         As Long   ' carriage return
       Dim oc         As Long   ' other

       oDoc = ThisComponent.CurrentController.Frame
       oParser = createUnoService("com.sun.star.util.URLTransformer")
       oDoc = ThisComponent
       oText = oDoc.Text
       
       t = Left( oText.String, 100 )
       For p = 1 To Len( t )
          Select Case Mid( t, p, 1 )
             Case "a" To "z", "A" To "Z", "0" To "9"
                b = Mid( t, p, 50 )
                Exit For
          End Select
       Next p

       ' Get the counts
       n = 1
       Do
          t = Mid( oText.String, n, 64000 )
          n = n + 64000
          For p = 1 To Len( t )
             Select Case Mid( t, p, 1 )
                Case "a" To "z", "A" To "Z"    ' letters
                   lc = lc + 1
                Case " ", Chr( 9 )          ' tabulation and spaces
                   sc = sc + 1
                Case "0" To "9"             ' digits
                   dc = dc + 1
                Case Chr( 13 )             ' carriage returns
                   rc = rc + 1
                Case Chr( 10 )
                   ' to be ignored
                Case else
                   oc = oc + 1
             End Select
          Next p
       Loop While Len( t ) = 64000

       ' Show the results
       t = "Alphanumerical characters: " & Str( lc + dc ) & Chr(13) & Chr(10) _
           & "Spaces and tabulations : " & Str(sc) & Chr(13) & Chr(10) _
           & "Others (punctuation, ...): " & Str(oc) & Chr(13) & Chr(10) _
           & "Total: " & Str(lc+dc+sc+oc) & Chr(13) & Chr(10) _
           & "Total minus spaces and tabs: " & Str(lc+dc-sc)
       MsgBox t,0,"Custom count"

    End Sub

[Poliverzum]

Hát én megpróbáltam ezt a makrót berakni, be is vette a "Saját makrók/Standard/Module1" izé... mondjuk hogy könyvtárba, még a Shift+F10-et is hozzárendeltem, de sajna egy jó 20 oldalas dokumentumban is minden értéknek nullát jelzett ki! (Plusz ugye, gondolom a magyar ékezetes betűket amúgy sem számlálná).

[g_123_wert]

Én úgy látom, hogy 64 000 betű után ez túlcsordul. Ezért lehet nulla nálad.
Favágó módszerrel beletettem a magyar karakterek számlálását. Nekem működik.
Csináltam próba fájlt is, csatolom.
Sortörésből egyel kevesebbet számol.

A kód:

Kód: Egész kijelölése

Sub CharactersCount
       Dim oDoc      As Object
       Dim oText     As Object
       Dim oParser   As Object
       Dim oUrl      As New com.sun.star.util.URL
       Dim b         As String
       Dim t         As String
       ' Counters definition
       Dim sc         As Long   ' sapce
       Dim lc         As Long   ' letter
       Dim dc         As Long   ' digit
       Dim rc         As Long   ' carriage return
       Dim oc         As Long   ' other

       oDoc = ThisComponent.CurrentController.Frame
       oParser = createUnoService("com.sun.star.util.URLTransformer")
       oDoc = ThisComponent
       oText = oDoc.Text
       
       t = Left( oText.String, 100 )
       For p = 1 To Len( t )
          Select Case Mid( t, p, 1 )
             Case "a" To "z", "A" To "Z", "0" To "9"
                b = Mid( t, p, 50 )
                Exit For
          End Select
       Next p

       ' Get the counts
       n = 1
       Do
          t = Mid( oText.String, n, 64000 )
          n = n + 64000
          For p = 1 To Len( t )
             Select Case Mid( t, p, 1 )
                Case "a" To "z", "A" To "Z"    ' letters
                   lc = lc + 1
                Case " ", Chr( 9 )          ' tabulation and spaces
                   sc = sc + 1
                Case "0" To "9"             ' digits
                   dc = dc + 1
                Case Chr( 13 )             ' carriage returns
                   rc = rc + 1
                Case Chr( 10 )
                   ' to be ignored
                Case "á"   
                   lc = lc + 1
                Case "Á"   
                   lc = lc + 1
                Case "é"   
                   lc = lc + 1
                Case "É"   
                   lc = lc + 1
                Case "í"   
                   lc = lc + 1
                Case "Í"   
                   lc = lc + 1
                Case "ó"   
                   lc = lc + 1
                Case "Ó"   
                   lc = lc + 1
                Case "ö"   
                   lc = lc + 1
                Case "Ö"   
                   lc = lc + 1
                Case "ő"   
                   lc = lc + 1
                Case "Ő"   
                   lc = lc + 1
                Case "ú"   
                   lc = lc + 1
                Case "Ú"   
                   lc = lc + 1
                Case "ü"   
                   lc = lc + 1
                Case "Ü"   
                   lc = lc + 1
                Case "ű"   
                   lc = lc + 1
                Case "Ű"   
                   lc = lc + 1
                Case else
                   oc = oc + 1
             End Select
          Next p
       Loop While Len( t ) = 64000

       ' Show the results
       t = "Alfanumerikus karakterek: " & Str( lc + dc ) & Chr(13) & Chr(10) _
           & "Space -ek és TAB -ok : " & Str(sc) & Chr(13) & Chr(10) _
           & "Egyéb (vessző, pont stb.): " & Str(oc) & Chr(13) & Chr(10) _
           & "Sortörés: " & Str(rc) & Chr(13) & Chr(10) _
           & "Teljes: " & Str(lc+dc+sc+oc+rc) & Chr(13) & Chr(10) _
           & "Teljes sortörések nélkül" & Str(lc+dc+sc+oc)
       MsgBox t,0,"Custom count"

End Sub

[Poliverzum]

A próbálkozásodat köszi, de nem értem a dolgot. Van 2 doksim. Az egyiknél ragyogóan kiírja amit kell. A másiknál továbbra is mindenre nullát ír ki. A hosszabbiknál. mi több mint 500 ezer karakteres. Nem értem, miért. Talán még mindig túlcsordul?