macro che legge dei file raggruppati in delle cartelle e crea il collegamento ipertestuale in una determinata posizione.

Question

Buongiorno, vi spiego il mio problema.

Sto utilizzando una macro che mi permette di andare a leggere dei file pdf contenuti in una cartella e mi crea i collegamenti ipertestuali in foglio excel selezionato.

Ci sono 2 problemi:  

• Se i file pdf di cui devo creare i collegamenti ipertestuali sono contenuti in diverse "sottocartelle" la macro non riesce a creare nessun collegamento ipertestuale.
• I collegamenti  vengono creati e incollati nel foglio Excel selezionato secondo un ordine casuale, posso decidere dove far "generare" i vari collegamenti ipertestuali?(dovrei far ricaricare i collegamenti ipertestuali presenti nel mio foglio Excel i modo tale che se sposto il file tutti i vari collegamenti non vengano persi)

Allego la macro utilizzata

Option Explicit

Sub Inserisci_NomeFiles_Iperlink()

    Application.ScreenUpdating = False

    Dim fd As FileDialog

    Dim i As Integer

    Dim miaCartella

    Dim domanda As String

    Dim lunghezza As Integer

    Dim uR As Long

    Dim FileAltro As Variant

    Dim WK As Workbook

    Dim sh As Worksheet

    Dim fs As Object

    Dim Fold As Object

    Dim Nomefile As Object

    Dim Cartella As Object

    Dim colonna As String

    Dim riga As Integer

    Set fd = Application.FileDialog(msoFileDialogFolderPicker)

    Dim CartellaSelezionata As Variant

    MsgBox "Scegli la cartella con i files ai quali attivare i collegamenti", vbInformation, "AVVISO"

    With fd

        If .Show = -1 Then

            i = 1

            For Each CartellaSelezionata In .SelectedItems

                miaCartella = CartellaSelezionata

            Next

        Else

            Exit Sub

        End If

    End With

    MsgBox "Scegli il file excel su cui copiare i collegamenti", vbInformation, "AVVISO"

    FileAltro = Application.GetOpenFilename

    If FileAltro = "Falso" Then

        MsgBox "Operazione annullata!", vbOKOnly + vbInformation

        Exit Sub

    End If

    Set WK = Workbooks.Open(FileAltro)

WK.BuiltinDocumentProperties("Hyperlink base") = _

                                          "\NoServer\NoFolder"

    Set sh = WK.Worksheets(1)

    Set fs = CreateObject("Scripting.FileSystemObject")

    Set Fold = fs.getfolder(miaCartella)

    Set Cartella = Fold.Files

    domanda = InputBox("Scegli la cella iniziale per scrivere i collegamenti. (Esempio B2)")

    lunghezza = Len(domanda)

    For i = 1 To lunghezza

        If IsNumeric(Mid(domanda, i, 1)) = True Then

            Exit For

        End If

    Next i

    colonna = Left(domanda, i - 1)

    riga = Val(Replace(domanda, colonna, ""))

    On Error GoTo esci

    For Each Nomefile In Cartella

        While sh.Cells(riga, colonna).Value <> ""

            riga = riga + 1

        Wend

        DoEvents

        sh.Cells(riga, colonna) = Left(Nomefile.Name, InStr(Nomefile.Name, ".") - 1)

        ActiveSheet.Hyperlinks.Add Anchor:=sh.Cells(riga, colonna), Address:=Nomefile

    Next

    uR = sh.Cells(Rows.Count, colonna).End(xlUp).Row

    sh.Sort.SortFields.Clear

    sh.Sort.SortFields.Add Key:=Range(domanda & ":" & colonna & uR), Order:=xlAscending

    With sh.Sort

        .SetRange Range(domanda & ":" & colonna & uR)

        .Header = xlGuess

        .MatchCase = False

        .Orientation = xlTopToBottom

        .SortMethod = xlPinYin

        .Apply

    End With

    WK.Save

    WK.Close

    MsgBox "Fatto!", vbInformation, "NOTIFICA"

    Set fs = Nothing

    Set Cartella = Nothing

    Set Fold = Nothing

    Set fd = Nothing

    Application.ScreenUpdating = True

    Exit Sub

esci:

    MsgBox "Si è verificato un errore, forse non hai digitato correttamente la cella scelta." & vbCrLf & "Ripeti l'operazione!", vbExclamation, "ATTENZIONE"

    WK.Save

    WK.Close

End Sub

Allego due screen per far vedere come sono sono suddivisi i pdf ( quelli in blue  sono i collegamenti ipertestuali) un altro per mostrare come dovrebbero essere generati i vari collegamenti ipertestuali

