'*****************************************************************************************************
' ___ _ _______ __ _ ____ _ _ _______ ___ _ _ _ ___ _ _.
' // \\ /\\ // // \\ // // // // // // \\ // // // // \\ //| //
' //___// //__\ // //__// // // //__// // // // // // // // // // | //
' // // \\ // // \\ // // // \\ // // // // // // // // // | //
'// // // // // // // //___ // \\ // \\__// //__// //___ \\__// // |//
'****************************************************************************************************
'CREER UN PATWORK AVEC DES IMAGES SUR LE DISQUE DUR dans une feuille
'Version 1.0
'date version 27/11/2025
'patricktoulon
Option Explicit
Sub clearPatwork2()
Dim shap As Shape
'clear la page
For Each shap In ActiveSheet.Shapes
If shap.TopLeftCell.Column >= 3 Then If Not shap.Name Like "BoutonGo*" Then shap.Delete
Next
End Sub
Sub GoPatchwork2()
Dim a&, B&, C&, D&, E&, F&, G&
'---------------------------------------
clearPatwork2
'-----------------------------------------
a = [B6] 'hauteur de l'image donc hauteur des lignes
B = [B5].Value 'Nombre d'images par ligne
C = Int(Cells(2, 1).Top) 'Top de depart
D = [D1].Left 'left de depart
E = [B7] 'combler les trous avec des doublon(0 pour non/1 pour oui)
F = [B8] 'melanger les images
G = [B9] 'terminer les bandes avec des images tronquées
CreatePatchwork2 a, B, C, D, E, F, G
End Sub
Sub CreatePatchwork2( _
Optional hauteurmax& = 100, _
Optional NbPictureByRow& = 4, _
Optional Topdepart& = 0, _
Optional LeftStart = 0, _
Optional FillGapsDuplicates = 0, _
Optional UnOrderedPicture& = 0, _
Optional TerminalCropImage& = 0)
Application.ScreenUpdating = False
Dim p As Range, fichiers, topx&, count&, fin#, TrOu, LeftX&, tbl(), a&, q&, temp, W#, Timages(), x&
Dim DosSier, img
Dim dicoRight As Object, it, elem, dicoDoublons As Object
Set dicoRight = CreateObject("scripting.dictionary")
Set dicoDoublons = CreateObject("scripting.dictionary")
topx = Topdepart
LeftX = LeftStart
'dialog folder
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "CHOISISSEZ LE DOSSIER D IMAGES"
If .Show <> -1 Then Exit Sub
DosSier = .SelectedItems(1) & "\"
End With
'dir fichieret stakage des liens fichier dans une variable tableau
fichiers = Dir(DosSier & "\*.*")
If fichiers <> "" Then
Do While fichiers <> ""
Select Case Split(LCase(fichiers), ".")(1)
Case "jpg", "jpeg", "png", "gif", "bmp", "tiff", "webp"
a = a + 1: ReDim Preserve tbl(1 To a): tbl(a) = DosSier & fichiers
End Select
fichiers = Dir
Loop
'si demandé on melange les images
If UnOrderedPicture& = 1 Then
For a = 1 To UBound(tbl)
q = 1 + (Rnd * (UBound(tbl) - 1))
temp = tbl(q): tbl(q) = tbl(a): tbl(a) = temp
Next
End If
For a = 1 To UBound(tbl)
DoEvents
'insertion de limage
'Set img = ActiveSheet.Pictures.Insert(dossier & fichiers)
Set img = ActiveSheet.Shapes.AddPicture(tbl(a), False, True, 0, 35, -1, -1)
img.LockAspectRatio = True
img.Top = topx: img.Left = LeftX
img.Height = hauteurmax
img.Name = "pict" & a
x = x + 1: ReDim Preserve Timages(1 To x): Timages(x) = img.Name
count = count + 1
If count = NbPictureByRow Then
dicoRight(topx) = (LeftX + img.Width)
If LeftX > fin Then fin = LeftX + img.Width
topx = topx + hauteurmax: LeftX = LeftStart: count = 0
Else
LeftX = LeftX + img.Width
End If
Next
If LeftX > LeftStart Then dicoRight(topx) = LeftX
End If
it = dicoRight.Items
' MsgBox fin & vbCrLf & Join(it, vbCrLf)
fin = Application.Max(dicoRight.Items)
'a partir d'ici on va combler les trous avec des shapes texturées
For Each elem In dicoRight
Dim shap, i&, cacHe As Shape, PiCt
Randomize
TrOu = 0
TrOu = Val(fin) - Val(dicoRight(elem))
'If trou > 0 Then
Set shap = ActiveSheet.Shapes.AddShape(1, Val(dicoRight(elem)), elem, TrOu, hauteurmax)
shap.Name = "shap" & elem
'shap.Fill.PresetTextured Round(Rnd * 22) + 1
shap.line.Visible = msoFalse
'End If
Next elem
'combler les trous avec des doublons autant que possible
If FillGapsDuplicates = 1 Then
For Each shap In ActiveSheet.Shapes
If shap.Type = 1 And shap.Top >= 30 Then
LeftX = shap.Left
For Each PiCt In ActiveSheet.Pictures
If Not dicoDoublons.Exists(PiCt.Name) Then
W = PiCt.Width
If W <= shap.Width Then
PiCt.CopyPicture
ActiveSheet.Paste
Set img = ActiveSheet.Shapes(ActiveSheet.Shapes.count)
img.Name = PiCt.Name & "bis"
img.Top = shap.Top: img.Left = LeftX
img.PictureFormat.Brightness = (3 + (Rnd * 4)) / 10
LeftX = LeftX + img.Width
shap.Width = shap.Width - img.Width: shap.Left = LeftX
dicoDoublons(PiCt.Name) = ""
dicoDoublons(img.Name) = ""
'x = x + 1: ReDim Preserve Timages(1 To x): Timages(x) = img.Name
End If
End If
Next
End If
Next
End If
Dim CropRatio, imgg
'à partir d'ici il reste encores des shape trou même minime en terme de largeur
'nous alons les remplir avec des images
If TerminalCropImage = 1 Then
For Each shap In ActiveSheet.Shapes
If shap.Type = 1 And shap.Top >= 30 Then
re:
imgg = tbl(1 + Int(Rnd * (UBound(tbl) - 1)))
If dicoDoublons.Exists(imgg) Or dicoDoublons.Exists(imgg & "bis") Then GoTo re
dicoDoublons(imgg) = ""
Set img = ActiveSheet.Shapes.AddPicture(imgg, False, True, 0, 0, -1, -1)
CropRatio = img.Height / hauteurmax
img.LockAspectRatio = True
img.Height = hauteurmax
img.PictureFormat.CropRight = (img.Width - shap.Width) * CropRatio
img.Left = shap.Left
img.Top = shap.Top
'x = x + 1: ReDim Preserve Timages(1 To x): Timages(x) = img.Name
End If
DoEvents
Next
End If
Dim G
'on peut grouper timages pour n'en faire qu'une ici et l'exporter
End Sub
