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 94 95 96
|
' xlsheet est déjà renseigné et correspond à une feuille de mon classeur cible
' LigneImportIMG est le numéro de la ligne où insérer mon (mes) image(s)
Sub ImporterPagesIC(strFichier As String)
'ouvre le classeur et la feuille de présentation
Dim Wbk As Workbook
Dim WbS As Worksheet
Dim onglet As String
Dim nbSel As Integer
On Error GoTo ERR
Set Wbk = Workbooks.Open(FileName:=strFichier, ReadOnly:=True)
If Not Existe(Wbk, "Pages présentation") Then
Do
onglet = InputBox("Veuillez indiquer le nom de l'onglet contenant les pages de présentation.", "Nom de l'onglet", "Nom de l'onglet")
Loop Until Existe(Wbk, onglet) = False
Set WbS = Wbk.Worksheets(onglet)
Else
Set WbS = Wbk.Worksheets("Pages présentation")
End If
'Recherche si elle contient des pages d'Identification de composants
Dim i As Integer, IMG As Integer
Dim HPB As HPageBreak
Dim ADR As Long, row As Long, RowIMG As Long
'Commence page 4 => on va chercher la ligne du 3eme saut de page
For i = 3 To WbS.HPageBreaks.Count
'Mémorise la ligne du saut de page
ADR = WbS.HPageBreaks(i).Location.row
For row = 4 To 7
RowIMG = row + ADR
'Le titre de la page se trouve dans une cellule fusionnée de A à O
If WbS.Range("A" & RowIMG).MergeArea.Address = "$A$" & RowIMG & ":$O$" & RowIMG Then
If WbS.Range("A" & row + ADR) = "IDENTIFICATION DES COMPOSANTS" Or WbS.Range("A" & row + ADR).value = "DESIGNATION OF COMPONENTS" Then
'On est bien sur une page d'identification des composants
'Il faut maintenant créer une page d'identification des composants et insérer l'image trouvée
CreerIdentificationComposants
PageComposants = PageComposants + 1
nbSel = 0
'On selectionne toutes les images contenues entre ADR+4 et wbs.hpagebreaks(I+1).location.row recherche l'image
For IMG = 1 To WbS.Shapes.Count
'récupère la ligne de la première cellule occupée par l'image
Debug.Print "Limite de la page : lignes " & ADR & " à " & WbS.HPageBreaks(i + 1).Location.row
RowIMG = Right(WbS.Shapes(IMG).TopLeftCell.Address, Len(WbS.Shapes(IMG).TopLeftCell.Address) - InStr(2, WbS.Shapes(IMG).TopLeftCell.Address, "$"))
Debug.Print "Image : " & RowIMG
If RowIMG > ADR And RowIMG < WbS.HPageBreaks(i + 1).Location.row Then
WbS.Shapes(IMG).Select False
Debug.Print WbS.Shapes(IMG).Name
nbSel = nbSel + 1
End If
Next IMG
' *********ERREUR A PARTIR DE LA*********
'On groupe la sélection si ce n'est pas un groupe afin de garder l'agencement des images
'
'If nbSel > 1 Then
' On Error Resume Next
Selection.Group.Select
' If ERR > 0 Then
' Debug.Print "Images séléctionnées : " & nbSel & " - Erreur lors du group"
' 'MsgBox "pb"
' End If
'End If
Selection.Copy
xlsheet.Range("A" & LigneImportIMG).Select
xlsheet.Paste
xlsheet.Range("A" & LigneImportIMG).PasteSpecial
'Selection.Ungroup
' *********** Comment ne plus sélectionner les images ? *************
'Selection.Clear
'Shape.Ungroup
Exit For
End If
End If
Next row
Next i
Wbk.Close False
Exit Sub
ERR:
Dim alog As New log
alog.Enregistrer "Classe ITP - ImporterPagesIC() - Erreur n°" & ERR.Number & " - " & ERR.Description
Debug.Print "Classe ITP - ImporterPagesIC() - Erreur n°" & ERR.Number & " - " & ERR.Description
MsgBox "Une erreur est survenue lors de l'importation : " & Chr(10) & ERR.Description & Chr(10), vbCritical, "Erreur lors de l'importation"
ERR.Clear
Wbk.Close False
End Sub |
Partager