All' interno di queste cartelle sono contenute altre cartelle contenti i vari pdf 

ad esempio se vado ad aprire la cartella ABB avrò:

Answer 1

Ciao Maurizio,

Prova qualcosa del genere:

• Alt+F11 per aprire l'editor di VBA
• Alt+IM per inserire un nuovo modulo di codice
• Nel nuovo modulo vuoto, incolla il seguente codice:

'=========>>

Option Explicit

Private Declare Function SHGetFolderPath _

                          Lib "shfolder.dll" _

                              Alias "SHGetFolderPathA" ( _

                              ByVal hwndOwner As Long, _

                              ByVal nFolder As Long, _

                              ByVal hToken As Long, _

                              ByVal dwReserved As Long, _

                              ByVal lpszPath As String) As Long

Private Const CSIDL_PERSONAL As Long = &H5

Dim iCtr As Long

Dim rCell As Range

'--------->>

Public Sub SelezionaCartella()

    Dim WB As Workbook

    Dim destSH As Worksheet

    Dim destRng As Range

    Dim FD As FileDialog

    Dim sFolder As String, sPercorso As String

    Dim sMsg As String, sTitle As String

    Dim iButtons As Long

    Set FD = Application.FileDialog(msoFileDialogFolderPicker)

    With FD

        .InitialFileName = MyDocuments

        .Title = "Seleziona Directory"

        .ButtonName = "Seleziona"

        If .Show = -1 Then

            sFolder = .SelectedItems(1)

        End If

    End With

    If sFolder = vbNullString Then

        sMsg = "Non hai selezionato una Directory! (:-"

        GoTo XIT

    End If

    On Error Resume Next

    Set destRng = Application.InputBox( _

                  Prompt:="Seleziona la destinazione per " _

                          & "i collegamenti ipertestuali", _

                  Default:=ActiveCell.Address(0, 0, , 1), _

                  Title:="SELEZIONA FOGLIO & CELLA", _

                  Type:=8)

    On Error GoTo 0

    If Not destRng Is Nothing Then

        With destRng

            Set destSH = .Parent

            Set rCell = .Cells(1)

        End With

        Set WB = destSH.Parent

        With WB

            .BuiltinDocumentProperties("Hyperlink base") = _

            "\NoServer\NoFolder"

            iCtr = 0

            Call CreaHyperlink(sFolder, destRng.Cells(1))

        End With

    Else

        sMsg = "Non hai selezionato una destinazione " _

               & "per i collegamenti ipertestuali!" _

               & vbNewLine & vbNewLine _

               & "Riprova!"

        GoTo XIT

    End If

XIT:

    With FD

        .InitialFileName = ""

        .Title = ""

        .ButtonName = ""

    End With

    If sMsg <> vbNullString Then

        sTitle = "OPERAZIONE ANNULLATA"

        iButtons = vbCritical

    Else

        rCell.EntireColumn.AutoFit

        sMsg = "Finita!" _

               & vbNewLine & vbNewLine _

               & iCtr & " collegamenti ipertestuali " _

               & "sono stati creati nell'intervallo " _

               & rCell.Resize(iCtr).Address(0, 0) _

               & " sul foglio: " & destSH.Name & " del file " _

               & WB.Name

        sTitle = "REPORT"

        iButtons = vbInformation

    End If

    Call MsgBox( _

         Prompt:=sMsg, _

         Buttons:=vbCritical, _

         Title:="OPERAZIONE ANNULLATA")

End Sub

'--------->>

Public Sub CreaHyperlink(sPercorso As String, Rng As Range)

    Dim oFSO As Object

    Dim oFolder As Object

    Dim oSubFolder As Object

    Dim oFile As Object

    Dim sFilename As String

    Set oFSO = CreateObject("Scripting.FileSystemObject")

    Set oFolder = oFSO.GetFolder(sPercorso)

    On Error Resume Next

    For Each oSubFolder In oFolder.SubFolders

        CreaHyperlink oSubFolder.Path, Rng

    Next oSubFolder

    With Application

        .EnableEvents = False

        .ScreenUpdating = False

    End With

    For Each oFile In oFolder.Files

        With oFile

            sFilename = Split(.Name, ".")(0)

            Rng.Value = sFilename

            ActiveSheet.Hyperlinks.Add _

                    Anchor:=Rng, _

                    Address:=.Path

            iCtr = iCtr + 1

        End With

        Set Rng = Rng.Offset(1)

    Next oFile

XIT:

    With Application

        .EnableEvents = True

        .ScreenUpdating = True

    End With

End Sub

