Option
Explicit
Private
Sub
CommandButton1_Click()
Dim
oExcelApp
As
Object
Dim
oExcelWorkbook
As
Object
Dim
lZeile
As
Long
Dim
objRange
As
Range
If
ListBox1.ListIndex >= 0
Then
Set
oExcelApp = CreateObject(
"Excel.Application"
)
Set
oExcelWorkbook = oExcelApp.Workbooks.Open(sBeispiel)
lZeile = 2
With
oExcelWorkbook.Sheets(sTabellenblatt)
Do
While
.Cells(lZeile, 1) <>
""
If
ListBox1.Text =
CStr
(.Cells(lZeile, 2).Value)
Then
Set
objRange = ActiveDocument.Bookmarks(
"Textmarke_Name "
).Range
With
.Cells(lZeile, 2)
objRange.Text =
CStr
(.Value)
Call
Font_Transfer(probjWdFont:=objRange.Font, probjXlFont:=.Font)
End
With
Set
objRange = ActiveDocument.Bookmarks(
"Textmarke_ID"
).Range
With
.Cells(lZeile, 1)
objRange.Text =
CStr
(.Value)
Call
Font_Transfer(probjWdFont:=objRange.Font, probjXlFont:=.Font)
End
With
Set
objRange = ActiveDocument.Bookmarks(
"Textmarke_Beschreibung"
).Range
With
.Cells(lZeile, 3)
objRange.Text =
CStr
(.Value)
Call
Font_Transfer(probjWdFont:=objRange.Font, probjXlFont:=.Font)
End
With
Set
objRange =
Nothing
Exit
Do
End
If
lZeile = lZeile + 1
Loop
End
With
oExcelWorkbook.Close
False
oExcelApp.Quit
Else
MsgBox
"Bitte wählen Sie einen Eintrag aus der Liste aus!"
, _
vbInformation + vbOKOnly,
"HINWEIS!"
Exit
Sub
End
If
Set
oExcelWorkbook =
Nothing
Set
oExcelApp =
Nothing
Unload
Me
End
Sub
Private
Sub
Font_Transfer(
ByRef
probjWdFont
As
Font,
ByRef
probjXlFont
As
Object
)
With
probjXlFont
probjWdFont.Color = .Color
probjWdFont.Bold = .Bold
probjWdFont.Name = .Name
probjWdFont.Italic = .Italic
probjWdFont.Underline = GetFontUnderline(pvlngXlUnderline:=.Underline)
End
With
End
Sub
Private
Function
GetFontUnderline(
ByVal
pvlngXlUnderline
As
Long
)
As
WdUnderline
Const
xlUnderlineStyleNone
As
Long
= -4142
Const
xlUnderlineStyleSingle
As
Long
= 2
Const
xlUnderlineStyleDouble
As
Long
= -4119
Select
Case
pvlngXlUnderline
Case
Is
= xlUnderlineStyleNone: GetFontUnderline = wdUnderlineNone
Case
Is
= xlUnderlineStyleSingle: GetFontUnderline = wdUnderlineSingle
Case
Is
= xlUnderlineStyleDouble: GetFontUnderline = wdUnderlineDouble
End
Select
End
Function