![](/img/trans.png)
[英]How to copy a formatted cell in Excel to a table cell in Word using .NET?
[英]How to copy excel embedded image to word header in table in specific cell?
我正在从主过程调用过程以在单词中创建标题,该标题包含2行文本,然后是image,然后是1行文本。 我正在尝试使用具有1列和4行的表来做到这一点。 在第三行中,我要图片。 图片存储在Excel文件中的工作表中,该文件包含所有报告数据。 粘贴无效。 无法弄清楚如何在单元格中获取图像。
发现可以从文件中添加图片,但是我不想将图片保存在单独的文件中,因为如果移动excel文件,我也必须移动图片文件。
'Procedure, to create header
Sub MakeHeader()
Dim StrArr(1 To 2) As String
Dim RangeObj As Word.Range
'load text from excel table
StrArr(1) = ActiveSheet.Range("A26").Value
StrArr(2) = ActiveSheet.Range("A27").Value
'to create table
Set RangeObj = ActiveDocument.Sections(1).Headers(1).Range
RangeObj.Tables.Add Range:=RangeObj, NumRows:=4, NumColumns:=1
'populate table
'//
RangeObj.Tables(1).Cell(1, 1).Range.Text = StrArr(1)
RangeObj.Tables(1).Cell(2, 1).Range.Text = StrArr(2)
'copy picture that is embedded in excel sheet
'Shapes(4), because there are more then one object in sheet
ActiveSheet.Shapes(4).CopyPicture xlScreen, xlBitmap
RangeObj.Tables(1).Cell(3, 1).Application.Selection.Paste
'//
'center
ActiveDocument.Sections(1).Headers(1).Range.ParagraphFormat.Alignment = 1
End Sub
代码中的主要问题所在
RangeObj.Tables(1).Cell(3, 1).Application.Selection.Paste
图片将被粘贴到文档本身中,因为它被引用为Application对象选择(通常不在标题表中,而在主文档中)。 因此将线更改为
RangeObj.Tables(1).Cell(3, 1).Range.Paste
会将其粘贴到标题表中,如下所示
另外,也可以通过Word Application来引用而不是直接在excel VBA中引用ActiveDocument
(在某些运行实例中引起问题)。
完整的修改后的代码:
Sub MakeHeader()
Dim StrArr(1 To 2) As String
Dim RangeObj As Word.Range
'Next line Added for test
Dim wd As Word.Application
'load text from excel table
StrArr(1) = ActiveSheet.Range("A26").Value
StrArr(2) = ActiveSheet.Range("A27").Value
'to create table
'Next Three line Added for test
Set wd = CreateObject("Word.Application")
wd.Visible = True
wd.Documents.Add
'Wd i.e. referance to Word application added to ActiveDocument
Set RangeObj = wd.ActiveDocument.Sections(1).Headers(1).Range
RangeObj.Tables.Add Range:=RangeObj, NumRows:=4, NumColumns:=1
'populate table
'//
RangeObj.Tables(1).Cell(1, 1).Range.Text = StrArr(1)
RangeObj.Tables(1).Cell(2, 1).Range.Text = StrArr(2)
'copy picture that is embedded in excel sheet
'Shapes(4), because there are more then one object in sheet
'shapes(4) modified to Shapes(1) for test. Change to Your requirement
ActiveSheet.Shapes(1).CopyPicture xlScreen, xlBitmap
'This line was causing Problem as Range.Application was referring to Word application
' And picture is getting pasted in the document not in header Table
RangeObj.Tables(1).Cell(3, 1).Range.Paste
'//
'center
'Wd i.e. referance to Word application added to ActiveDocument
wd.ActiveDocument.Sections(1).Headers(1).Range.ParagraphFormat.Alignment = 1
End Sub
尝试:
Sub MakeWordHeader()
Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim wdRng As Word.Range, wdTbl As Word.Table
Dim xlSht As Excel.Worksheet: Set xlSht = ActiveSheet
With wdApp
.Visible = True
Set wdDoc = .Documents.Add
With wdDoc
Set wdRng = .Sections(1).Headers(1).Range
Set wdTbl = .Tables.Add(Range:=wdRng, NumRows:=4, NumColumns:=1)
With wdTbl
.Cell(1, 1).Range.Text = xlSht.Range("A26").Text
.Cell(2, 1).Range.Text = xlSht.Range("A27").Text
xlSht.Shapes(4).CopyPicture xlScreen, xlBitmap
.Cell(3, 1).Range.Paste
End With
wdRng.ParagraphFormat.Alignment = wdAlignParagraphCenter
End With
End With
End Sub
对于将来想要做类似事情但又没有Table的人
'Procedure, to create header
Sub MakeHeader(WApp As Object)
Dim StrArr(1 To 3) As String
Dim ImageObj As Excel.Shape
Dim Doc As Word.Document
Dim i As Long
Dim Count As Long
'load text from excel file
StrArr(1) = ActiveSheet.Range("A26").Value
StrArr(2) = ActiveSheet.Range("A27").Value
StrArr(3) = ActiveSheet.Range("A28").Value
'create object to hold picture
Set ImageObj = ActiveSheet.Shapes(4)
Set Doc = WApp.ActiveDocument
With Doc.Sections(1).Headers(1).Range
'centers text
.ParagraphFormat.Alignment = 1
'choosing font
.Font.Name = "Verdana"
.Font.Size = 9
'writes text
.InsertAfter StrArr(1)
.Paragraphs.Add
.InsertAfter StrArr(2)
.Paragraphs.Add
'creates space for image
For i = 1 To 8
.InsertAfter vbNullString
.Paragraphs.Add
Next
.InsertAfter StrArr(3)
'change font size for paragraphs 1 and 2
.Paragraphs(1).Range.Font.Size = 10
.Paragraphs(2).Range.Font.Size = 10
'copies image form excel file
With ImageObj
.Copy
End With
'collapses selection, 0 = wdCollapseEnd
.Collapse Direction:=0
'paste image, 3 = wdPasteMetafilePicture
.PasteSpecial DataType:=3
'centers image
.ShapeRange.Align msoAlignCenters, True
'lowers it from top of page
.ShapeRange.Top = 35
End With
'counts words in header
Count = Doc.Sections(1).Headers(1).Range.Words.Count
'underlines last two words, count considers ".", "@" and etc. as words
With Doc.Sections(1).Headers(1).Range
.Words(Count - 1).Font.Underline = 1
.Words(Count - 2).Font.Underline = 1
.Words(Count - 3).Font.Underline = 1
.Words(Count - 4).Font.Underline = 1
.Words(Count - 5).Font.Underline = 1
.Words(Count - 6).Font.Underline = 1
.Words(Count - 7).Font.Underline = 1
'don't need to underline comma ","
.Words(Count - 9).Font.Underline = 1
.Words(Count - 10).Font.Underline = 1
.Words(Count - 11).Font.Underline = 1
.Words(Count - 12).Font.Underline = 1
.Words(Count - 13).Font.Underline = 1
.Words(Count - 14).Font.Underline = 1
.Words(Count - 15).Font.Underline = 1
End With
End Sub
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.