Insérer des fichiers pdf dans EXCEL par macro

[renren]

Bonjour,
J’aimerais pouvoir sous EXCEL effectuer par macro l’attachement d’un fichier PDF sur chaque ligne d’un classeur, sachant que le nom du fichier est défini par la valeur d’une cellule.
Exemple : si en cellule A1, j’ai la valeur « BOB », j’aimerais pouvoir insérer sous la forme d’une icône le fichier C://Mes Documents/BOB.pdf et le redimensionner(important car 120 lignes) pour qu’il tienne dans la cellule B1.
De même en A2, si la valeur est « SAM », que le fichier SAM.pdf soit attaché en cellule B2…
Et ainsi de suite pour 120 lignes.

Est ce possible ?
Merci de m’aider !!!

 

[PMO2]

Re : Insérer des fichiers pdf dans EXCEL par macro

Bonjour,

Une solution avec le code suivant, à copier dans un module standard, dans lequel
il vous faudra adapter, à votre usage, la constante
Const CHEMIN As String = "C:\"

'### Constante à adapter à votre usage ###
Const CHEMIN As String = "C:\"
'#########################################

Const TAG_ICONE As String = "___pmo_"

Sub InserePDF()
Dim PDFobject As Object
Dim S As Shape
Dim i&
Dim nbLig&
Dim A$
On Error GoTo Erreur
Application.ScreenUpdating = False
For Each S In ActiveSheet.Shapes
  If Left(S.Name, Len(TAG_ICONE)) = TAG_ICONE Then S.Cut
Next S
nbLig& = ActiveSheet.[a65536].End(xlUp).Row
For i& = 1 To nbLig&
  A$ = Trim(Range("a" & i& & ""))
  If A$ <> "" Then
    If LCase(Right(A$, 4)) <> ".pdf" Then A$ = A$ & ".pdf"
    On Error Resume Next
    Set PDFobject = GetObject(CHEMIN & A$)
    If Err = 0 Then
      Call OlePDF(Range("b" & i& & ""), CHEMIN & A$)
    Else
      Err.Clear
    End If
    On Error GoTo Erreur
  End If
Next i&
Erreur:
Application.ScreenUpdating = True
End Sub

Sub OlePDF(Cellule As Range, Fichier As String)
Dim R As Range
Dim OL As OLEObject
Dim A$
Set R = Cellule
R.Select
Set OL = ActiveSheet.OLEObjects.Add(Filename:=Fichier, Link:=False, _
        DisplayAsIcon:=True, IconFileName:= _
        "C:\WINDOWS\Installer\{AC76BA86-7AD7-1036-7B44-A81300000003}\PDFFile_8.ico", _
        IconIndex:=0, IconLabel:="C:\SAM.pdf")
With OL
  .Width = R.Width
  .Height = R.Height
  .Placement = xlMoveAndSize
  .PrintObject = True
  .Name = TAG_ICONE & OL.Name
  A$ = "'" & ActiveWorkbook.Name & "'!'SurClic" & Chr(34) & .Name & Chr(34) & "'"
  .OnAction = A$
End With
End Sub

Sub SurClic(Nom As String)
ActiveSheet.Shapes(Nom).Select
Selection.Verb Verb:=xlPrimary
Selection.TopLeftCell.Select
End Sub

Cordialement.

PMO
Patrick Morange