Hallo,
ok, dann probier mal folgendes, das ist jetzt aus Word programmiert, Deinen Textboxen müssen zwingend TextBox1, TextBox2 und TextBox3 heißen, oder Du änderst das im Code.
Der erste kleine Code-Teil sind Ereignisprozeduren für die Boxen und gehört in Dein Dokument-Modul ('ThisDocument').
Der zweite große Code-Teil gehört in ein Standardmodul (Rechtsklick auf die Module >>> Einfügen >>> Modul).
Option Explicit
Private mstrText As String
Private Sub Document_ContentControlOnEnter(ByVal ContentControl As ContentControl)
mstrText = ContentControl.Range.Text
End Sub
Private Sub Document_ContentControlOnExit(ByVal ContentControl As ContentControl, Cancel As Boolean)
With ContentControl '// Hier Deine TextBox-Namen...
If .Title = "TextBox1" Then _
If .Range.Text <> mstrText Then _
Call Fill_Boxes(pvstrText:=.Range.Text)
End With
End Sub
Option Explicit
Option Private Module
Private lblnTMP As Boolean
Public Sub Fill_Boxes(ByVal pvstrText As String)
Const FILE_PATH As String = "C:\Users\MyUser\Documents\Excel\"
Const FILE_NAME As String = "MyExcelFile.xlsx"
Const xlValues As Long = -4163
Const xlWhole As Long = 1
Dim objApp As Object
Dim objWorkbook As Object
Dim objCell As Object
On Error GoTo Sub_Exit
Set objApp = OffApp("Excel")
'// folgende Codezeile für Excel nicht sichtbar:
'// Set objApp = OffApp("Excel", False)
If Not objApp Is Nothing Then
For Each objWorkbook In objApp.Workbooks
If objWorkbook.Name = FILE_NAME Then Exit For
Next
If objWorkbook Is Nothing Then _
Set objWorkbook = objApp.Workbooks.Open(FileName:=FILE_PATH & FILE_NAME)
Set objCell = objWorkbook.Worksheets(1).UsedRange.Find(What:=Trim$(pvstrText), _
LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Not objCell Is Nothing Then
With ActiveDocument '// Hier Deine TextBox-Namen...
.SelectContentControlsByTitle("TextBox2")(1).Range.Text = objCell.Offset(0, 1).Value
.SelectContentControlsByTitle("TextBox3")(1).Range.Text = objCell.Offset(0, 2).Value
End With
Else
Call MsgBox(Prompt:="Searched Data couldn't be found!", Buttons:=vbExclamation, Title:="Error")
End If
Else
Call MsgBox(Prompt:="Application not installed!", Buttons:=vbExclamation, Title:="Error")
End If
Sub_Exit:
If Not objApp Is Nothing Then
If lblnTMP Then
Call objApp.Quit
lblnTMP = False
End If
End If
Set objCell = Nothing
Set objWorkbook = Nothing
Set objApp = Nothing
If Err.Number <> 0 Then Call MsgBox(Prompt:="Fehler: " & _
Err.Number & " " & Err.Description, _
Buttons:=vbExclamation, Title:="Error")
End Sub
Private Function OffApp(ByVal pvstrApp As String, _
Optional ByVal opvblnVisible As Boolean = True) As Object
Dim objApp As Object
On Error Resume Next
Set objApp = GetObject(Class:=pvstrApp & ".Application")
If Err.Number = 429 Then
Call Err.Clear
Set objApp = CreateObject(Class:=pvstrApp & ".Application")
lblnTMP = True
If opvblnVisible Then
On Error Resume Next
objApp.Visible = True
Call Err.Clear
End If
End If
On Error GoTo 0
Set OffApp = objApp
Set objApp = Nothing
End Function
Vier Erfolg erstmal...Gruß,
|