Запрос к базе данных

[rikomono]

Помогите написать макрос.
1) Имеется текст в редакторе Word
2) Нужно чтобы по каждому слову был сделан запрос к базе данных Access или к книги Exel
3) Поиск слова в поле "ААА".
4) Слово находящееся в ячейке поля "ВВВ" справа от слова в поле "ААА" было помещено на слово в исходном тексте с помощью (PhoneticGuide)
5) А если слова нет в базе данных, то слово в тексте заключалось бы в такие скобки <слово>

[rikomono]

У меня есть такой макрос.
Я его переделал из другого насколько хватило мозгов. Но как сделать чтобы происходило обращение к базе данных Access или книги Exel, а не просто помещения текста между кавычками на слово слева?

Sub Trans()
Dim s As String
Do
Selection.Find.ClearFormatting
With Selection.Find
.Text = ChrW(12298) & "*" & ChrW(12299)
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.Find.Execute
s = Selection.Text
If Len(s) < 2 Then Exit Sub 'нет искомого текста, конец работы
s = Mid(s, 2, Len(s) - 2) 'удалить первый и последний символ
Selection.Cut
Selection.MoveLeft Unit:=wdWord, Count:=1, Extend:=wdExtend
Selection.Range.PhoneticGuide Text:=s, _
Alignment:=wdPhoneticGuideAlignment OneTwoOne, Raise:=14, FontSize:=10 _
, FontName:="Lucida Sans Unicode"
Loop
End Sub


Если есть специалисты помогите

[doober]

Выложите образцы файлов Excel и Access

[rikomono]

Сообщение от doober

Выложите образцы файлов Excel и Access

Вот выкладываю http://narod.ru/disk/14560279001/data.zip.html

Мне ещё помог очень хороший человек, но сказал что макрос не работает его надо доработать.

Public Sub test()
    Dim w As Range
    Dim i As Integer
    Dim cn As ADODB.Connection
    Dim rs As ADODB.Recordset
    
    'открываем соединение к БД
    Set cn = New ADODB.Connection
    cn.ConnectionString = "тута строка подключения"
    
    'бежим по всем словам в тексте
    For i = 1 To ThisDocument.Words.Count
        'ищем слово в БД
        rs.Open cn, "select BBB from Таблица where AAA = '" + w.Text + "'"
        
        'Слово находящееся в ячейке поля "ВВВ"  справа от слова в поле "ААА" было помещено на слово в исходном тексте с помощью (PhoneticGuide
        If Not rs.EOF Then
            Set w = ThisDocument.Words.Item(i)
            If Asc(w.Text) > 30 Then w.PhoneticGuide Text:="qqq", Alignment:=wdPhoneticGuideAlignmentOneTwoOne, Raise:=14, FontSize:=10, FontName:="Lucida Sans Unicode"
        
        ' А если слова нет в базе данных, то слово в тексте заключалось  бы в такие скобки <слово>
        Else
             w.Text = "<" + w.Text + ">"
        End If
        rs.Close
    Next
    
    Set rs = Nothing
    cn.Close
    Set cn = Nothing
End Sub

[doober]

сначала в диалоге открываете файл Excel.затем Access

[rikomono]

Сообщение от doober

сначала в диалоге открываете файл Excel.затем Access

Я выполняю эти действия, но ничего не происходит.
Там в макросе необходимо вставить кусок кода? Там где пометка

'Ваш код

Надо вставить примерно вот так?

Const sCn1 As String = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source="
Dim Ex As Excel.Application
Dim WB As Workbook
Dim Kol_Listow As Integer
Dim SH1 As Worksheet
 Dim R_Count As Long


Sub start()
Dim cn As ADODB.Connection
' Ñíà÷àëà îòêðûâàåì ôàéë Åêñåëü,ïîòîì Àöåññ

  Dim FileName, FileFilter As String
   FileName = GetFile
    If (FileName = False) Or Trim(FileName) = "" Then Exit Sub
    
    Set Ex = New Excel.Application
  Set WB = Ex.Workbooks.Open(FileName)
 WB.Worksheets(1).Copy
 
 Set SH1 = Ex.ActiveSheet
 R_Count = SH1.Range("A" & SH1.Rows.Count).End(xlUp).Row + 1
 WB.Close (False)

        FileName = GetFile
    If (FileName = False) Or Trim(FileName) = "" Then Exit Sub
         
         Dim sCon As String, sSql As String
     
     Set cn = New ADODB.Connection
       Set rs = New ADODB.Recordset
       
       
         sCon = sCn1 + FileName
        cn.Open (sCon)
sSql = "SELECT AAA, BBB  FROM Таблица1;"
        If Not cn.State = 1 Then Exit Sub
 
  rs.Open sSql, cn, ADODB.CursorTypeEnum.adOpenStatic, ADODB.LockTypeEnum.adLockReadOnly
 
       If rs.RecordCount > 0 Then
              
        SH1.Cells(R_Count, 1).CopyFromRecordset rs
                          
        End If
 '-----------------------------------
'бежим по всем словам в тексте
    For i = 1 To ThisDocument.Words.Count
        'ищем слово в БД
        rs.Open cn, "select BBB from Таблица1 where AAA = '" + w.Text + "'"
        
        'Слово находящееся в ячейке поля "ВВВ"  справа от слова в поле "ААА" было помещено на слово в исходном тексте с помощью (PhoneticGuide
        If Not rs.EOF Then
            Set w = ThisDocument.Words.Item(i)
            If Asc(w.Text) > 30 Then w.PhoneticGuide Text:="qqq", Alignment:=wdPhoneticGuideAlignmentOneTwoOne, Raise:=14, FontSize:=10, FontName:="Lucida Sans Unicode"
        
        ' А если слова нет в базе данных, то слово в тексте заключалось  бы в такие скобки <слово>
        Else
             w.Text = "<" + w.Text + ">"
        End If
        rs.Close
    Next
    
    Set rs = Nothing
    cn.Close
    Set cn = Nothing
