Une macro développée sous LibreOffice pour exporter un diaporama Impress vers un document Writer. Les modèles d'impression des diapos accompagnés de leurs notes sous Impress ne me convenaient pas, notamment parce que si les notes étaient trop longues, elles étaient tronquées. Ce module règle le problème.
Quand la macro est lancée, un nouveau document Writer est créé.
Chaque diapositive d'un diaporama va provoquer la création d'un tableau occupant toute la largeur disponible et de 3 cellules de haut dans le document Writer :
Attention : Seul le texte des notes est repris, pas leur mise en forme (Gras, Italique, Souligné...).
A l'issue de chaque tableau, un saut de page est inséré pour accueillir la diapositive suivante.
Copiez le code des deux procédures ci-dessous dans un module que vous aurez créé au préalable dans Impress, je vous conseille dans la section "Mes macros et boîtes de dialogue".
Dans le code de la première procédure, il vous est possible de paramétrer facilement la police de caractères (par défaut Arial) et le nombre de pages finales du diaporama que vous ne souhaitez pas voir (par défaut 1) dans le document Writer notamment l'éternelle dernière diapositive "Vous avez des questions ?".
Sous licence GNU GPL, plus de détails concernant ces droits en suivant ce lien.
' Export des slides et commentaires LibreOffice Impress vers Writer.
' Source : www.keusch.org
' Version 6.7 du 24/02/2026
' *******************************************************
Sub ExportDiaposEtNotesVersWriter()
Dim Doc As Object
Dim WriterDoc As Object
Dim Slides As Object
Dim Slide As Object
Dim NotesPage As Object
Dim i As Integer
Dim intCutXLastPage as Integer
Dim strNomPolice as String
'*******************************************************
'Variables utilisateur à paramétrer
'
'strNomPolice -> Nom de la police de caractères qui doit être utilisée pour l'export
strNomPolice = "Arial"
'intCutXLastPage -> Nombre de pages à ne pas prendre en compte en fin de diaporama
intCutXLastPage = 1
'*******************************************************
Doc = ThisComponent
If Not Doc.SupportsService("com.sun.star.presentation.PresentationDocument") Then
MsgBox "Ce n'est pas un document Impress"
Exit Sub
End If
WriterDoc = StarDesktop.LoadComponentFromURL("private:factory/swriter", "_blank", 0, Array())
Slides = Doc.getDrawPages()
' Récupérer le nom du fichier Impress
Dim ImpressFileName As String
ImpressFileName = Doc.Title
' Ajouter un pied de page avec le nom du fichier
Dim FooterStyle As Object
FooterStyle = WriterDoc.StyleFamilies.getByName("PageStyles").getByName("Standard")
FooterStyle.FooterIsOn = True
Dim FooterText As Object
FooterText = FooterStyle.FooterText
Dim FooterCursor As Object
FooterCursor = FooterText.createTextCursor()
FooterCursor.setPropertyValue("CharHeight", 10)
FooterCursor.setPropertyValue("CharFontName", strNomPolice)
FooterText.insertString(FooterCursor, ImpressFileName, False)
' Préparer l'export d'images
Dim xExporter As Object
xExporter = CreateUnoService("com.sun.star.drawing.GraphicExportFilter")
Dim TempDir As String
TempDir = Environ("TEMP")
For i = 0 To Slides.getCount() - 1 - intCutXLastPage
Slide = Slides.getByIndex(i)
Dim Title As String
Title = "Diapositive " & (i + 1)
' Créer un tableau 1 colonne, 3 lignes
Dim Table As Object
Table = WriterDoc.createInstance("com.sun.star.text.TextTable")
Table.initialize(3, 1)
WriterDoc.Text.insertTextContent(WriterDoc.Text.End, Table, False)
' Ajuster la largeur du tableau
Table.setPropertyValue("Width", 100)
' Première cellule : titre centré, en gras, taille 12, police choisie par l'utilisateur
Dim TitleCursor As Object
TitleCursor = Table.getCellByPosition(0, 0).createTextCursor()
TitleCursor.setPropertyValue("CharWeight", com.sun.star.awt.FontWeight.BOLD)
TitleCursor.setPropertyValue("CharHeight", 12)
TitleCursor.setPropertyValue("CharFontName", strNomPolice)
TitleCursor.setPropertyValue("ParaAdjust", com.sun.star.style.ParagraphAdjust.CENTER)
Table.getCellByPosition(0, 0).String = Title
' Exporter la diapositive en image temporaire
Dim ImageURL As String
ImageURL = ConvertToUrl(TempDir & "/Slide" & (i + 1) & ".jpg")
' Supprimer le fichier existant s'il est déjà présent
If FileExists(ImageURL) Then
Kill ConvertFromUrl(ImageURL)
End If
' Créer les propriétés d'export à chaque itération pour éviter la persistance
ReDim ExportProps(1) As New com.sun.star.beans.PropertyValue
ExportProps(0).Name = "FilterName"
ExportProps(0).Value = "draw_jpg_Export"
ExportProps(1).Name = "URL"
ExportProps(1).Value = ImageURL
On Error GoTo ExportSlideError
xExporter.setSourceDocument(Slide)
xExporter.filter(ExportProps())
On Error GoTo 0
' Insérer l'image dans la deuxième cellule avec redimensionnement et centrage
Dim Graphic As Object
Graphic = WriterDoc.createInstance("com.sun.star.text.GraphicObject")
Graphic.GraphicURL = ImageURL
Graphic.AnchorType = com.sun.star.text.TextContentAnchorType.AS_CHARACTER
Graphic.Width = Table.getPropertyValue("Width") * 140
Graphic.Height = Graphic.Width * 9 / 16 ' Conserver le ratio 16:9
Table.getCellByPosition(0, 1).insertTextContent(Table.getCellByPosition(0, 1).End, Graphic, False)
' Centrer l'image dans la cellule
Dim ImageCursor As Object
ImageCursor = Table.getCellByPosition(0, 1).createTextCursor()
ImageCursor.setPropertyValue("ParaAdjust", com.sun.star.style.ParagraphAdjust.CENTER)
' Troisième cellule : notes alignées à gauche, taille 10, police Marianne
NotesPage = Slide.getNotesPage()
If Not IsNull(NotesPage) Then
Dim Obj As Object
For Each Obj In NotesPage
On Error Resume Next
Dim NotesText As String
NotesText = Obj.String
On Error GoTo 0
If Not IsError(NotesText) Then
If Trim(NotesText) <> "" Then
'**********************************
'Nettoyage de la chaîne NotesText
'Supprimer les retours chariot en tête
Do While Left(NotesText, 1) = Chr(10) Or Left(NotesText, 1) = Chr(13)
NotesText = Mid(NotesText, 2)
Loop
'Supprimer les retours chariot en queue
Do While Right(NotesText, 1) = Chr(10) Or Right(NotesText, 1) = Chr(13)
NotesText = Left(NotesText, Len(NotesText) - 1)
Loop
'ajout d'un retour chariot final pour aérer
NotesText = NotesText & Chr(13)
'**********************************
' Définir CellText : la cellule recevant le texte
Dim CellText As Object
CellText = Table.getCellByPosition(0, 2)
' Définir NoteCursor : le curseur qui va écrire le texte
Dim NotesCursor As Object
NotesCursor = CellText.Text.createTextCursor()
NotesCursor.setPropertyValue("CharHeight", 10)
NotesCursor.setPropertyValue("CharFontName",strNomPolice)
NotesCursor.setPropertyValue("ParaAdjust", com.sun.star.style.ParagraphAdjust.LEFT)
'**********************************************************
' "BLOCK : adjusted to both borders / stretched, except for last line selon la doc"
' mais ça ne fonctionne pas. Ca justifie aussi la dernière ligne...
'NotesCursor.setPropertyValue("ParaAdjust", com.sun.star.style.ParagraphAdjust.BLOCK)
'**********************************************************
' Insertion du texte dans la cellule
'CellText.insertString(NotesCursor, NotesText, False)
Call _InsertTextWithClickableLinks(CellText, NotesText, NotesCursor)
'vider la variable
NotesText = ""
End If
End If
Next Obj
End If
' Ajouter un saut de page APRÈS chaque tableau
Dim JumpCursor As Object
JumpCursor = WriterDoc.Text.createTextCursor()
JumpCursor.gotoEnd(False)
JumpCursor.setPropertyValue("BreakType", com.sun.star.style.BreakType.PAGE_AFTER)
WriterDoc.Text.insertControlCharacter(WriterDoc.Text.End, com.sun.star.text.ControlCharacter.PARAGRAPH_BREAK, False)
SkipToNextSlide:
GoTo AndFinally
ExportSlideError:
MsgBox "Erreur lors de l'export de la diapositive " & (i + 1)
AndFinally:
Next i
MsgBox "Export terminé"
End Sub
'*******************************************************************************************************************************************
' Insertion de texte avec reconnaissance des URL.
' Ne pas invoquer directement, ce module est appelé par ExportDiaposEtNotesVersWriter
Private Sub _InsertTextWithClickableLinks(CellText As Object, NotesText As String, NotesCursor As Object)
Dim StartPos As Integer
Dim UrlStart As Integer
Dim UrlEnd As Integer
Dim CurrentText As String
StartPos = 1
CurrentText = NotesText
Do While InStr(StartPos, CurrentText, "http://") > 0 Or InStr(StartPos, CurrentText, "https://") > 0 Or InStr(StartPos, CurrentText, "www.") > 0
' Trouver le début de l'URL
Dim HttpPos As Integer, HttpsPos As Integer, WwwPos As Integer
HttpPos = InStr(StartPos, CurrentText, "http://")
HttpsPos = InStr(StartPos, CurrentText, "https://")
WwwPos = InStr(StartPos, CurrentText, "www.")
' Déterminer quelle URL vient en premier
UrlStart = 0
If HttpPos > 0 Then UrlStart = HttpPos
If HttpsPos > 0 And (UrlStart = 0 Or HttpsPos < UrlStart) Then UrlStart = HttpsPos
If WwwPos > 0 And (UrlStart = 0 Or WwwPos < UrlStart) Then UrlStart = WwwPos
If UrlStart = 0 Then Exit Do
' Insérer le texte avant l'URL (texte normal)
If UrlStart > StartPos Then
CellText.insertString(NotesCursor, Mid(CurrentText, StartPos, UrlStart - StartPos), False)
NotesCursor.gotoEnd(False)
End If
' Trouver la fin de l'URL
UrlEnd = UrlStart
Do While UrlEnd <= Len(CurrentText)
Dim Char As String
Char = Mid(CurrentText, UrlEnd, 1)
If Char = " " Or Char = Chr(10) Or Char = Chr(13) Or Char = Chr(9) Then
Exit Do
End If
UrlEnd = UrlEnd + 1
Loop
' Extraire l'URL
Dim Url As String
Url = Mid(CurrentText, UrlStart, UrlEnd - UrlStart)
' Préparer l'URL complète
Dim FullUrl As String
If Left(Url, 5) <> "https" And Left(Url, 4) <> "http" Then
FullUrl = "https://" & Url
Else
FullUrl = Url
End If
' Insérer l'URL comme texte
Dim UrlStartPos As Object
UrlStartPos = NotesCursor.getStart()
CellText.insertString(NotesCursor, Url, False)
NotesCursor.gotoEnd(False)
' Sélectionner l'URL qu'on vient d'insérer
Dim UrlCursor As Object
UrlCursor = CellText.createTextCursorByRange(UrlStartPos)
UrlCursor.goRight(Len(Url), True) ' True = sélectionner
' Appliquer les propriétés d'hyperlien
UrlCursor.setPropertyValue("HyperLinkURL", FullUrl)
StartPos = UrlEnd
Loop
' Insérer le reste du texte
If StartPos <= Len(CurrentText) Then
CellText.insertString(NotesCursor, Mid(CurrentText, StartPos), False)
End If
End Sub
Image d'illustration générée à l'aide de l'IA Craiyon