Bonjour
Je souhaiterais rechercher dans toutes les pages d’un PDF les chaînes de caractères spécifiées, extrait le texte entre celles-ci et copie le contenu dans un classeur Excel avec un collage spécial en feuille de calcul XML.
J'ai Adobe Acrobat Pro
ci dessous ma macro que j'utilise
Sub ExtractTextBetweenStringsToXML()
Dim AcroApp As Object
Dim AcroDoc As Object
Dim jsObj As Object
Dim pdfPath As String
Dim textContent As String
Dim startIndex As Long, endIndex As Long
Dim extractedText As String
Dim ws As Worksheet
Dim currentPage As Integer, totalPages As Integer
Dim outputRow As Integer
' Initialiser la feuille cible
Set ws = ThisWorkbook.Sheets(1) ' Modifiez si nécessaire
outputRow = 1 ' Ligne où commencer à écrire dans Excel
' Sélectionner un fichier PDF
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Sélectionnez un fichier PDF"
.Filters.Clear
.Filters.Add "Fichiers PDF", "*.pdf"
If .Show = -1 Then
pdfPath = .SelectedItems(1)
Else
MsgBox "Aucun fichier sélectionné.", vbExclamation
Exit Sub
End If
End With
' Ouvrir Adobe Acrobat
Set AcroApp = CreateObject("AcroExch.App")
Set AcroDoc = CreateObject("AcroExch.PDDoc")
' Charger le fichier PDF
If Not AcroDoc.Open(pdfPath) Then
MsgBox "Impossible d'ouvrir le fichier PDF.", vbCritical
Exit Sub
End If
' Obtenir l'objet JavaScript du PDF
Set jsObj = AcroDoc.GetJSObject
totalPages = AcroDoc.GetNumPages
' Parcourir toutes les pages du PDF
For currentPage = 0 To totalPages - 1
' Extraire le texte de la page actuelle
textContent = jsObj.GetPageNthWordQuads(currentPage, 0)
' Rechercher la chaîne "FICHE N°"
startIndex = InStr(1, textContent, "FICHE N°", vbTextCompare)
' Rechercher la chaîne "CONSIGNES DE SÉCURITÉ"
endIndex = InStr(startIndex, textContent, "CONSIGNES DE SÉCURITÉ", vbTextCompare)
' Vérifier si les deux chaînes sont trouvées
If startIndex > 0 And endIndex > 0 Then
' Extraire le texte entre les deux chaînes
extractedText = Mid(textContent, startIndex, endIndex - startIndex)
' Coller le texte extrait dans Excel
ws.Cells(outputRow, 1).Value = extractedText
outputRow = outputRow + 1
End If
Next currentPage
' Sauvegarder le contenu extrait au format XML
Dim xmlRange As Range
Set xmlRange = ws.UsedRange
xmlRange.Copy
ws.Cells(1, 1).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
MsgBox "Extraction terminée et collée au format XML.", vbInformation
' Nettoyage et fermeture
AcroDoc.Close
AcroApp.Exit
Set AcroApp = Nothing
Set AcroDoc = Nothing
Set jsObj = Nothing
End Sub
Les etapes souhaitées sont les suivante
1. Sélection du fichier PDF
2. Ouverture avec Adobe Acrobat
3. Recherche des chaînes
4. Recherche d'une chaine de caractère et enregistrer la position
5. Recherche d'une 2ème chaine de caractère et enregistrer la position
6. Si les deux chaînes sont trouvées, extraire le texte entre ces deux positions.
7. Coller dans excel la selection avec le collage spécial en format XML.
La macro se déroule mais rien n'est copié
Les 2 positions restent à 0 tout au long de la macro
Est ce quelqu'un aurait une idée
Par avance merci de votre aide
Salutations
Je souhaiterais rechercher dans toutes les pages d’un PDF les chaînes de caractères spécifiées, extrait le texte entre celles-ci et copie le contenu dans un classeur Excel avec un collage spécial en feuille de calcul XML.
J'ai Adobe Acrobat Pro
ci dessous ma macro que j'utilise
Sub ExtractTextBetweenStringsToXML()
Dim AcroApp As Object
Dim AcroDoc As Object
Dim jsObj As Object
Dim pdfPath As String
Dim textContent As String
Dim startIndex As Long, endIndex As Long
Dim extractedText As String
Dim ws As Worksheet
Dim currentPage As Integer, totalPages As Integer
Dim outputRow As Integer
' Initialiser la feuille cible
Set ws = ThisWorkbook.Sheets(1) ' Modifiez si nécessaire
outputRow = 1 ' Ligne où commencer à écrire dans Excel
' Sélectionner un fichier PDF
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Sélectionnez un fichier PDF"
.Filters.Clear
.Filters.Add "Fichiers PDF", "*.pdf"
If .Show = -1 Then
pdfPath = .SelectedItems(1)
Else
MsgBox "Aucun fichier sélectionné.", vbExclamation
Exit Sub
End If
End With
' Ouvrir Adobe Acrobat
Set AcroApp = CreateObject("AcroExch.App")
Set AcroDoc = CreateObject("AcroExch.PDDoc")
' Charger le fichier PDF
If Not AcroDoc.Open(pdfPath) Then
MsgBox "Impossible d'ouvrir le fichier PDF.", vbCritical
Exit Sub
End If
' Obtenir l'objet JavaScript du PDF
Set jsObj = AcroDoc.GetJSObject
totalPages = AcroDoc.GetNumPages
' Parcourir toutes les pages du PDF
For currentPage = 0 To totalPages - 1
' Extraire le texte de la page actuelle
textContent = jsObj.GetPageNthWordQuads(currentPage, 0)
' Rechercher la chaîne "FICHE N°"
startIndex = InStr(1, textContent, "FICHE N°", vbTextCompare)
' Rechercher la chaîne "CONSIGNES DE SÉCURITÉ"
endIndex = InStr(startIndex, textContent, "CONSIGNES DE SÉCURITÉ", vbTextCompare)
' Vérifier si les deux chaînes sont trouvées
If startIndex > 0 And endIndex > 0 Then
' Extraire le texte entre les deux chaînes
extractedText = Mid(textContent, startIndex, endIndex - startIndex)
' Coller le texte extrait dans Excel
ws.Cells(outputRow, 1).Value = extractedText
outputRow = outputRow + 1
End If
Next currentPage
' Sauvegarder le contenu extrait au format XML
Dim xmlRange As Range
Set xmlRange = ws.UsedRange
xmlRange.Copy
ws.Cells(1, 1).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
MsgBox "Extraction terminée et collée au format XML.", vbInformation
' Nettoyage et fermeture
AcroDoc.Close
AcroApp.Exit
Set AcroApp = Nothing
Set AcroDoc = Nothing
Set jsObj = Nothing
End Sub
Les etapes souhaitées sont les suivante
1. Sélection du fichier PDF
2. Ouverture avec Adobe Acrobat
3. Recherche des chaînes
4. Recherche d'une chaine de caractère et enregistrer la position
5. Recherche d'une 2ème chaine de caractère et enregistrer la position
6. Si les deux chaînes sont trouvées, extraire le texte entre ces deux positions.
7. Coller dans excel la selection avec le collage spécial en format XML.
La macro se déroule mais rien n'est copié
Les 2 positions restent à 0 tout au long de la macro
Est ce quelqu'un aurait une idée
Par avance merci de votre aide
Salutations
