Réduction d'image auto
Bonjour a tous,
En pj mon projet auquel j'ai longuement travaillé, mais je bloque sur un point
A l'aide de gpt j'ai créer un code pour ajouter une image dans une basse de donnée :
Option Explicit
Public Sub AjouterImageFromUserForm(ByVal callingUserForm As Object)
Dim dialog As FileDialog
Dim selectedImagePath As String
Dim designation As String
Dim wsReglage As Worksheet
Dim folderPath As String
' Accède à la feuille "Réglages"
Set wsReglage = ThisWorkbook.Sheets("Réglages")
' Obtient le chemin d'accès au dossier contenant les images depuis la cellule J5
folderPath = wsReglage.Range("D3").value
' Obtient la désignation sélectionnée ou saisie dans le UserForm appelant
designation = UCase(callingUserForm.ComboBox2.value) ' Convertit en majuscules
' Vérifie si une désignation a été sélectionnée ou saisie manuellement dans la ComboBox2
If Len(Trim(designation)) = 0 Then
MsgBox "Veuillez sélectionner ou saisir une désignation dans la ComboBox2 avant d'ajouter une image.", vbExclamation
Exit Sub
End If
' Crée une nouvelle instance de la boîte de dialogue Ouvrir
Set dialog = Application.FileDialog(msoFileDialogOpen)
' Configure la boîte de dialogue pour n'afficher que les fichiers image
dialog.Filters.Clear
dialog.Filters.Add "Images", "*.jpg; *.jpeg; *.png;*.jfif;*.bmp", 1
' Affiche la boîte de dialogue Ouvrir et récupère le chemin d'accès du fichier sélectionné
If dialog.Show = -1 Then
selectedImagePath = dialog.SelectedItems(1)
' Enregistre l'image dans le dossier avec le nom de la désignation
If SaveImage(selectedImagePath, folderPath, designation) Then
' Mettre à jour l'élément Image1 sur le UserForm appelant
callingUserForm.Image1.Picture = LoadPicture(selectedImagePath)
MsgBox "L'image a été ajoutée avec succès.", vbInformation
Else
MsgBox "Une erreur s'est produite lors de l'ajout de l'image.", vbExclamation
End If
End If
End Sub
Private Function SaveImage(ByVal imagePath As String, ByVal folderPath As String, ByVal designation As String) As Boolean
On Error GoTo ErrorHandler
' Copie l'image dans le dossier avec le nom de la désignation
FileCopy imagePath, folderPath & "\" & designation & ".jpg"
' Indiquer que l'opération s'est terminée avec succès
SaveImage = True
Exit Function
ErrorHandler:
MsgBox "Une erreur s'est produite lors de l'ajout de l'image.", vbExclamation, "Erreur"
SaveImage = False
End Function
je n'arrive pas a ce qu'une grande image type photo soit redimensionnée correctement et enregistré comme tel dans le dossier de destination
Pour entrer dans le fichier clickez sur le bouton visiteur
Merci pour votre aide
Bonjour anarium,
J'ai effectué quelques recherches après avoir examiné ton code.
Mes recherches n'ont pas donné de résultat purement Vba Excel.
En revanche, j'ai trouvé et expérimenté, avec succès et quelques conditions, une solution, laquelle nécessite l'installation de "ImageMagick" (du Open-Source).
ImageMagick contient un module "convert.exe", lequel permet de redimensionner un fichier image ( .jpg entre autres) directement dans le dossier image.
Restrictions :
- Nécessite l'installation d'une application.
- Le chemin et le nom du fichier image ne doivent pas contenir d'espace.
Utilisation après que la nouvelle image est créée ...
Public Sub AjouterImageFromUserForm(ByVal callingUserForm As Object)
...
...
call RedimentionnerImage
end sub
Si cela peut convenir :
Sub RedimensionnerImage()
' Définir le chemin du fichier image
Dim cheminImage As String
cheminImage = "C:\Temp\anarium\accessoires-de-levage\PHOTO-OUTIL\MANILLE-LYRE.jpg"
' Définir la taille de la nouvelle image (largeur et hauteur en pixels)
Dim largeur As Long
Dim hauteur As Long
largeur = 600 ' Largeur souhaitée
hauteur = 500 ' Hauteur souhaitée
' Définir la commande convert
Dim commande As String
commande = "D:\ImageMagick-7.1.1-Q16-HDRI\convert.exe """ & cheminImage & """ -resize " & largeur & "x" & hauteur & "! " & cheminImage & "_redimensionnee.jpg"""
' Déclarer les variables nécessaires pour la sortie de la commande
Dim wsh As Object
Dim output As String
' Créer un objet WshShell pour exécuter la commande
Set wsh = CreateObject("WScript.Shell")
' Exécuter la commande convert et capturer la sortie
output = wsh.Exec(commande).StdOut.ReadAll
End Sub
Bizz
re,
je ne comprends pas le fonctionnement de cette macro, elle fait quoi exactement ? Sélectionner un image, filecopy et ... ???
Bonjour BsAlv, anarium,
Le code du formulaire "UsfCréation" de anarium : Créer de nouvelles fiches et leur ajouter une image (photo) dans l'encadré "Image1" du Userform.
L'image (photo) est redimensionnée temporairement dans l'encadré Image1 du userform avec la propriété "fmPictureSizeModeZoom".
Mais en enregistrant la copie de la photo sous son nouveau nom (celui de la nouvelle fiche créée), la taille de la photo reste à la taille d'origine.
anarium cherche à redimensionner cette nouvelle "photo" à la taille de l'encadré "Image1".
La seule méthode que j'ai trouvée est d'utiliser "convert.exe" de l'application ImageMagick.
Le code aura besoin d'être retravaillé pour le dynamiser. Mais avant, j'attends l'opinion de anarium, à savoir si cette méthode peut convenir.
Si quelqu'un a une solution pure Vba de Excel, nous sommes lecteurs.
Bizz
Bonjour,
Moi, je ne veux rien. 8- ))
anarium cherche à redimensionner un fichier image.
Une image de 800x600 en exemple, faire une copie de cette image dans le dossier photo sous le nom déterminé par l'article créé dans le formulaire. Tout ce bout-là fonctionne correctement.
Il faudrait redimensionner cette nouvelle image créée dans le dossier "Photos.
Si j'ai bien compris, il faudrait redimensionner la photo aux dimensions de l'encadré "Image1" du formulaire. Ce n'est pas là la difficulté.
Cordialement,
Bizz
Bonjour a tous et merci pour votre aide ....
Lorsque l'utilisateur ajoute une image généralement il prend une image qui est au standard appareil photo ou smartphone donc de grande taille.lorsqu'il clique sur le bouton ajouter images l'image s'affiche réduite correctement dans images 1 (la visionneuse de l userform) le code enregistre l'image tu as un dossier nommé base de données. J'ai besoin que l'image soit enregistrées dans son format réduit ou alors si elle est enregistré dans son format normal lorsque une image est appelée par la dénomination de la combo box dimanche s'affiche de la taille de images 1.
Merci "Bizarre" pour ton aide pour ce qui est de imagemagik ce n'est pas possible ce fichier fonctionne en entreprise sur serveur fermé sans droit d'administrateur donc compliqué pour ajouter des applications ou accéder simplement à Internet
Bonjour anarium, le forum,
l'encadré Image1 du userform avec la propriété "fmPictureSizeModeZoom".
fmPictureSizeModeZoom va afficher l'image correctement dans Image1.
Mais l'image sera toujours, dans le dossier, aux dimensions d'origine.
' Vérifie si l'image existe
If Dir(imagePath) <> "" Then
' Affiche l'image correspondante dans Image1
Image1.Picture = LoadPicture(imagePath)
Me.Image1.PictureSizeMode = fmPictureSizeModeZoom ' < ajout de Bizz
Else
' Si aucune image n'est trouvée, affiche l'image par défaut
Image1.Picture = LoadPicture(folderPath & "/PAS D IMAGE.jpg")
Me.Image1.PictureSizeMode = fmPictureSizeModeZoom ' < ajout de Bizz
End If
Bizz
bonjour le fil,
cette macro modifie les dimensions de l'image vers ce 800*600 en respectant le rapport entre hauteur et largeur
Sub Anarium()
'*****************************************************************************************
' l'idée est qu'on ne peut pas déformer l'image, donc rapport largeur/hauteur reste intacte (l'inverse est aussi possible)
' donc si ce rapport n'est pas le même, l'image sera un petit peu plus petit que le cadre pour une des 2 dimensions
'*****************************************************************************************
Dim Hauteur, Largeur, MyPath, NewName, MyFile
MyPath = ThisWorkbook.Path
NewName = "Nouveau.PNG"
Hauteur = 600
Largeur = 800
With Application.FileDialog(msoFileDialogOpen)
.Filters.Clear
.Filters.Add "Images", "*.jpg; *.jpeg; *.png;*.jfif;*.bmp", 1 ' Configure la boîte de dialogue pour n'afficher que les fichiers image
If .Show = -1 Then ' Affiche la boîte de dialogue Ouvrir et récupère le chemin d'accès du fichier sélectionné
MyFile = .SelectedItems(1)
With ActiveSheet.Shapes.AddChart2 'ajouter un graphique
.Left = 0 'positionner (pas si important)
.Top = 0
.Height = Hauteur 'ces dimensions sont important
.Width = Largeur
x1 = Array(.Height, .Width) 'mémoriser ces dimensions
Set pct = .Chart.Pictures.Insert(MyFile) 'insérer l'image
With .Chart.Shapes(1) 'cet image
x2 = Array(.Height, .Width) 'mémoriser ces dimensions
Delta = Application.Min(x1(0) / x2(0), x1(1) / x2(1)) 'le plus petit rapport des 2 demensions
.LockAspectRatio = msoTrue 'rapport hauteur et largeur de l'image doit rester intact
.ScaleWidth Delta, msoFalse, msoScaleFromTopLeft 'modifier l'hauteur et largeur autant que le rapport entre graphique et image
End With
.LockAspectRatio = msoTrue ' 'rapport hauteur et largeur du graphique doit rester intact
.ScaleWidth 1 / 1.335, msoFalse, msoScaleFromTopLeft 'je ne comprends rien des pixels, mais il a fallu réduire le graphique 1,335 fois
.Chart.Export Filename:=MyPath & "\" & NewName 'exporter le graphique vers ce fichier "PNG"
.Delete 'supprimer le graphique
End With
x = CreateObject("Shell.Application").Namespace(MyPath).ParseName(NewName).ExtendedProperty("Dimensions")
MsgBox "les dimensions sont " & Mid(x, 2, Len(x) - 2), vbInformation, UCase(MyPath & "\" & NewName)
Else
MsgBox "rien sélectionné"
End If
End With
End Sub