'--------->>

Public Function MyDocuments() As String

    Dim pos As Long

    Dim sBuffer As String

    sBuffer = Space$(260)

    If SHGetFolderPath(0&, CSIDL_PERSONAL, -1, 0&, sBuffer) = 0 Then

        pos = InStr(1, sBuffer, Chr(0))

        MyDocuments = Left$(sBuffer, pos - 1)

    End If

End Function

'<<=========

• Alt+Q per chiudere l'editor di VBA e tornare a Excel
• Salva il file con l’estensione xlsm
• Alt+F8 per aprire  la finestra di gestione delle macro
• Seleziona la procedura: SelezionaCartella
• Esegui

===

Regards,

Norman

Answer 2

Ciao Maurizio,

Ho eseguito le tue istruzioni, incollando la macro.

Eseguendo la macro mi viene fornito il seguente errore come si può risolvere?

Stai  esercitando l'arte di creare echi? -:)

Questo è identico al tuo post #3  in questo thread!!! Quindi, rileggi la risposta che ho postato a quel tempo. 

===

Regards,

Norman

Answer 3

Ciao Maurizio,

Ripensandoci bene, credo che io abbia capito male la tua esigenza e, pertanto, ti chiedo scusa!

Se la tua esigenza sia quella di corregere dei collegamenti ipertestuali che sono stati creati in precedenza, e qualora tu non avessi eseguito il mio codice per

creare dei collegamenti, prova la seguente procedura:

'=========>>

Option Explicit

'--------->>

Public Sub Tester()

    Dim WB As Workbook

    Dim SH As Worksheet

    Dim FD As FileDialog

    Dim HL As Hyperlink

    Dim arrSplit As Variant

    Dim sFolder As String, sPercorso As String

    Dim sMsg As String

    Const sFoglio As String = "Foglio1"                  '<<=== Modifica

    Set FD = Application.FileDialog(msoFileDialogFolderPicker)

    With FD

        If .Show = -1 Then

            sFolder = .SelectedItems(1)

        End If

    End With

    If sFolder = vbNullString Then

        sMsg = "Non hai selezionato una Directory! (:-"

        GoTo XIT

    End If

    Set WB = ThisWorkbook

    With WB

        Set SH = .Sheets(sFoglio)

        If .BuiltinDocumentProperties("Hyperlink base") = _

                                              vbNullString Then

            .BuiltinDocumentProperties("Hyperlink base") = _

                                            "\NoServer\NoFolder"

        Else

            sMsg = "Attenzione! Sembra che i collegamenti ipertestuali  " _

                   & "di questo file siano già assoluti!"

            GoTo XIT

        End If

    End With

    For Each HL In SH.Hyperlinks

        With HL

            arrSplit = Split(.Address, "")

            arrSplit(0) = vbNullString

            sPercorso = Join(arrSplit, "")

            .Address = sFolder & sPercorso

        End With

    Next HL

    Exit Sub

XIT:

    Call MsgBox( _

         Prompt:=sMsg, _

         Buttons:=vbCritical, _

         Title:="REPORT")

End Sub

'<<=========

===

Regards,

Norman

Answer 4

Ciao  Maurizio,

GRAZIE NORMAN, MA COME FACCIO A RIPOSIZIONARE NELLA STESSA POSIZIONE DOVE SI TROVAVANO PRIMA I COLlAEGAMENTI? ORA LA MACRO DALLE SOTTO CARTELLE LEGGE E INCOLLA CORRETTAMENTE I PDF.

A questo punto dovrei solo farli incollare nella posizione corretta, ovvero andare ad incollarli nella stessa posizione dei vecchi collegamenti.

Non so se mi sono ben spiegato.

Forse vi è un fraintendimento!

Il mio codice permette la selezione di una cartella e crea un collegamento ipertestuale per ogni file sia nella cartella stessa che ogni sottocartella.

Sono in viaggio e quindi potrebbe esserci un leggero ritardo nel pubblicare ulteriori risposte.

===

Regards,

Norman

Answer 5

Ciao Maurizio,

se vado ed eseguire la macro seguendo le tue istruzioni mi da il seguente errore, cosa devo fare?

Sostituisci il codice con la seguente versione che comprende la compilazione condizionale:

'=========>>

Option Explicit

#If VBA7 Then

    Private Declare PtrSafe Function SHGetFolderPath Lib "shfolder.dll" _

    Alias "SHGetFolderPathA" _

       (ByVal hwndOwner As LongPtr, _

        ByVal nFolder As Long, _

        ByVal hToken As LongPtr, _

        ByVal dwReserved As Long, _

        ByVal lpszPath As String) As Long

