Cette version copie la photo dans son format dans le diaporama. Le calcul de la taille du diaporama est basé sur un fichier Impress vide : une page vide auquel on ajoute les images.
Les serveurs de boîtes aux lettres limitent la taille des pièces jointes. Fixez donc la taille du diaporama à cette limite.
Utilisez de préférence les fichiers .jpg moins encombrants que les .bmp
Bonne utilisation
En pièce jointe un tableau pour donner une idée des variations de la taille des diaporamas
Code : Tout sélectionner
sub cree_diaporama
'____________sImpress_________à partir des images rassemblées dans un répertoire crée un diaporama
dim Rep_nom as string ' répertoire contenant les images
dim URL_Rep_nom as string ' le nom est traduit en URL: compatibilité Unix
dim nom_image as string ' image pour le diaporama
dim nom_fic_image as string ' nom complet: chemin + nom image
dim liste_images as string ' liste des images pour le diaporama
dim idiapo as integer ' index de la diapo
dim nom_diapo as string ' Dans Impress nom de la diapo: nom générique & index
dim nom_diapositive as string ' Dans Impress nom générique donné aux Diapos
dim taille_image as Long ' taille du fichier image
dim taille_diaporama as Long ' taille du diaporama
dim taille_max_diaporama as Long ' taille du diaporama
Rep_nom = InputBox("Répertoire contenant les images?","Répertoire - Saisie","C:\users\user\desktop\images\")
if Rep_nom = "" then stop 'Bouton annuler
'Rep_nom = "C:\users\user\desktop\images\" ' on peut avoir un répertoire dédié où mettre les images
nom_diapositive = InputBox("Nom à donner aux diapos?","Nom - Diapos","Diapositive_")
if nom_diapositive = "" then stop 'Bouton annuler
'nom_diapositive = "Diapositive_" ' on peut avoir un nom générique habituel
taille_max_diaporama = InputBox("Taille maximun que le diaporama ne doit pas dépasser?" & _
chr(13) & chr(13) & "taille exprimée en Mo ","Taille - maximun","20")
if taille_max_diaporama = 0 then stop 'Bouton annuler
'taille_max_diaporama = 20 ' on peut avoir une taille maximun habituelle
taille_max_diaporama = (taille_max_diaporama * 1048576) - 256 ' ( -256 pour être en dessous de la limite)
taille_diaporama = 5000 ' taille arbitraire d'un diaporama vide
If len(Rep_nom) = 0 then exit sub
URL_Rep_nom = convertToURL(Rep_nom)
nom_image = Dir(URL_Rep_nom,0)
while len(nom_image) > 4
if c_est_une_image(nom_image) then
idiapo = idiapo + 1
nom_diapo = ajoute_diapo(nom_diapositive & str(idiapo))
nom_fic_image = URL_Rep_nom & nom_image
diapo_insere_image(nom_diapo,nom_fic_image)
taille_image = FileLen(nom_fic_image)
liste_images = liste_images & nom_image & " " & str(int(taille_image/1024.)) & "Ko" & chr(13)
taille_diaporama = taille_diaporama + taille_image
If taille_diaporama > taille_max_diaporama then goto c_est_fini
endif
nom_image = Dir
wend
c_est_fini:
if taille_diaporama > 1048576 then
liste_images = "DIAPORAMA de" & Format(((9000+taille_diaporama)/1048576.), "### ##0.00") & " Mo" & chr(13) & _
"IMAGES INSEREES:" & chr(13) & liste_images
else
liste_images = "DIAPORAMA de" & str(int(((9000+taille_diaporama)/1024.)) & " Ko" & chr(13) & _
"IMAGES INSEREES:" & chr(13) & liste_images
endif
msgBox(liste_images)
end sub
Function c_est_une_image(nom_image as String) As Boolean
'___________________version de Sebastien C
Dim nomFichier(12) As String, extension As String
nomFichier = Split(nom_image, ".")
extension = nomFichier(uBound(nomFichier))
select case ucase(extension)
Case "JPG", "BMP", "GIF", "PNG", "TIF", "TIFF"
c_est_une_image = True
Case Else
c_est_une_image = False
End Select
End Function
function ajoute_diapo(nom_diapo as string) as string
'____________sImpress_________ ajoute une diapo
Dim monDocument As Object, mesPages As Object, maPage As Object
Dim une_Page As Object
dim i as integer
ajoute_diapo = ""
monDocument = ThisComponent
mesPages= monDocument.DrawPages
i= monDocument.DrawPages.count +1
maPage = mesPages.insertNewByIndex(i)
cherche:
on error goto pas_trouvee
une_Page = monDocument.DrawPages.getByName(nom_diapo)
'__Diapo trouvée
nom_diapo = nom_diapo & "_2" ' nom bis
goto cherche
pas_trouvee:
on error goto 0
maPage.setName(nom_diapo)
ajoute_diapo = nom_diapo
end function
Sub diapo_insere_image(nom_diapo as string,nom_fic_image as string)
'____________sImpress_________met une image dans une diapo
Dim oDocument As Object, oLaPage As Object,oImage As Object
Dim oImageInfo As Object, oTaille As Object
Dim Graphique As Object
Dim sImageURL As String
Dim proprietes(0) As New com.sun.star.beans.PropertyValue
Dim positionImage As New com.sun.star.awt.Point
Dim Proportion As Double, zoom As Double
Dim PageA4_hauteur As Double, PageA4_largeur As Double, PageA4_propor As Double
Graphique = createUnoservice("com.sun.star.graphic.GraphicProvider")
PageA4_hauteur = 20800 : PageA4_largeur = 29500 ' 1/100 mm (210-2)x(297-2)
PageA4_propor = PageA4_largeur / PageA4_hauteur
oDocument = ThisComponent
oLaPage = oDocument.DrawPages.getByName(nom_diapo)
oImage = oDocument.createInstance("com.sun.star.drawing.GraphicObjectShape")
oImage.GraphicURL = ConvertToURL(nom_fic_image)
oLaPage.add(oImage) ' ajout d'une image
sImageURL = oImage.GraphicURL
if InStr(1, sImageURL, "vnd.sun.star.GraphicObject:", 0) = 0 then
proprietes(0).Name = "URL"
proprietes(0).Value = sImageURL
oImage.GraphicURL = "" ' necessary for Draw and Impress !
oImage.Graphic = Graphique.queryGraphic( proprietes() )
end if
oImageInfo = oImage.Graphic
oTaille = oImageInfo.SizePixel
Proportion = oTaille.Width / oTaille.Height
if Proportion < PageA4_propor then ' hauteur importante
zoom = PageA4_hauteur / oTaille.Height
oTaille.Height = oTaille.Height * zoom
oTaille.Width = oTaille.Width * zoom
positionImage.x = (PageA4_largeur - oTaille.Width)/2#
positionImage.y = 0 ' 5300 ' 53 mm en dessous du coin de la page
else ' largeur importante
zoom = PageA4_largeur / oTaille.Width
oTaille.Height = oTaille.Height * zoom
oTaille.Width = oTaille.Width * zoom
positionImage.x = 0 ' 6500 ' 65 mm en dessous du coin de la page
positionImage.y = (PageA4_hauteur - oTaille.Height)/2#
endif
oImage.Size = oTaille
oImage.Position = positionImage
End Sub