Discussion :

[Theophile69]

Bonjour à vous ,

j'ai une macro qui se déclenche lorsqu'on clique sur un rectangle pour y faire apparaître un icone, l'icone d'un fichier qui sera intégré ensuite au classeur une fois importé.
Toutefois je suis perdu face à la propriété iconFileName.
Vous verrez si vous essayez le fichier (en pj) que les .png par exemple apparaître très bien.
Toutefois les pdf et autres fichiers font apparaître une espère de rectangle noir à droite: l'affichage de l'icone étant totalement dysfonctionnel.

Voici ma question:
- Existe t'il un moyen (objectif simplifié) d'attribuer un même icone (tout bête blanc) à tous les types de fichier?
- Et dans l'idéal, un moyen de récupérer exactement le type d'icone en fonction du type d'application selon, si possible, un chemin qui restera durable quelle que soit la version de Windows employée. J'avoue craindre les modifications de chemin (notamment pour l'icone .pdf) et cible ainsi la première méthode qui me parait moins ambitieuse bien que plus durable.

Si quelqu'un trouve quelques pistes de solution je serai ravi.
Ce n'est pas à défaut d'avoir cherché, cependant j'avoue être à présent totalement embrouillé.

Merci d'avance,

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
86
87
88
89
90
91
92
93
Option Explicit
Sub AddFileToDropArea()
 
'On Error GoTo errorHandler
 
    Application.ScreenUpdating = False
 
'Variables
    Dim filePicker As FileDialog
    Dim strFilePath, strIconType As String
    Dim arrSplitedPath() As String
    Dim arrSplitedPath_Size, intHorzOffSet, intVertOffSet As Integer
    Dim strFileName As String
    Dim shapeCount, i As Integer
    Dim boolNewLine As Boolean
    Dim shp As Shape
    Dim icon As Object
 
'Counting number of Shapes
For Each shp In ActiveSheet.Shapes
    If InStr(shp.Name, "Object") <> 0 Then
        shapeCount = shapeCount + 1
    End If
Next shp
 
'Limiting file number
If shapeCount >= 8 Then
    MsgBox "Vous avez atteind le nombre maximum de huit fichiers pouvant être insérés. Veuillez en effacer puis réessayer."
    Exit Sub
End If
 
'Manage file to import
    If MsgBox("Veuilez choisir le document à stocker dans ce classeur.", vbInformation + vbOKCancel, "Recherche du fichier à déposer") = vbOK Then
        Set filePicker = Application.FileDialog(msoFileDialogOpen)
        With filePicker
            .AllowMultiSelect = False
            If .Show = True Then
                strFilePath = .SelectedItems(1)
                arrSplitedPath = Split(strFilePath, "\")
                arrSplitedPath_Size = UBound(arrSplitedPath)
                strFileName = Left(arrSplitedPath(arrSplitedPath_Size), 11)
                'Icon choice
                If InStr(strFileName, ".xls") <> 0 Then
                    strIconType = "C:\PROGRA~2\MICROS~1\Office14\XLICONS.EXE"
                ElseIf InStr(strFileName, ".doc") <> 0 Then
                    strIconType = "C:\PROGRA~2\MICROS~1\Office14\WINWORD.EXE"
                ElseIf InStr(strFileName, ".pdf") <> 0 Then
                    strIconType = "C:\Program Files\Adobe\Acrobat Reader DC\Reader\AcroRd32.exe"
                Else
                    strIconType = ""
                End If
            Else
                'Canceling selection
                Exit Sub
            End If
         End With
    Else
        'Canceling process
        Exit Sub
    End If
 
'Saving file and generating icon
    Set icon = ActiveSheet.OLEObjects.Add(Filename:= _
        strFilePath, _
        Link:=False, _
        DisplayAsIcon:=True, _
        IconFileName:=strIconType, _
        IconLabel:=strFilePath)
 
'Arranging icon positions
    For Each shp In ActiveSheet.Shapes
        If InStr(shp.Name, "Object") <> 0 Then
            With ActiveSheet
                .Shapes(shp.Name).Left = .Shapes("Img_DropArea").Left + 20 + intHorzOffSet
                .Shapes(shp.Name).Top = .Shapes("Img_DropArea").Top + 20 + intVertOffSet
                .Shapes(shp.Name).Line.Visible = msoFalse
            End With
            intHorzOffSet = intHorzOffSet + 75
            If i < 3 Then
                intVertOffSet = 0
                boolNewLine = False
            ElseIf i >= 3 And boolNewLine = False Then
                intVertOffSet = 50
                intHorzOffSet = 0
                boolNewLine = True
            End If
            i = i + 1
        End If
    Next shp
 
Application.ScreenUpdating = True
 
End Sub