'### Constante du dossier et son chemin à adapter ###
Const MON_DOSSIER = "C:\Dossier vacances"
'####################################################
Sub PropertiesFile()
Dim ShellApp As Object 'Shell32.Shell
Dim Fichier As Object 'Shell32.FolderItem
Dim Dossier As Object 'Shell32.Folder
Dim mesDetails
Dim i&
Dim j&
Dim T()
Dim S As Worksheet
Dim R As Range
mesDetails = Array(0, 10, 16, 9)
Set ShellApp = CreateObject("Shell.Application")
Set Dossier = ShellApp.Namespace(MON_DOSSIER)
If Dossier Is Nothing Then
MsgBox "Le dossier ''" & MON_DOSSIER & "'' est introuvable."
Exit Sub
End If
ReDim T(1 To Dossier.Items.Count + 1, 1 To UBound(mesDetails) + 1)
For Each Fichier In Dossier.Items
i& = i& + 1
If i& = 1 Then
For j& = 0 To UBound(mesDetails)
T(i&, j& + 1) = Dossier.GetDetailsOf(Dossier.Items, mesDetails(j&))
Next j&
Else
For j& = 0 To UBound(mesDetails)
T(i&, j& + 1) = Dossier.GetDetailsOf(Fichier, mesDetails(j&))
Next j&
End If
Next Fichier
Set S = Sheets.Add
Set R = S.Range(S.Cells(1, 1), S.Cells(UBound(T, 1), UBound(T, 2)))
R = T
With S.Range(S.Cells(1, 1), S.Cells(1, UBound(T, 2)))
.Font.Bold = True
.HorizontalAlignment = xlCenter
.Interior.ColorIndex = 34
End With
S.Columns.AutoFit
Set ShellApp = Nothing
Call ChargePicture
Call CompressionImage
End Sub
Sub ChargePicture(Optional dummy As Byte)
Dim var
Dim bool As Boolean
Dim i&
Dim A$
Dim R As Range
Dim PICT As Picture
On Error GoTo Erreur
var = ActiveSheet.UsedRange
For i& = 2 To UBound(var, 1)
A$ = UCase(Mid(var(i&, 1), InStrRev(var(i&, 1), ".") + 1))
If A$ = "BMP" Or A$ = "JPG" Or A$ = "JPEG" Then
bool = True
Exit For
End If
Next i&
If Not bool Then Exit Sub
Application.ScreenUpdating = False
For Each PICT In ActiveSheet.Pictures
PICT.Delete
Next PICT
Rows("2:" & UBound(var, 1) & "").RowHeight = 39
Columns(3).ColumnWidth = 9.57
For i& = 2 To UBound(var, 1)
A$ = UCase(Mid(var(i&, 1), InStrRev(var(i&, 1), ".") + 1))
If A$ = "BMP" Or A$ = "JPG" Or A$ = "JPEG" Then
Set R = Range("e" & i& & "")
Set PICT = ActiveSheet.Pictures.Insert(MON_DOSSIER & "\" & var(i&, 1))
With PICT
.Top = R.Top
.Left = R.Left
.Width = R.Width
.Height = R.Height
.Placement = xlMoveAndSize
.OnAction = "sansAction" 'Sans action : Evite la sélection de l'image
End With
End If
Next i&
Application.ScreenUpdating = True
Exit Sub
Erreur:
Application.ScreenUpdating = True
End Sub
Sub sansAction(Optional dummy As Byte)
'''vide de traitement, mais nécessaire pour éviter la sélection de l'image
End Sub
Sub CompressionImage(Optional dummy As Byte)
Dim C As Object
Dim PICT As Picture
Dim bool As Boolean
For Each PICT In ActiveSheet.Pictures
bool = True
Exit For
Next PICT
If Not bool Then Exit Sub
Application.ScreenUpdating = False
For Each C In Application.CommandBars("Picture").Controls
If TypeOf C Is CommandBarButton Then
If C.ID = 6382 Then
Application.SendKeys _
"{DOWN}{TAB}{UP}{ENTER}{ENTER}", True
C.Execute
Exit For
End If
End If
Next C
Application.ScreenUpdating = True
End Sub