TextBox - Formatted - Word!

The content of a TextBox (in Excel 2007 from "Insert - Text - TextBox") is inserted formatted in a new Word document. The files at the end of the article are Excelfiles of the version 2003 and 2007. The following code belonged in "Module1"


Der Inhalt einer Textbox (in Excel 2007 aus "Einfügen - Text - Textfeld") wird formatiert in ein neues Worddokument eingefügt. Die Dateien am Ende des Artikels sind Exceldateien der Version 2003 und 2007. Der folgende Code gehört in "Modul1"


Option Explicit
Public Sub Test()
Dim objDocument As Object
Dim intHeight As Integer
Dim intWidth As Integer
Dim objWDApp As Object
Dim shpShape As Shape
Dim intTMP As Integer
Application.ScreenUpdating = False
On Error Resume Next
Set objWDApp = GetObject(, "Word.Application")
If objWDApp Is Nothing Then Set objWDApp = _
CreateObject("Word.Application")
On Error GoTo 0
On Error GoTo Fin
Set objDocument = objWDApp.Documents.Add
objWDApp.Visible = True
For Each shpShape In ThisWorkbook.Worksheets(1).Shapes
If shpShape.Type = msoTextBox Then
With ThisWorkbook.Worksheets(1)
intWidth = .Columns("A:A").ColumnWidth
intHeight = .Rows("1:1").RowHeight
.Columns("A:A").ColumnWidth = 150
.Rows("1:1").RowHeight = 35
End With
ThisWorkbook.Worksheets(1).Range("A1").Value = _
shpShape.TextFrame.Characters.Text
For intTMP = 1 To Len(shpShape.TextFrame.Characters.Text)
With ThisWorkbook.Worksheets(1). _
Range("A1").Characters(intTMP).Font
.Size = shpShape.TextFrame. _
Characters(intTMP, 1).Font.Size
.ColorIndex = shpShape.TextFrame. _
Characters(intTMP, 1).Font.ColorIndex
.Bold = shpShape.TextFrame. _
Characters(intTMP, 1).Font.Bold
.Underline = shpShape.TextFrame. _
Characters(intTMP, 1).Font.Underline
End With
Next intTMP
With ThisWorkbook.Worksheets(1)
.Range("A1").Copy
objDocument.Windows(1).Selection.Paste
objDocument.Tables(1).AutoFitBehavior (1)
Application.CutCopyMode = False
.Range("A1").Clear
.Columns("A:A").ColumnWidth = intWidth
.Rows("1:1").RowHeight = intHeight
End With
End If
Next shpShape
Fin:
Application.ScreenUpdating = True
Set objWDApp = Nothing
End Sub


Sample 2003

Sample 2007

Kommentare

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...