[VBA] Importer une image d'un fichier excel vers un autre
Bonjour,
Je sais comment importer une image depuis un répertoire, mais comme mon image actuelle est plutôt un groupe d'éléments contenant une image et 3 champs texte, j'aimerais l'importer depuis un autre fichier.
En fonction d'un type de pompes, j'importe déjà des caractéristiques de celle ci. J'aimerais en plus importer l image. Je pense donc rajouter les lignes manquantes dans ma fonction Importer', puisque l'image se trouvera dans le même fichier.
Code:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
|
Public Function FichierExiste(S As String) As Boolean
Dim obj As Object
Set obj = CreateObject("Scripting.FileSystemObject")
FichierExiste = obj.FileExists(S)
End Function
Function DossierExiste(NomDossier As String) As Boolean
DossierExiste = Dir(NomDossier, vbDirectory) <> ""
End Function
Private Function Test() As String
Dim Chemin As String
If DossierExiste("C:\Pompes_BDD") = True Then
Chemin = "C:\Pompes_BDD"
Else
Dim objShell As Object, objFolder As Object, oFolderItem As Object
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, " C:\Pompes_BDD n'existe pas, veuillez choisir un autre répertoire", &H1&)
On Error Resume Next
Set oFolderItem = objFolder.Items.Item
Chemin = oFolderItem.Path
End If
Test = Chemin
End Function
Private Function Importer(TypePompe As String) As Boolean
Dim Wb As Workbook
Dim Ws As Worksheet
Dim Nom As String
Application.ScreenUpdating = False
Nom = Test & "\" & TypePompe & ".xlsx"
If FichierExiste(Nom) = True Then
Set Wb = Workbooks.Open(Nom, , True)
Set Ws = Wb.Worksheets(1)
Ws.Range("A3:D8").Copy ThisWorkbook.Worksheets(1).Range("A31")
Wb.Close
Application.ScreenUpdating = True
Set Ws = Nothing
Set Wb = Nothing
Importer = True
Else
MsgBox ("Erreur : le type de pompe ne correspond à aucun fichier.")
Importer = False
End If
End Function
Private Sub Sauvegarder()
Dim Nom As String
Nom = Range("C1").Value & " " & Range("G1").Value & " " & Range("H1").Value & " HP " & Range("D6").Value
ActiveWorkbook.SaveAs ActiveWorkbook.Path & "\" & Nom
rep = MsgBox("Votre fichier a bien été sauvegardé sous le nom : " & Nom, vbYes + vbInformation, "Copie sauvegarde classeur")
End Sub
Private Sub Ok_Click()
If StationText.Value = "" Or SDMText.Value = "" _
Or TypeText.Value = "" Or NText.Value = "" _
Or NJCText.Value = "" Or PuiText.Value = "" _
Or IntText.Value = "" Or ViText.Value = "" _
Or NiveauText.Value = "" Then
MsgBox "Erreur : Veuillez remplier tous les champs."
ElseIf IsNumeric(PuiText.Value) = False _
Or IsNumeric(IntText.Value) = False _
Or IsNumeric(ViText.Value) = False _
Or IsNumeric(NiveauText.Value) = False Then
MsgBox "Erreur : les champs Puissance moteur, Intensité moteur et Vitesse de référence doivent être numérique."
Else
Range("C1").Value = StationText.Value
Range("H1").Value = SDMText.Value
Range("A6").Value = TypeText.Value
Range("B6").Value = NText.Value
Range("D6").Value = NJCText.Value
Range("F6").Value = PuiText.Value
Range("H6").Value = IntText.Value
Range("J6").Value = ViText.Value
Range("K29").Value = NiveauText.Value
If Importer(TypeText.Value) = True Then
'Sauvegarder
Unload Me
End If
End If
End Sub |
Merci d'avance à ceux qui pourront m'aider.
