Как выделить слова из текста?

[Maxxx.!!!.]

Проблема такова: есть RTFBox, в котором содержится произвольный текст. Требуется: выделить из него слова и знанести их в массив. Т.е., чтобы в массив попали только слова: без пробелов, без знаков препинания; если какое-то слово в скобках или кавычках, то эти кавычки и скобки надо убрать и т.д. Я пробовал сам: получались глюки.

[BV]

Код того, что ты пробовал - в студию.

[Maxxx.!!!.]

Код: Выделить всё

'Îáúÿâëåíèå ïåðåìåííûõ
Public num_char As Long 'êîë-âî ñèìâîëîâ â òåêñòå
Public num_word As Long 'êîë-âî ñëîâ â òåêñòå
Public num_letter As Long 'êîë-âî áóêâ â òåêñòå

Private Sub Ñòàòèñòèêà_Click()
Dim abc As String 'õðàíèì òåêñò
abc = RichTextBox1.Text 'çàïèñûâàåì â abc òåêñò
Dim aaa As Long
aaa = Len(abc) 'äëèíà òåêñòà
num_char = aaa 'êîë-âî ñèìâîëîâ â ãëîá. ïåðåìåííóþ
'Ñîçäàåì ìàññèâ ñ êîë-ì ýëåìåíòîâ, ðàâíûì êîë-âó ñèìâîëîâ â ñòðîêå
'Dim slova(100) As String
ReDim slova(aaa) As String 'ðàçìåð ìàññèâà=êîëè÷åñòâó ñèìâîëîâ â òåêñòå
Dim i
Dim bukva As String 'õðàíèì òåêóùèé ñèìâîë
Dim bukva2 As String 'õðàíèì äâà ñèìâîëà: òåêóùèé+ñëåäóþùèé
Dim ii As Long
ii = 0
'ñ÷èòûâàåì âñå ñèìâîëû
For i = 1 To aaa
    'çàíîñèì òåêóùèé ñèìâîë â bukva
    bukva = Mid(abc, i, 1)
    'çàíîñèì äâà ñèìâîëà â bukva2
    bukva2 = Mid(abc, i + 1, 1)
'çàíîñèì â ìàññèâ áóêâû ïîäðÿä
slova(ii) = slova(ii) & bukva
'ïðîâåðêà: íîâîå ëè ñëîâî
    If bukva = " " Or bukva2 = "; " Or bukva2 = ". " _
    Or bukva2 = ", " Or bukva2 = ": " Or bukva2 = "? " _
    Or bukva2 = "! " Or bukva2 = ") " Or bukva = ")" Then
    'óäàëÿåì ïðîáåë, ò.å. êðàéíèé ñïðàâà ñèìâîë
    slova(ii) = Left(slova(ii), Len(slova(ii)) - 1)
'óäàëÿåì ñëåäóþùèé ñèìâîë - çíàê ïðåïèíàíèÿ
        If Right(slova(ii), 1) = "." Or Right(slova(ii), 1) = ";" _
        Or Right(slova(ii), 1) = ":" Or Right(slova(ii), 1) = "," _
        Or Right(slova(ii), 1) = "?" Or Right(slova(ii), 1) = "!" _
        Or Right(slova(ii), 1) = ")" _
        Then slova(ii) = Left(slova(ii), Len(slova(ii)) - 1)
    'ïåðåäâèãàåì èíäåêñ ìàññèâà, ÷òîáû ñëåäóþùèå ñèìâîëû
    'çàïèñûâàëèñü óæå â äðóãóþ ÿ÷åéêó ìàññèâà
    ii = ii + 1
    End If
     
Next i

ReDim Preserve slova(ii) 'óìåíüøàåì ðàçìåð ìàññèâà äî êîë-âà ñëîâ â òåêñòå
num_word = ii 'êîë-âî ñëîâ â ãëîá. ïåðåìåííóþ

'âû÷èñëÿåì êîë-âî áóêâ, ò.å. çà âû÷åòîì ïðîáåëîâ è çíàêîâ ïðåïèíàíèÿ
num_letter = 0
For i = 0 To num_word
num_letter = num_letter + Len(slova(i))
Next i


[dr.MIG]

Я бы сначала заменил всё что нам ненадо (скобки, запятые и т.д.) на "" - см. ф-я Replace, затем использовал бы ко всему тексту ф-ю Split с разделителем " "(пробел).
Единственно возможная проблема - если будут пробелы не одинарные, а двойные, тройные и т.д., то получится не очень красиво

[Andrey Fedorov]

Я бы сначала заменил всё что нам ненадо (скобки, запятые и т.д.) на "" - см. ф-я Replace, затем использовал бы ко всему тексту ф-ю Split с разделителем " "(пробел).

А ты не учитываешь,что иногда после запятой забывают ставить пробел,к примеру?

[Antonariy]

Заменить сначала все знаки препинания на пробелы, потом прогнать в цикле

Код: Выделить всё

Replace(txt, "  ", " ")

до тех пор, пока длина строки до не станет равна длине после. Потом split.

[Andrey Fedorov]

Вот примерчик функции, возвращающей массив слов (за слово считается непрерывная последовательность одних алфавитных символов) с учетом переноса слов на другую строку:

Код: Выделить всё

Option Explicit

Private Declare Function IsCharAlpha Lib "user32" Alias "IsCharAlphaA" (ByVal cChar As Byte) As Long

Public Sub Main()
    Const sFile As String = "C:\Temp\hottab.txt" ' файл длиной 455684 байт
    Dim t As Single, iHFile As Integer, sText As String, n As Long, m() As String, i As Long
   
    iHFile = FreeFile
    Open sFile For Binary Access Read As #iHFile
    sText = Space(LOF(iHFile))
    Get #iHFile, , sText
    Close #iHFile
   
    t = Timer
    n = TextInArray(sText, m)
    t = Timer - t
   
    Debug.Print Format$(t, "#,##0.000") & " сек", n & " слов"
    For i = 0 To IIf(n > 10, 10, n)
        Debug.Print m(i)
    Next i
End Sub

Private Function TextInArray(ByVal sText As String, m() As String) As Long
    Dim s As String, ss As String, sss As String, v As Variant
    Dim i As Long, k As Long, kk As Long, n As Long
   
    n = Len(sText) - 1
    If n < 0 Then Erase m: TextInArray = -1: Exit Function
       
    v = Split(Replace(sText, vbTab, " "), vbCrLf)
    ReDim m(n): n = -1
    kk = UBound(v)
    For k = 0 To kk
        ss = Trim$(v(k))
        i = Len(ss)
        If i Then
            If i > 1 Then
                ' Если в конце строки стоит перенос...
                Do While IsCharAlpha(Asc(Mid$(ss, i - 1, 1))) And Right$(ss, 1) = "-" And k < kk
                    k = k + 1
                    s = Trim$(v(k))
                    If Len(s) Then
                        ss = Left$(ss, i - 1) & s
                        i = Len(ss)
                    End If
                Loop
            End If
            For i = 1 To i
                s = Mid$(ss, i, 1)
                If IsCharAlpha(Asc(s)) Then
                    sss = sss & s
                Else
                    If Len(sss) Then n = n + 1: m(n) = sss: sss = vbNullString
                End If
            Next i
            If Len(sss) Then n = n + 1: m(n) = sss: sss = vbNullString
        End If
    Next k
    If n >= 0 Then ReDim Preserve m(n) Else Erase m
    TextInArray = n
End Function

Файлик длиной 455684 у меня обрабатывается за 0,42 сек и содержит 63602 слова...