Forum

Forum (https://www.ms-office.gr/forum/)
-   Access - Ερωτήσεις / Απαντήσεις (https://www.ms-office.gr/forum/access-erotiseis-apantiseis/)
-   -   Από Access 2007 ψάξιμο λέξης σε έγγραφο word (https://www.ms-office.gr/forum/access-erotiseis-apantiseis/5261-apo-access-2007-psaksimo-leksis-se-eggrafo-word.html)

dim.konst 31-05-19 20:35

Από Access 2007 ψάξιμο λέξης σε έγγραφο word
 
Γεια σας είμαι σχετικά νέος στη vba και θέλω τη βοήθεια σας.
Με ένα κουμπί σε μια φόρμα access 2007 θέλω να ανοίγω ένα ένα τα έγγραφα word από ένα φάκελο και να ψάχνω ένα επώνυμο, όταν βρεθεί το επώνυμο που έδωσα από inputbox στην access θέλω να μου βγάζει ένα μήνυμα Msgbox ότι βρέθηκε και να αφήνει ανοιχτό το έγγραφο, αν είναι συνωνυμία να συνεχίζει το ψάξιμο στα επόμενα έγγραφα.
Ευχαριστώ εκ των προτέρων.

dim.konst 02-06-19 09:02

Τελικά ψάχνοντας στο ιντερνετ βρήκα λύση που με κάποιες μετατροπές με καλύπτει. Ίσως δεν είναι η καλύτερη λύση αλλά μου έλυσε το πρόβλημα, ανεβάζω τον κώδικα για όποιον αντιμετωπίσει παρόμοιο πρόβλημα.

Private Sub FindInDoc
Dim wApp As Word.Application
Dim mySource As Object
Dim oDoc As Object
Const wdYellow = 7
Dim rng1 As Range
Dim strTheText As String
Dim metr, metr2 As Integer

strTheText = InputBox("Δώσε Επώνυμο για ψάξιμο μέσα στα έγγραφα του φακέλου TEST_WORD")
DoCmd.Hourglass True
If Len(strTheText) < 2 Then
DoCmd.Hourglass False
Exit Sub
End If
Set obj = CreateObject("Scripting.FileSystemObject")
Set mySource = obj.GetFolder("D\TEST_WORD")

For Each file In mySource.Files 'loop through the directory
If Len(file.Name) > 0 And InStr(1, file.Name, "$") = 0 Then
Set wApp = CreateObject("Word.Application")
Set oDoc = wApp.Documents.Open(mySource & "\" & file.Name)
oDoc.Content.Find.HitHighlight FindText:=strTheText
Set rng1 = oDoc.Range
If rng1.Find.Execute(FindText:=strTheText) Then
wApp.Visible = True
AnswerVRE = MsgBox( " ΒΡΈΘΗΚΕ - ΘΈΛΕΤΕ ΝΑ ΣΥΝΕΧΊΣΕΤΕ ΤΟ ΨΆΞΙΜΟ", vbYesNo + vbQuestion + vbDefaultButton1, "ΕΠΙΛΈΞΤΕ;")
If AnswerVRE = vbNo Then
DoCmd.Hourglass False
Exit Sub
End If
End If
On Error Resume Next
wApp.Quit
Set wApp = Nothing
End If
Next file
DoCmd.Hourglass False
MsgBox "Τέλος "
End Sub


Η ώρα είναι 15:49.

Ms-Office.gr - ©2000 - 2026, Jelsoft Enterprises Ltd.


Search Engine Optimization by vBSEO 3.3.2