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(
"test1"
).Range
objRange.Text =
CStr
(.Cells(1, 2).Value)
Call
Font_Transfer(probjWdChars:=objRange.Characters, probjXlCell:=.Cells(1, 2))
Set
objRange = ActiveDocument.Bookmarks(
"test2"
).Range
objRange.Text =
CStr
(.Cells(1, 1).Value)
Call
Font_Transfer(probjWdChars:=objRange.Characters, probjXlCell:=.Cells(1, 1))
Set
objRange = ActiveDocument.Bookmarks(
"test3"
).Range
objRange.Text =
CStr
(.Cells(1, 3).Value)
Call
Font_Transfer(probjWdChars:=objRange.Characters, probjXlCell:=.Cells(1, 3))
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
probjWdChars
As
Characters,
ByRef
probjXlCell
As
Object
)
Dim
objXlFont
As
Object
Dim
lngIndex
As
Long
With
probjXlCell
For
lngIndex = 1
To
.Characters.Count
Set
objXlFont = .Characters(Start:=lngIndex, Length:=1).Font
With
probjWdChars.Item(Index:=lngIndex).Font
.Color = objXlFont.Color
.Bold = objXlFont.Bold
.Name = objXlFont.Name
.Italic = objXlFont.Italic
.Size = objXlFont.Size
.Underline = GetFontUnderline(pvlngXlUnderline:=objXlFont.Underline)
End
With
Next
End
With
Set
objXlFont =
Nothing
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