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
| Sub RepositionnementImages()
Dim Donnees As DAO.Database
Dim Creation As Object
Dim Enregistrement As String
Dim Chemin As String
Dim Appli As Object
Dim TexteRequete As String
Dim Requete As Recordset
Dim ImageInseree As Shape
Dim CompA As Integer
Dim Adresse As String
Dim Image As String
Set Appli = CreateObject("Scripting.FileSystemObject")
Chemin = "C:\ImageRentabilite\"
Set Donnees = DAO.OpenDatabase(Chemin, False, False, "Text;Database=" & Chemin)
Set Creation = Appli.CreateTextFile(Chemin & "TempImageInseree.csv", True)
Creation.Write "Champs1;Champs2" & vbCrLf
For Each ImageInseree In ActiveSheet.Shapes
If InStr(ImageInseree.Name, "_") > 0 Then
Select Case Left(ImageInseree.Name, InStr(ImageInseree.Name, "_") - 1)
Case "moinsGN", "moinsGV", "moinsVN", "moinsVV", "plusGN", "plusGV", "plusVN", "plusVV"
Creation.Write ImageInseree.Name & ";" & Replace(ImageInseree.Name, Left(ImageInseree.Name, InStr(ImageInseree.Name, "_")), "") & vbCrLf
ImageInseree.Delete
End Select
End If
Next ImageInseree
DoEvents
Creation.Close
Set Creation = Nothing
TexteRequete = "SELECT Champs1, Champs2 FROM [TempImageInseree.csv] ORDER BY Champs2"
Set Requete = Donnees.OpenRecordset(TexteRequete, DAO.dbOpenSnapshot)
Do While Not (Requete.EOF)
For CompA = 3 To Sheets("EnGam").Range("A65536").End(xlUp).Row
If Sheets("EnGam").Range("AD" & CompA).Value = CLng(Requete.Fields(1).Value) Then
Adresse = Sheets("EnGam").Range("AA" & CompA).Value
Image = Sheets("EnGam").Range("Z" & CompA).Value & Sheets("EnGam").Range("Y" & CompA).Value
With ActiveSheet.Pictures.Insert(Chemin & Left(Requete.Fields(0).Value, InStr(Requete.Fields(0).Value, "_") - 1) & ".bmp")
.Name = Requete.Fields(0).Value
.PrintObject = False
.ShapeRange.PictureFormat.TransparencyColor = RGB(233, 231, 219)
If InStr(Requete.Fields(0).Value, "plus") > 0 Then
If Image <> "VV" Then .OnAction = "ProOuverture"
Else
If Image <> "VV" Then .OnAction = "ProFermeture"
End If
End With
ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Top = Range(Replace(Adresse, "$", "")).Top
ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Left = Range(Replace(Adresse, "$", "")).Left
End If
Next CompA
Requete.MoveNext
Loop
Requete.Close
Set Requete = Nothing
End Sub |
Partager