Formulaire avec macro
Mario1963
Messages postés
2
Statut
Membre
-
Le Pingou Messages postés 12646 Date d'inscription Statut Contributeur Dernière intervention -
Le Pingou Messages postés 12646 Date d'inscription Statut Contributeur Dernière intervention -
J'ai créer un formulaire qui contient une macro pour afficher une photo lorsque j'appui sur le bouton commande. Cependant lorsque la photo s'insère dans le formulaire à l'endroit où les cellules sont fusionné en block, la première ligne du block s'aggrandi de la grandeur de la photo (si je choisi d'afficher la photo grandeur 150, la ligne prend la même grandeur que la photo)... j'aimerais bien que la photo s'insère dans le block fusionné sans rien changer à la ligne !!
j'espère avoir été clair dans mes explications ;-)
je vous joint la macro, il y a peut-etre des lignes dont je pourrais me passer si ça peut simplifier la chose :
Sub AffImage()
' Sélectionner les cellules contenant un lien vers une image et appeler la macro
' AffImage les affichera sur le lien ou dans la colonne de gauche ou de droite
Const hDefaut = 125 ' hauteur des images
'Const imgDefaut = "" ' saisir chemin complet et le nom de l'image par défaut à afficher si erreur
'Dim msg As String, r As Long, h As Long, lmax As Long
'Dim c As Range, numfich As Integer
'Dim fich
'msg = "Oui : Afficher les images à gauche des liens sélectionnés" & vbCrLf
'msg = msg & "Non : Afficher les images sur les liens sélectionnés" & vbCrLf
'msg = msg & "Annuler : Afficher les images à droite des liens sélectionnés"
'r = MsgBox(msg, vbYesNoCancel, "Cellules où mettre les images")
'If r = vbYes Then
'r = -1
'ElseIf r = vbNo Then
'r = 0
'Else
'r = 1
'End If
h = InputBox("Hauteur des lignes :", "Choix hauteur", hDefaut)
For Each c In Selection
'c.ColumnWidth = 10
fich = c.Value
' test fichier
If fich <> "" Then
If Left(fich, 7) = "http://" Then
' on conserve le lien sur le net
Else
numfich = FreeFile()
On Error GoTo errfich
Open fich For Input As #numfich
Close #numfich
On Error GoTo 0
End If
End If
'
If fich <> "" Then
c.RowHeight = h 'fixer la hauteur de ligne
ActiveSheet.Pictures.Insert(fich).Select 'ouverture image
With Selection.ShapeRange
.LockAspectRatio = msoTrue 'conserver les proportions
.Height = h - 4 'hauteur de l'image = hauteur des lignes - 4
.Left = c.Offset(0, r).Left + 2 'à gauche colonne A (sinon tu calcules avec la largeur de colonne)
.Top = c.Top + 2 'et positionner verticalement
End With
End If
Next c
Exit Sub
errfich:
fich = imgDefaut
Resume Next
End Sub
j'espère avoir été clair dans mes explications ;-)
je vous joint la macro, il y a peut-etre des lignes dont je pourrais me passer si ça peut simplifier la chose :
Sub AffImage()
' Sélectionner les cellules contenant un lien vers une image et appeler la macro
' AffImage les affichera sur le lien ou dans la colonne de gauche ou de droite
Const hDefaut = 125 ' hauteur des images
'Const imgDefaut = "" ' saisir chemin complet et le nom de l'image par défaut à afficher si erreur
'Dim msg As String, r As Long, h As Long, lmax As Long
'Dim c As Range, numfich As Integer
'Dim fich
'msg = "Oui : Afficher les images à gauche des liens sélectionnés" & vbCrLf
'msg = msg & "Non : Afficher les images sur les liens sélectionnés" & vbCrLf
'msg = msg & "Annuler : Afficher les images à droite des liens sélectionnés"
'r = MsgBox(msg, vbYesNoCancel, "Cellules où mettre les images")
'If r = vbYes Then
'r = -1
'ElseIf r = vbNo Then
'r = 0
'Else
'r = 1
'End If
h = InputBox("Hauteur des lignes :", "Choix hauteur", hDefaut)
For Each c In Selection
'c.ColumnWidth = 10
fich = c.Value
' test fichier
If fich <> "" Then
If Left(fich, 7) = "http://" Then
' on conserve le lien sur le net
Else
numfich = FreeFile()
On Error GoTo errfich
Open fich For Input As #numfich
Close #numfich
On Error GoTo 0
End If
End If
'
If fich <> "" Then
c.RowHeight = h 'fixer la hauteur de ligne
ActiveSheet.Pictures.Insert(fich).Select 'ouverture image
With Selection.ShapeRange
.LockAspectRatio = msoTrue 'conserver les proportions
.Height = h - 4 'hauteur de l'image = hauteur des lignes - 4
.Left = c.Offset(0, r).Left + 2 'à gauche colonne A (sinon tu calcules avec la largeur de colonne)
.Top = c.Top + 2 'et positionner verticalement
End With
End If
Next c
Exit Sub
errfich:
fich = imgDefaut
Resume Next
End Sub
A voir également:
- Formulaire avec macro
- Whatsapp formulaire opposition - Guide
- Telecharger macro convertir chiffre en lettre excel - Télécharger - Tableur
- Formulaire de réclamation facebook compte désactivé - Guide
- Formulaire de reclamation instagram - Guide
- Télécharger macro convertir chiffre en lettre excel - Télécharger - Tableur
3 réponses
Bonjour, les propriété de ton image font qu'elle est redimensionnée avec les cellules.
Peux-tu poster ton fichier (sans données perso) afin de pouvoir tester ton code en condition réelle
Peux-tu poster ton fichier (sans données perso) afin de pouvoir tester ton code en condition réelle
salut tyranausor,
merci pour ta réponse, d'après les infos dans mon post tu ne peux pas me dire quelle ligne je dois modifier pour régler mon problème ??
je ne peux vraiment pas poster mon fichier, je travaille dans un endroit où tout est strict et confidentielle...
merci pour ta réponse, d'après les infos dans mon post tu ne peux pas me dire quelle ligne je dois modifier pour régler mon problème ??
je ne peux vraiment pas poster mon fichier, je travaille dans un endroit où tout est strict et confidentielle...