#Else       

    Private Declare Function SHGetFolderPath Lib "shfolder.dll" _

    Alias "SHGetFolderPathA" _

       (ByVal hwndOwner As Long, _

        ByVal nFolder As Long, _

        ByVal hToken As Long, _

        ByVal dwReserved As Long, _

        ByVal lpszPath As String) As Long

#End If

Private Const CSIDL_PERSONAL As Long = &H5

Dim iCtr As Long

Dim rCell As Range

'--------->>

Public Sub SelezionaCartella()

    Dim WB As Workbook

    Dim destSH As Worksheet

    Dim destRng As Range

    Dim FD As FileDialog

    Dim sFolder As String, sPercorso As String

    Dim sMsg As String, sTitle As String

    Dim iButtons As Long

    Set FD = Application.FileDialog(msoFileDialogFolderPicker)

    With FD

        .InitialFileName = MyDocuments

        .Title = "Seleziona Directory"

        .ButtonName = "Seleziona"

        If .Show = -1 Then

            sFolder = .SelectedItems(1)

        End If

    End With

    If sFolder = vbNullString Then

        sMsg = "Non hai selezionato una Directory! (:-"

        GoTo XIT

    End If

    On Error Resume Next

    Set destRng = Application.InputBox( _

                  Prompt:="Seleziona la destinazione per " _

                          & "i collegamenti ipertestuali", _

                  Default:=ActiveCell.Address(0, 0, , 1), _

                  Title:="SELEZIONA FOGLIO & CELLA", _

                  Type:=8)

    On Error GoTo 0

    If Not destRng Is Nothing Then

        With destRng

            Set destSH = .Parent

            Set rCell = .Cells(1)

        End With

        Set WB = destSH.Parent

        With WB

            .BuiltinDocumentProperties("Hyperlink base") = _

            "\NoServer\NoFolder"

            iCtr = 0

            Call CreaHyperlink(sFolder, destRng.Cells(1))

        End With

    Else

        sMsg = "Non hai selezionato una destinazione " _

               & "per i collegamenti ipertestuali!" _

               & vbNewLine & vbNewLine _

               & "Riprova!"

        GoTo XIT

    End If

XIT:

    With FD

        .InitialFileName = ""

        .Title = ""

        .ButtonName = ""

    End With

    If sMsg <> vbNullString Then

        sTitle = "OPERAZIONE ANNULLATA"

        iButtons = vbCritical

    Else

        rCell.EntireColumn.AutoFit

        sMsg = "Finita!" _

               & vbNewLine & vbNewLine _

               & iCtr & " collegamenti ipertestuali " _

               & "sono stati creati nell'intervallo " _

               & rCell.Resize(iCtr).Address(0, 0) _

               & " sul foglio: " & destSH.Name & " del file " _

               & WB.Name

        sTitle = "REPORT"

        iButtons = vbInformation

    End If

    Call MsgBox( _

         Prompt:=sMsg, _

         Buttons:=vbCritical, _

         Title:="OPERAZIONE ANNULLATA")

End Sub

'--------->>

Public Sub CreaHyperlink(sPercorso As String, Rng As Range)

    Dim oFSO As Object

    Dim oFolder As Object

    Dim oSubFolder As Object

    Dim oFile As Object

    Dim sFilename As String

    Set oFSO = CreateObject("Scripting.FileSystemObject")

    Set oFolder = oFSO.GetFolder(sPercorso)

    On Error Resume Next

    For Each oSubFolder In oFolder.SubFolders

        CreaHyperlink oSubFolder.Path, Rng

    Next oSubFolder

    With Application

        .EnableEvents = False

        .ScreenUpdating = False

    End With

    For Each oFile In oFolder.Files

        With oFile

            sFilename = Split(.Name, ".")(0)

            Rng.Value = sFilename

            ActiveSheet.Hyperlinks.Add _

                    Anchor:=Rng, _

                    Address:=.Path

            iCtr = iCtr + 1

        End With

        Set Rng = Rng.Offset(1)

    Next oFile

XIT:

    With Application

        .EnableEvents = True

        .ScreenUpdating = True

    End With

End Sub

'--------->>

Public Function MyDocuments() As String

    Dim pos As Long

    Dim sBuffer As String

    sBuffer = Space$(260)

    If SHGetFolderPath(0&, CSIDL_PERSONAL, -1, 0&, sBuffer) = 0 Then

        pos = InStr(1, sBuffer, Chr(0))

        MyDocuments = Left$(sBuffer, pos - 1)

    End If

End Function

'<<=========

===

Regards,

Norman