Hallo,
oha, das sagst Du jetzt...;-)...aber ok, dann macht's Sinn...da müssen wir jeden einzelnen Buchstaben durchnuckeln...
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
Gruß,
|