' Âàø êîä
'Åñëè ñëîâî íàéäåíî.òî âîçâðàùàåò èç ñòîëáöà ÂÂÂ,åñëè íåò òî "Ffalse"
'
 ff = Slovo("êðàñíûé")
 
  ff1 = Slovo("êðàñí")
  
  '-----------------------------
  
  
  
  'îêîí÷àíèå ðàáîòû ñ ôàéëîì åêñåëü
   Set SH1 = Nothing
   Ex.DisplayAlerts = False
  Ex.Quit
 Set Ex = Nothing
  
End Sub

Function Slovo(ssl As String) As String
Dim X As Excel.Range, Saldo As String, Klient As String
Set X = SH1.Columns(1).Find(What:=ssl, LookAt:=xlWhole)
If Not X Is Nothing Then
Slovo = X.Offset(, 1)
Exit Function
Else
Slovo = "Ffalse"
Exit Function
End If
End Function


Function GetFile(Optional ByVal Title As String = "", Optional ByVal InitialPath As String) As String
    Dim PS
    GetFolderPath_F = "": PS = Application.PathSeparator
    With Application.FileDialog(msoFileDialogOpen)
        .ButtonName = "Âûáðàòü": .Title = Title: .FilterIndex = 1
        If .Show = -1 Then GetFile = .SelectedItems(1): If Not Right$(GetFile, 1) = PS Then GetFile = GetFile
    End With
End Function

[doober]

Что тут не понятно.
Запускаете Start.
Этот макрос объеденяет две базы данных на один лист,дабы не метаться по базам.
Функция Slovo производит разведку в базе данных и выявляет искомое слово.При наличии онного возвращает значение спрва.
Если противник не обнаружен .возвращает Ffalse

Далее запускаете свои макросы,для проверки слова вызываете в нужном месте функцию Slovo
После завершения вашего макроса надо вызвать процедуру gameOver

Удачи

 Const sCn1 As String = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source="
Dim Ex As Excel.Application
Dim WB As Workbook
Dim Kol_Listow As Integer
Dim SH1 As Worksheet
 Dim R_Count As Long


Sub start()
Dim cn As ADODB.Connection
' Сначала открываем файл Ексель,потом Ацесс

  Dim FileName, FileFilter As String
   FileName = GetFile
    If (FileName = False) Or Trim(FileName) = "" Then Exit Sub
    
    Set Ex = New Excel.Application
  Set WB = Ex.Workbooks.Open(FileName)
 WB.Worksheets(1).Copy
 
 Set SH1 = Ex.ActiveSheet
 R_Count = SH1.Range("A" & SH1.Rows.Count).End(xlUp).Row + 1
 WB.Close (False)

        FileName = GetFile
    If (FileName = False) Or Trim(FileName) = "" Then Exit Sub
         
         Dim sCon As String, sSql As String
     
     Set cn = New ADODB.Connection
       Set rs = New ADODB.Recordset
       
       
         sCon = sCn1 + FileName
        cn.Open (sCon)
sSql = "SELECT AAA, BBB  FROM Таблица1;"
        If Not cn.State = 1 Then Exit Sub
 
  rs.Open sSql, cn, ADODB.CursorTypeEnum.adOpenStatic, ADODB.LockTypeEnum.adLockReadOnly
 
       If rs.RecordCount > 0 Then
              
        SH1.Cells(R_Count, 1).CopyFromRecordset rs
                          
        End If

End Sub

Sub gameOver() 'окончание работы с файлом ексель
  Set SH1 = Nothing
   Ex.DisplayAlerts = False
  Ex.Quit
 Set Ex = Nothing
End Sub

Function Slovo(ssl As String) As String
Dim X As Excel.Range, Saldo As String, Klient As String
Set X = SH1.Columns(1).Find(What:=ssl, LookAt:=xlWhole)
If Not X Is Nothing Then
Slovo = X.Offset(, 1)
Exit Function
Else
Slovo = "Ffalse"
Exit Function
End If
End Function


Sub Trans() 'Ваша процедура
искомое_Слово = Slovo("комар")
If искомое_Слово <> "Ffalse" Then
MsgBox "Нашли " & искомое_Слово
Else
MsgBox "Такого слова в базах нет"
End If

End Sub


Function GetFile(Optional ByVal Title As String = "", Optional ByVal InitialPath As String) As String
    Dim PS
    GetFolderPath_F = "": PS = Application.PathSeparator
    With Application.FileDialog(msoFileDialogOpen)
        .ButtonName = "Выбрать": .Title = Title: .FilterIndex = 1
        If .Show = -1 Then GetFile = .SelectedItems(1): If Not Right$(GetFile, 1) = PS Then GetFile = GetFile
    End With
End Function

[rikomono]

Сообщение от doober

Что тут не понятно.

Вы профи, Вам это как 2Х2, а я так и не понял, куда вставить кусок кода, чтобы он автоматически применял (PhoneticGuide).
Мне очень нужен этот макрос, а я к сожалению плохо разбираюсь в VBA.

[doober]

С вордом я практически не работаю,здесь я вам не помощник.
Ждите помощи от спецов по Ворду.

[rikomono]

Спасибо Вам за помощь и что потратили на меня своё время.
Постараюсь хотя и не знаю как дописать Ваш макрос.