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

re,

vous voulez quoi exactement ?

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