Private Sub UserForm_Initialize() GmeBox.value = ActiveCell.value End Sub Private Sub GmeBox_Click() 'Par Userform Images Application.ScreenUpdating = False Dim Gme As String 'Dim iGme As String ' As quoi ? Gme = GmeBox.value ActiveCell.value = Gme 'Reprise de l'image dans userform Images iGme = "Image" & Replace(GmeBox.value, ",", "_") If Gme = "C2" _ And VoirGamme.ModelVT.Caption = "S2000" _ Then iGme = "ImageC2_2" If Gme = "C2" _ And VoirGamme.ModelVT.Caption = "S3000" _ Then iGme = "ImageC2_3" GmeSlide.Picture = Images.Controls(iGme).Picture End Sub
Private Sub RepGmeBox_Click() 'Par répertoire de fichiers '.../... End Sub
Vous n’avez pas trouvé la réponse que vous recherchez ?
Posez votre questionActiveSheet.Shapes("Image 2").CopyPicture
Image1.Picture = LoadPicture(toto.Item("Image 2"))
Option Explicit Private Declare Function IsClipboardFormatAvailable Lib _ "user32" (ByVal wFormat As Integer) As Long Private Declare Function OpenClipboard Lib "user32" _ (ByVal hwnd As Long) As Long Private Declare Function GetClipboardData Lib "user32" _ (ByVal wFormat As Integer) As Long Private Declare Function CloseClipboard Lib "user32" () As Long Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _ (PicDesc As uPicDesc, RefIID As GUID _ , ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long Private Declare Function CopyImage Lib "user32" (ByVal handle As Long _ , ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long _ , ByVal un2 As Long) As Long Private Type GUID Data1 As Long Data2 As Integer Data3 As Integer Data4(0 To 7) As Byte End Type Private Type uPicDesc Size As Long Type As Long hPic As Long hPal As Long End Type Private Function PasteBmp() As IPicture Dim hCopy As Long If IsClipboardFormatAvailable(2) Then If OpenClipboard(0&) Then hCopy = CopyImage(GetClipboardData(2), 0, 0, 0, &H4) CloseClipboard If hCopy Then Set PasteBmp = CreateBmp(hCopy, 0, 2) End If End If End Function ' IPicture requires a reference to "OLE Automation" Private Function CreateBmp(ByVal hPic As Long, ByVal hPal As Long, ByVal lPicType) As IPicture Dim i As Long, PicInfo As uPicDesc, OlePicStore As GUID, IPic As IPicture With OlePicStore .Data1 &H7BF80980: .Data2 &HBF32: .Data3 = &H101A For i = 1 To 8 .Data4(i - 1) = Choose(i, &H8B, &HBB, &H0, &HAA, &H0, &H30, &HC, &HAB) Next i End With With PicInfo .Size = Len(PicInfo) .Type = 1 .hPic = hPic .hPal = hPal End With If OleCreatePictureIndirect(PicInfo, OlePicStore, True, IPic) Then MsgBox "Impossible de créer le bitmap !", 48 Set CreateBmp = IPic End Function Sub SaveBmp() ' inutilisé (Optional idx As Integer = 1) On Error GoTo Fin Dim oPic As IPictureDisp, BmpFile As String 'Inutilisé ThisWorkbook.Sheets("Débits").Shapes("Picture " & idx).CopyPicture xlScreen, xlBitmap ThisWorkbook.Sheets("Débits").Shapes("Image 683").CopyPicture xlScreen, xlBitmap BmpFile = ThisWorkbook.Path & "\Temp.bmp" Set oPic = PasteBmp: SavePicture oPic, BmpFile VoirGamme.GmeSlide.Picture = LoadPicture(BmpFile) Kill BmpFile: Set oPic = Nothing Exit Sub Fin: MsgBox "Image non trouvée !", 48 End Sub
Private Sub UserForm_Initialize() GmeSlide.Picture = LoadPicture("") SaveBmp End Sub '----------------------------------------- Private Sub GmeBox_Change() Application.ScreenUpdating = False Dim Gme Gme = GmeBox.value 'Remplace GmeSlide.Picture = LoadPicture("C:\InfiltroPass\Images" & Gme & ".jpg") SaveBmp ActiveCell.value = Gme End Sub
En revanche, il ne l'est plus avec WorkSheet_Change car Temp.bmp inexistant
Image1.Picture = ActiveSheet.Imagetoto.Picture
Je veux éviter de passer par un répertoire contenant les images afin que l'on n'ait à utiliser que UN SEUL Classeur.
tu l'insérerais dans un contrôle activex image "imagetoto",
If Not Intersect(Target, Sheets("Mesures").Range("H42:Q42")) Is Nothing _ Then VisuGme If Not Intersect(Target, Sheets("Mesures").Range("H72:Q72")) Is Nothing _ Then VisuGme If Not Intersect(Target, Sheets("Mesures").Range("H95:Q95")) Is Nothing _ Then VisuGme If Not Intersect(Target, Sheets("Mesures").Range("H113:Q113")) Is Nothing _ Then VisuGme If Not Intersect(Target, Sheets("Mesures").Range("H131:Q131")) Is Nothing _ Then VisuGme If Not Intersect(Target, Sheets("Mesures").Range("H149:Q149")) Is Nothing _ Then VisuGme If Not Intersect(Target, Sheets("Mesures").Range("H167:Q167")) Is Nothing _ Then VisuGme If Not Intersect(Target, Sheets("Mesures").Range("H185:Q185")) Is Nothing _ Then VisuGme If Not Intersect(Target, Sheets("Mesures").Range("H203:Q203")) Is Nothing _ Then VisuGme If Not Intersect(Target, Sheets("Mesures").Range("H221:Q221")) Is Nothing _ Then VisuGme If Not Intersect(Target, Sheets("Mesures").Range("H239:Q239")) Is Nothing _ Then VisuGme If Not Intersect(Target, Sheets("Mesures").Range("H257:Q257")) Is Nothing _ Then VisuGme If Not Intersect(Target, Sheets("Mesures").Range("H275:Q275")) Is Nothing _ Then VisuGme If Not Intersect(Target, Sheets("Mesures").Range("H293:Q293")) Is Nothing _ Then VisuGme If Not Intersect(Target, Sheets("Mesures").Range("H311:Q311")) Is Nothing _ Then VisuGme If Not Intersect(Target, Sheets("Mesures").Range("H329:Q329")) Is Nothing _ Then VisuGme
Sub VisuGme() Application.ScreenUpdating = False Dim Gme, Grw, GmeOK, GmeVent, ListeGamme Gme = ActiveCell.value Grw = ActiveCell.Row 'Reprise de l'image GmeOK = Dir("C:\InfiltroPass\Images" & Gme & ".jpg") 'Fichier JPG correspondant trouvé If GmeOK <> "" Then VoirGamme.GmeSlide.Picture = LoadPicture("C:\InfiltroPass\Images" & Gme & ".jpg") Else MsgBox "Gamme non reconnue!", vbCritical, "Visualiser Gamme" End If 'Reprise liste des Gammes disponible pour le Ventilateur choisi GmeVent = Sheets("Mesures").Range("G" & Grw).value ListeGamme = ThisWorkbook.Sheets("Data").Range(GmeVent).Address(external:=True) VoirGamme.GmeBox.RowSource = ListeGamme VoirGamme.Show End Sub
Private Sub UserForm_Initialize() GmeBox.value = ActiveCell.value End Sub Private Sub GmeBox_Change() Application.ScreenUpdating = False Dim Gme, GmeOK Gme = GmeBox.value GmeOK = Dir("C:\InfiltroPass\Images" & Gme & ".jpg") ActiveCell.value = Gme If GmeOK <> "" Then GmeSlide.Picture = LoadPicture("C:\InfiltroPass\Images" & Gme & ".jpg") End If End Sub
If Not Intersect(Target, Sheets("Mesures").Range("H42:Q42")) Is Nothing _t(Target, Sheets("Mesures").Range("H329:Q329")) Is Nothing _
Then VisuGme
If Not Intersect(Target, Sheets("Mesures").Range("H72:Q72")) Is Nothing _
Then VisuGme
If Not Intersect(Target, Sheets("Mesures").Range("H95:Q95")) Is Nothing _
Then VisuGme
If Not Intersect(Target, Sheets("Mesures").Range("H113:Q113")) Is Nothing _
Then VisuGme
If Not Intersect(Target, Sheets("Mesures").Range("H131:Q131")) Is Nothing _
Then VisuGme
If Not Intersect(Target, Sheets("Mesures").Range("H149:Q149")) Is Nothing _
Then VisuGme
If Not Intersect(Target, Sheets("Mesures").Range("H167:Q167")) Is Nothing _
Then VisuGme
If Not Intersect(Target, Sheets("Mesures").Range("H185:Q185")) Is Nothing _
Then VisuGme
If Not Intersect(Target, Sheets("Mesures").Range("H203:Q203")) Is Nothing _
Then VisuGme
If Not Intersect(Target, Sheets("Mesures").Range("H221:Q221")) Is Nothing _
Then VisuGme
If Not Intersect(Target, Sheets("Mesures").Range("H239:Q239")) Is Nothing _
Then VisuGme
If Not Intersect(Target, Sheets("Mesures").Range("H257:Q257")) Is Nothing _
Then VisuGme
If Not Intersect(Target, Sheets("Mesures").Range("H275:Q275")) Is Nothing _
Then VisuGme
If Not Intersect(Target, Sheets("Mesures").Range("H293:Q293")) Is Nothing _
Then VisuGme
If Not Intersect(Target, Sheets("Mesures").Range("H311:Q311")) Is Nothing _
Then VisuGme
If Not Intersec
dim truc as range with sheets("Mesures") set truc = union(.Range("H42:Q42"),.Range("H72:Q72"), .... etc ... ,.Range("H311:Q311"),.Range("H329:Q329")) end with If not intersect(target, truc) is nothing then visuGme
Dim Gme, Grw, GmeOK, GmeVent, ListeGamme