Excel VBA-Fußzeile Bild

Question

Gibt es eine Möglichkeit, Excel-VBA-Code zu verwenden, um ein Bildobjekt in einem Blatt zu erstellen, um es als Fußzeilenbild einzufügen. Ich habe dies versucht, indem ich ein Diagrammobjekt erstellt und es in ein Bildformat eingefügt habe. Anschließend habe ich das Diagramm in eine Bilddatei exportiert und das Bild als Fußzeile festgelegt. Gibt es eine bessere Möglichkeit, ein Bildobjekt als Fußzeilenbild einzufügen, und wenn ja, wie mache ich das?

Answer 1

Ich startete den Makrorecorder. Ich klickte Page Setup dann Header/Footer dann Custom Footer. Ich klickte den Mittelteil und dann Format Picture (Knopf mit Bild der Sonne über Bergen). Ich suchte nach einem Bild und klickte Insert. "& [Bild]" erschien im mittleren Bereich. Ich habe zweimal auf OK geklickt. Ich habe den Makrorekorder ausgeschaltet.

Ich druckte die Seite und das ausgewählte Bild erschien am unteren Rand.

Der wichtige Code durch den Makro-Recorder gespeichert war:

ActiveSheet.PageSetup.CenterFooterPicture.Filename = _ 
    "C:\Users\Public\Pictures\Sample Pictures\Desert Landscape.jpg" 

Ersetzen "C:\Users\Public\Pictures\Sample Pictures\Desert Landscape.jpg" mit Dateinamen Ihrer Wahl.

Der Makrorekorder ist normalerweise der einfachste Weg, solche Aussagen zu entdecken.

Answer 2

Versuchen Sie folgendes:

Dim ws as Worksheet 
Set ws = Worksheets("YourWorksheetName") 

With ws.PageSetup 
    .CenterFooterPicture = "&G" 'Specifies that you want an image in your footer 
    .CenterFooterPicture.Filename = "C:\Pictures\MyFooterImage.jpg" 'specifies the image file you want to use 

End With 

Der Code von der Makroaufzeichnung erzeugt werden Sie Teil des Weges dorthin gelangen, aber wie es oft der Fall, es bietet nicht die ganze oder am besten geeignete Lösung. Es klingt auch wie Sie versuchen, ein Bild, das von Excel (wie einem Diagramm) erzeugt wird, in die Fußzeile einzufügen? Wenn das der Fall ist, glaube ich, dass Sie dasselbe Objekt wie ein Bild verwenden und dann auf diese Bilddatei verweisen müssen.

Answer 3

Für alle, die dies in Zukunft sehen, teile ich meinen Code, um einen Bereich zu kopieren und als Datei auf Ihrem Computer zu speichern, die dann zur Fußzeile hinzugefügt werden kann. Sie können Sie nicht wollen, =)

Dim objPic As Shape 
    Dim objChart As Chart 
    Dim strTimeStamp As String 
    Dim strFileDest As String 

20 Sheets(2).Activate 

30 Sheets(2).Columns("R:T").AutoFit 
40 Sheets(2).Rows("17:21").AutoFit 

50 ActiveWindow.DisplayGridlines = False 
60 Call Sheets(2).Range("S17", "U21").CopyPicture(xlScreen, xlPicture) 
70 ActiveWindow.DisplayGridlines = True 

80 Sheets(2).Shapes.AddChart 
90 Sheets(2).Activate 
100 Sheets(2).Shapes.Item(1).Select 

110 Set objChart = ActiveChart 
120 ActiveChart.Parent.Name = "FooterChart" 

    ' For some reason, Excel occasionally tries to make an actual chart out of these strings. 
    ' It's just a nonsensical chart that messes the footer up but I'm having trouble duplicating the issue and figuring out what causes it. 
    ' This should always work. Don't use .Clear, it crashes. 

130 ActiveChart.ChartArea.ClearContents 

140 objChart.Paste 
150 Selection.Name = "FooterImage" 
160 ActiveSheet.ChartObjects("FooterChart").Activate 

170 Sheets(2).Shapes.Item(1).Line.Visible = msoFalse 
180 Sheets(2).Shapes.Item(1).Height = Range("S17", "U21").Height 
190 Sheets(2).Shapes.Item(1).Width = Range("S17", "U21").Width 
200 ActiveChart.Shapes.Range(Array("FooterImage")).Height = Range("S17", "U21").Height 
210 ActiveChart.Shapes.Range(Array("FooterImage")).Width = Range("S17", "U21").Width 

220 Sheets(2).Shapes.Item(1).Height = Sheets(2).Shapes.Item(1).Height * 1.25 
230 Sheets(2).Shapes.Item(1).Width = Sheets(2).Shapes.Item(1).Width * 1.25 
240 ActiveChart.Shapes.Range(Array("FooterImage")).Height = ActiveChart.Shapes.Range(Array("FooterImage")).Height * 1.2 
250 ActiveChart.Shapes.Range(Array("FooterImage")).Width = ActiveChart.Shapes.Range(Array("FooterImage")).Width * 1.2 

260 strTimeStamp = CStr(Format(Now(), "yyyymmddHhNnSs")) 
270 strFileDest = "D:\Temp" & strTimeStamp & ".jpg" 

280 objChart.Export strFileDest 

290 InsertPicture strFileDest 

300 If Len(Dir$(strFileDest)) > 0 Then 
310  Kill strFileDest 
320 End If 

330 Sheets(2).Shapes.Item(1).Delete