Export avec objet OLE vers powerpoint et cellules déverouillées
S
Bonjour à tous,
Je me permets de me tourner vers vous car je suis un peu perdu. En effet, je ne suis pas développeur et mes connaissances en VBA sont très minimes. Malgré cela, une demande d'un supérieur hiérarchique m'est tombée dessus et je dois bidouiller un script VBA.... N'ayant pas les compétences nécessaires, je me suis orienté vers les IA, qui me font tourner en bourrique car elles ne me fournissent pas le rendu espéré. De base, le script doit exporter des zones définies de mon fichier excel en objet OLE dont certaines cellules doivent être modifiables "editableCells". Seulement le script ne vérrouille aucune cellule dans mon export Pwp. Pourriez-vous m'aider à trouver la solution car, personnellement, j'ai épuisé toutes mes cartouches... D'avance je vous remercie
Option Explicit
Sub ExportToPowerPoint()
Dim pptApp As Object
Dim pptPres As Object
Dim ws As Worksheet
Dim slideCount As Long
Dim cellB1Value As String
Dim sourceFile As String
Dim errorsList As String
Dim createdSlides As Long
Dim errorLocation As String
Dim editableCells As String
' Constantes pour late binding
Const ppLayoutBlank As Long = 12
Const msoFalse As Long = 0
Const msoTrue As Long = -1
' Définir les cellules qui doivent être modifiables
editableCells = "G4:I6,N4:O6,G48:I50,N48:O50,G74:I74,N74:O75,J75,G100:I101,N100:O101,I125:K128,I8,I14,I20,I54,I61,I67,I78,I89,I92,I130,I136,I142"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error GoTo ErrHandler
errorLocation = "Initialisation"
' === VÉRIFICATION: Existence de la feuille "Business Meetings" ===
On Error Resume Next
Set ws = ThisWorkbook.Sheets("Business Meetings")
If ws Is Nothing Then
MsgBox "Erreur : La feuille 'Business Meetings' n'existe pas dans ce classeur.", vbCritical, "Feuille manquante"
Exit Sub
End If
On Error GoTo ErrHandler
' Activer la feuille Excel pour assurer la visibilité
ws.Activate
sourceFile = ThisWorkbook.Name
errorLocation = "Préparation visuelle"
' === IMPORTANT: NE PAS PROTÉGER LA FEUILLE AVANT L'EXPORT ===
' Retirer toute protection existante pour permettre la modification dans PowerPoint
On Error Resume Next
ws.Unprotect
ws.Cells.Locked = False ' Déverrouiller toutes les cellules
On Error GoTo ErrHandler
' Mettre en surbrillance les cellules modifiables (optionnel - aide visuelle)
Call HighlightEditableCells(ws, editableCells)
errorLocation = "Lecture des valeurs"
' Lecture de la cellule C1 pour le titre
cellB1Value = ""
On Error Resume Next
cellB1Value = Trim(ws.Range("C1").Value)
On Error GoTo ErrHandler
If cellB1Value = "" Then cellB1Value = "Business Meeting"
errorLocation = "Création PowerPoint"
' === Création de l'application PowerPoint ===
On Error Resume Next
Set pptApp = CreateObject("PowerPoint.Application")
If pptApp Is Nothing Then
MsgBox "Erreur : Impossible de démarrer PowerPoint." & vbCrLf & _
"Vérifiez que PowerPoint est installé sur cet ordinateur.", vbCritical, "PowerPoint indisponible"
Call RemoveHighlight(ws, editableCells)
Exit Sub
End If
On Error GoTo ErrHandler
' Configuration PowerPoint
pptApp.Visible = True
pptApp.WindowState = 1 ' Maximiser
Set pptPres = pptApp.Presentations.Add(msoTrue)
' Activer PowerPoint pour assurer la visibilité
pptApp.Activate
DoEvents
slideCount = 0
errorsList = ""
createdSlides = 0
' === Export des zones SANS PROTECTION pour permettre la modification ===
errorLocation = "Export zone A2:P26"
Application.StatusBar = "Export en cours... Zone 1/5 (Objets modifiables)"
ws.Activate
createdSlides = createdSlides + CopyZoneToSlideSafe(ws, "A2:P26", pptPres, pptApp, slideCount, sourceFile, cellB1Value, errorsList, editableCells)
errorLocation = "Export zone A44:P71"
Application.StatusBar = "Export en cours... Zone 2/5 (Objets modifiables)"
ws.Activate
createdSlides = createdSlides + CopyZoneToSlideSafe(ws, "A44:P71", pptPres, pptApp, slideCount, sourceFile, cellB1Value, errorsList, editableCells)
errorLocation = "Export zone A72:P97"
Application.StatusBar = "Export en cours... Zone 3/5 (Objets modifiables)"
ws.Activate
createdSlides = createdSlides + CopyZoneToSlideSafe(ws, "A72:P97", pptPres, pptApp, slideCount, sourceFile, cellB1Value, errorsList, editableCells)
errorLocation = "Export zone A123:P147"
Application.StatusBar = "Export en cours... Zone 4/5 (Objets modifiables)"
ws.Activate
createdSlides = createdSlides + CopyZoneToSlideSafe(ws, "A123:P147", pptPres, pptApp, slideCount, sourceFile, cellB1Value, errorsList, editableCells)
errorLocation = "Export zone A152:P167"
Application.StatusBar = "Export en cours... Zone 5/5 (Objets modifiables)"
ws.Activate
createdSlides = createdSlides + CopyZoneToSlideSafe(ws, "A152:P167", pptPres, pptApp, slideCount, sourceFile, cellB1Value, errorsList, editableCells)
' === Retirer la surbrillance après l'export ===
Call RemoveHighlight(ws, editableCells)
' === Activer PowerPoint et positionner sur la première slide ===
If pptPres.Slides.Count > 0 Then
pptPres.Slides(1).Select
pptApp.Activate
End If
' Nettoyage
Application.CutCopyMode = False
Application.StatusBar = False
' Libération des objets (mais garder PowerPoint ouvert)
Set pptPres = Nothing
Set pptApp = Nothing
Set ws = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
' === Message de confirmation avec instructions détaillées ===
Dim msg As String
If createdSlides > 0 Then
msg = "Export terminé avec succès !" & vbCrLf & vbCrLf & _
"Slides créées : " & createdSlides & " sur 5" & vbCrLf & vbCrLf & _
"POUR MODIFIER LES OBJETS EXCEL :" & vbCrLf & _
"1. Double-cliquez sur l'objet Excel dans PowerPoint" & vbCrLf & _
"2. Les cellules suivantes sont modifiables :" & vbCrLf & _
" • Lignes 4-6 : Colonnes G-I et N-O" & vbCrLf & _
" • Lignes 48-50 : Colonnes G-I et N-O" & vbCrLf & _
" • Ligne 74-75 : Colonnes G-I, N-O et J75" & vbCrLf & _
" • Lignes 100-101 : Colonnes G-I et N-O" & vbCrLf & _
" • Lignes 125-128 : Colonnes I-K" & vbCrLf & _
" • Cellules individuelles : I8, I14, I20, I54, I61, I67, I78, I89, I92, I130, I136, I142" & vbCrLf & vbCrLf & _
"3. Cliquez en dehors de l'objet pour terminer l'édition" & vbCrLf & vbCrLf & _
"Utilisez 'Fichier > Enregistrer sous' pour sauvegarder."
If errorsList <> "" Then
msg = msg & vbCrLf & vbCrLf & "Avertissements :" & vbCrLf & errorsList
End If
MsgBox msg, vbInformation, "Export PowerPoint réussi"
Else
MsgBox "Aucune slide n'a pu être créée. Vérifiez les plages de données.", vbExclamation, "Export incomplet"
End If
Exit Sub
ErrHandler:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.CutCopyMode = False
Application.StatusBar = False
' Retirer la surbrillance en cas d'erreur
If Not ws Is Nothing Then Call RemoveHighlight(ws, editableCells)
' Nettoyer PowerPoint en cas d'erreur
If Not pptApp Is Nothing Then
On Error Resume Next
If Not pptPres Is Nothing Then pptPres.Close
pptApp.Quit
Set pptApp = Nothing
On Error GoTo 0
End If
MsgBox "Erreur lors de l'export PowerPoint" & vbCrLf & vbCrLf & _
"Étape : " & errorLocation & vbCrLf & _
"Description : " & Err.Description & vbCrLf & _
"Code erreur : " & Err.Number, vbCritical, "Export annulé"
End Sub
' === NOUVELLE FONCTION: Mettre en surbrillance les cellules modifiables ===
Private Sub HighlightEditableCells(ws As Worksheet, editableCells As String)
On Error Resume Next
' Sauvegarder les couleurs originales sera fait manuellement si nécessaire
With ws.Range(editableCells).Interior
.Color = RGB(255, 255, 200) ' Jaune clair
.Pattern = xlSolid
End With
On Error GoTo 0
End Sub
' === NOUVELLE FONCTION: Retirer la surbrillance ===
Private Sub RemoveHighlight(ws As Worksheet, editableCells As String)
On Error Resume Next
With ws.Range(editableCells).Interior
.Pattern = xlNone ' Retirer la couleur de fond
End With
On Error GoTo 0
End Sub
' === Wrapper sécurisé pour copie (avec indication des cellules modifiables) ===
Private Function CopyZoneToSlideSafe(ws As Worksheet, plage As String, pptPres As Object, pptApp As Object, _
ByRef slideCount As Long, sourceFile As String, cellB1Value As String, _
ByRef errorsList As String, editableCells As String) As Long
On Error GoTo SlideError
' Vérifier que la plage existe
Dim testRange As Range
On Error Resume Next
Set testRange = ws.Range(plage)
If testRange Is Nothing Then
errorsList = errorsList & "- Zone " & plage & " : Plage invalide" & vbCrLf
CopyZoneToSlideSafe = 0
Exit Function
End If
On Error GoTo SlideError
CopyZoneToSlideSafe = 0
Call CopyZoneToSlide(ws, plage, pptPres, pptApp, slideCount, sourceFile, cellB1Value, editableCells)
CopyZoneToSlideSafe = 1
Exit Function
SlideError:
errorsList = errorsList & "- Zone " & plage & " : " & Err.Description & vbCrLf
Err.Clear
CopyZoneToSlideSafe = 0
End Function
' === Copie OLE SANS PROTECTION pour permettre la modification ===
Private Sub CopyZoneToSlide(ws As Worksheet, plage As String, pptPres As Object, pptApp As Object, _
ByRef slideCount As Long, sourceFile As String, cellB1Value As String, editableCells As String)
Dim pptSlide As Object
Dim pptWindow As Object
Dim rng As Range
Dim slideW As Double, slideH As Double
Dim footer As Object, header As Object
Dim pastedShape As Object
Dim objW As Double, objH As Double
Dim scaleRatio As Double
Dim maxWidth As Double, maxHeight As Double
Dim centerX As Double, centerY As Double
Dim shapeCount As Long
Dim success As Boolean
' Constantes
Const ppLayoutBlank As Long = 12
Const ppPasteOLEObject As Long = 10
Const ppPasteDefault As Long = 0
Const HEADER_HEIGHT As Double = 40
Const FOOTER_HEIGHT As Double = 35
Const MARGIN As Double = 20
On Error GoTo LocalError
' Créer nouvelle slide
slideCount = slideCount + 1
Set pptSlide = pptPres.Slides.Add(slideCount, ppLayoutBlank)
' Sélectionner la slide pour assurer qu'elle est active
pptSlide.Select
Set pptWindow = pptApp.ActiveWindow
' Dimensions slide
slideW = pptPres.PageSetup.SlideWidth
slideH = pptPres.PageSetup.SlideHeight
' Calculer l'espace disponible
maxWidth = slideW - (2 * MARGIN)
maxHeight = slideH - HEADER_HEIGHT - FOOTER_HEIGHT - (2 * MARGIN)
' === COPIE DE LA PLAGE SANS PROTECTION ===
Set rng = ws.Range(plage)
' S'assurer que la feuille n'est pas protégée avant la copie
On Error Resume Next
ws.Unprotect
On Error GoTo LocalError
' S'assurer que Excel est actif et la plage est sélectionnée
Application.Visible = True
ws.Activate
rng.Select
DoEvents
' Copier la sélection (sans protection, toutes les cellules seront modifiables)
Selection.Copy
DoEvents
' Pause pour assurer que la copie est dans le presse-papiers
Application.Wait Now + TimeValue("00:00:01")
' Activer PowerPoint et la slide
pptApp.Activate
pptSlide.Select
DoEvents
' Compter les shapes avant le collage
shapeCount = pptSlide.Shapes.Count
' === COLLAGE AVEC PLUSIEURS TENTATIVES ===
success = False
' Tentative 1: PasteSpecial OLE (préféré pour la modification)
On Error Resume Next
pptWindow.View.PasteSpecial DataType:=ppPasteOLEObject, Link:=False
DoEvents
Application.Wait Now + TimeValue("00:00:01")
If pptSlide.Shapes.Count > shapeCount Then success = True
On Error GoTo LocalError
' Tentative 2: Si échec, essayer Paste normal
If Not success Then
On Error Resume Next
pptWindow.View.Paste
DoEvents
Application.Wait Now + TimeValue("00:00:01")
If pptSlide.Shapes.Count > shapeCount Then success = True
On Error GoTo LocalError
End If
' Tentative 3: Si toujours échec, utiliser CommandBars
If Not success Then
On Error Resume Next
pptApp.CommandBars.ExecuteMso "PasteSourceFormatting"
DoEvents
Application.Wait Now + TimeValue("00:00:01")
If pptSlide.Shapes.Count > shapeCount Then success = True
On Error GoTo LocalError
End If
' Si un objet a été collé avec succès
If success And pptSlide.Shapes.Count > shapeCount Then
Set pastedShape = pptSlide.Shapes(pptSlide.Shapes.Count)
' === Redimensionnement et centrage optimal ===
On Error Resume Next
With pastedShape
' Obtenir les dimensions actuelles
objW = .Width
objH = .Height
If objW > 0 And objH > 0 Then
' Calculer le ratio optimal
Dim scaleW As Double, scaleH As Double
scaleW = maxWidth / objW
scaleH = maxHeight / objH
' Utiliser le plus petit ratio pour garder les proportions
If scaleW < scaleH Then
scaleRatio = scaleW
Else
scaleRatio = scaleH
End If
' Limiter l'agrandissement pour éviter la déformation
If scaleRatio > 2 Then scaleRatio = 2
' Appliquer le redimensionnement
.LockAspectRatio = True
.Width = objW * scaleRatio
.Height = objH * scaleRatio
' Centrer l'objet dans l'espace disponible
centerX = (slideW - .Width) / 2
centerY = HEADER_HEIGHT + ((maxHeight - .Height) / 2)
.Left = centerX
.Top = centerY
End If
End With
On Error GoTo LocalError
End If
' === Ajouter Header ===
On Error Resume Next
Set header = pptSlide.Shapes.AddTextbox(1, MARGIN, 10, slideW - (2 * MARGIN), 25)
With header.TextFrame
.MarginLeft = 0
.MarginRight = 0
.TextRange.Text = cellB1Value & " - Slide " & slideCount & " (Double-clic pour éditer)"
.TextRange.Font.Size = 16
.TextRange.Font.Bold = True
.TextRange.Font.Name = "Arial"
.TextRange.ParagraphFormat.Alignment = 2 ' Centre
End With
On Error GoTo LocalError
' === Ajouter Footer avec indication des cellules modifiables ===
On Error Resume Next
Set footer = pptSlide.Shapes.AddTextbox(1, MARGIN, slideH - FOOTER_HEIGHT, slideW - (2 * MARGIN), 25)
With footer.TextFrame
.MarginLeft = 0
.MarginRight = 0
If success Then
.TextRange.Text = "Zone : " & plage & " | " & Format(Now, "dd/mm/yyyy hh:mm") & _
" | Toutes les cellules sont modifiables après double-clic"
Else
.TextRange.Text = "Zone : " & plage & " | Échec du collage"
End If
.TextRange.Font.Size = 10
.TextRange.Font.Italic = True
.TextRange.Font.Name = "Arial"
.TextRange.Font.Color = RGB(100, 100, 100) ' Gris
.TextRange.ParagraphFormat.Alignment = 2 ' Centre
End With
On Error GoTo LocalError
' Retourner le focus à Excel
ws.Parent.Activate
' Nettoyage
Application.CutCopyMode = False
Set pastedShape = Nothing
Set footer = Nothing
Set header = Nothing
Set rng = Nothing
Set pptSlide = Nothing
Set pptWindow = Nothing
Exit Sub
LocalError:
' Gestion locale des erreurs
Application.CutCopyMode = False
Resume Next
End Sub