1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
|
Private Sub ReplacePptShapeArea(pptShape As Object, tabVarArea As ListObject)
Dim rowVar As ListRow, tmpStr As String, rngSrc As Range, graphSrc As ChartObject, newShape As Object, tmpDbl As Double
On Error Resume Next
tmpStr = Replace(Replace(pptShape.TextFrame.TextRange.Text, "$Z{", vbNullString), "}", vbNullString)
Set rowVar = tabVarArea.ListRows(Application.WorksheetFunction.Match(tmpStr, tabVarArea.ListColumns("Variable Zone").DataBodyRange, 0))
Set rngSrc = ThisWorkbook.Sheets(rowVar.Range(1, 2).Text).Range(rowVar.Range(1, 3).Text)
Set graphSrc = ThisWorkbook.Sheets(rowVar.Range(1, 2).Text).ChartObjects(rowVar.Range(1, 3).Text)
On Error GoTo 0
If rowVar Is Nothing Then Exit Sub
If (rngSrc Is Nothing) And (graphSrc Is Nothing) Then Exit Sub
'copier la zone dans le ppt
If rngSrc Is Nothing Then
graphSrc.Copy
'si c'est un graphique, le coller au format Bitmap
' Set newShape = pptShape.Parent.Shapes.PasteSpecial(ppPasteBitmap)(1)
Set newShape = pptShape.Parent.Shapes.PasteSpecial(1)(1)
Else
rngSrc.Copy
On Error Resume Next
'si c'est un Range, essayer de le coller au format HTML, sinon coller une image "métafichier amélioré"
' Set newShape = pptShape.Parent.Shapes.PasteSpecial(ppPasteHTML, msoFalse, , , , msoFalse)(1)
' If newShape Is Nothing Then Set newShape = pptShape.Parent.Shapes.PasteSpecial(ppPasteEnhancedMetafile, msoFalse, , , , msoFalse)(1)
Set newShape = pptShape.Parent.Shapes.PasteSpecial(8, 0, , , , 0)(1)
If newShape Is Nothing Then Set newShape = pptShape.Parent.Shapes.PasteSpecial(2, 0, , , , 0)(1)
On Error GoTo 0
End If
Application.CutCopyMode = False |
