HYPERLINK (Aus Formel in Excel generiert) mit VBA prüfen

Const Zeile1 = 10   'Hyperlink-Zeilen Begin  
Const Spalte = "L"  'Hyperlink-Spalte  

Private Sub TestHyperlinks()
    Dim Fso As Object, c As Range, EndLine As Long
    
    Set Fso = CreateObject("Scripting.FileSystemObject")  
    
    EndLine = Cells(Cells.Rows.Count, Spalte).End(xlUp).Row
    
    For Each c In Range(Cells(Zeile1, Spalte), Cells(EndLine, Spalte))
        If c.Formula Like "*HIPERVINCULO*" And c.Text <> "" Then  
            If Fso.FileExists(c) = False Then
                c.Offset(0, 1) = "x"  
            Else
                c.Offset(0, 1) = ""  
            End If
        End If
    Next
End Sub

Option Explicit

Const Zeile1 = 10   'Hyperlink-Zeilen Begin  
Const Spalte = "L"  'Hyperlink-Spalte  

Const AcrobatReader = """D:\Programme\Adobe\Reader 9.0\Reader\AcroRd32.exe"" /p /h """  

Private Sub TestHyperlinks_Click()
    Dim Fso As Object, c As Range, EndLine As Long
    
    Set Fso = CreateObject("Scripting.FileSystemObject")  
    
    EndLine = Cells(Cells.Rows.Count, Spalte).End(xlUp).Row
    
    For Each c In Range(Cells(Zeile1, Spalte), Cells(EndLine, Spalte))
        If c.Formula Like "*HYPERLINK*" And c.Text <> "" Then  
            If Fso.FileExists(c) = False Then
                c.Offset(0, 1) = "x"  
            Else
                c.Offset(0, 1) = ""  
            End If
        End If
    Next
End Sub


Private Sub PrintPdf_Click()
    Dim Fso As Object, c As Range, EndLine As Long
    
    Set Fso = CreateObject("Scripting.FileSystemObject")  
    
    EndLine = Cells(Cells.Rows.Count, Spalte).End(xlUp).Row
    
    For Each c In Range(Cells(Zeile1, Spalte), Cells(EndLine, Spalte))
        If c.Formula Like "*HYPERLINK*" And c.Text <> "" Then  
            If Fso.FileExists(c) = True Then
                Shell AcrobatReader & c & """", vbMinimizedNoFocus  
            End If
        End If
    Next
End Sub

Option Explicit

Const Zeile1 = 10           'Hyperlink-Zeilen Begin  
Const Spalte = "L"          'Hyperlink-Spalte  

Const PdfName = "H"         'Spalte Pdf-Name  

'Pfad der Pdf-Dateien mit Variable (?) für Dateiname  
Const PdfPfad = "W:\Personal\Manuel\Facturas_Vaude\?.pdf"   

Const AcrobatReader = """D:\Programme\Adobe\Reader 9.0\Reader\AcroRd32.exe"" /p /h """  

Private Sub TestHyperlinks_Click()
    Dim Fso As Object, c As Range, EndLine As Long, Pdf As String
    
    Set Fso = CreateObject("Scripting.FileSystemObject")  
    
    EndLine = Cells(Cells.Rows.Count, Spalte).End(xlUp).Row
    
    For Each c In Range(Cells(Zeile1, Spalte), Cells(EndLine, Spalte))
        If c.Formula Like "*HYPERLINK*" And c.Text <> "" Then  
            Pdf = Replace(PdfPfad, "?", Cells(c.Row, PdfName))  
            If Fso.FileExists(Pdf) = False Then
                c.Offset(0, 1) = "x"  
            Else
                c.Offset(0, 1) = ""  
            End If
        End If
    Next
End Sub


Private Sub PrintPdf_Click()
    Dim Fso As Object, c As Range, EndLine As Long, Pdf As String
    
    Set Fso = CreateObject("Scripting.FileSystemObject")  
    
    EndLine = Cells(Cells.Rows.Count, Spalte).End(xlUp).Row
    
    For Each c In Range(Cells(Zeile1, Spalte), Cells(EndLine, Spalte))
        If c.Formula Like "*HYPERLINK*" And c.Text <> "" Then  
            Pdf = Replace(PdfPfad, "?", Cells(c.Row, PdfName))  
            If Fso.FileExists(Pdf) = True Then
                Shell AcrobatReader & Pdf & """", vbMinimizedNoFocus  
            End If
        End If
    Next
End Sub

Const PdfCopyPfad = "W:\Personal\Manuel\Facturas_Vaude_Copy"  

Private Sub CopyPdf_Click()
    Dim Fso As Object, c As Range, EndLine As Long
    
    Set Fso = CreateObject("Scripting.FileSystemObject")  
    
   'On Error Resume Next:  Fso.DeleteFolder PdfCopyPfad, True:  On Error GoTo 0  
    
   'Fso.CreateFolder PdfCopyPfad  

    EndLine = Cells(Cells.Rows.Count, Spalte).End(xlUp).Row
    
    For Each c In Range(Cells(Zeile1, Spalte), Cells(EndLine, Spalte))
        If c.Formula Like "*HYPERLINK*" And c.Text <> "" Then  
            If Fso.FileExists(c) = True Then Fso.CopyFile c, PdfCopyPfad & "\"  
        End If
    Next
End Sub

Const PdfCopyPfad = "W:\Personal\Manuel\Facturas_Vaude_Copy"  

Private Sub CopyPdf_Click()
    Dim Fso As Object, c As Range, EndLine As Long, Pdf As String
    
    Set Fso = CreateObject("Scripting.FileSystemObject")  
    
   'On Error Resume Next:  Fso.DeleteFolder PdfCopyPfad, True:  On Error GoTo 0  
    
   'Fso.CreateFolder PdfCopyPfad  

    EndLine = Cells(Cells.Rows.Count, Spalte).End(xlUp).Row
    
    For Each c In Range(Cells(Zeile1, Spalte), Cells(EndLine, Spalte))
        If c.Formula Like "*HYPERLINK*" And c.Text <> "" Then  
            Pdf = Replace(PdfPfad, "?", Cells(c.Row, PdfName))  
            If Fso.FileExists(Pdf) = True Then Fso.CopyFile Pdf, PdfCopyPfad & "\"  
        End If
    Next
End Sub

    Dim StdDrucker As String

    StdDrucker = Application.ActivePrinter
    
    Application.ActivePrinter = "Druckername auf Ne00:"  
    
    Shell AcrobatReader.....
    
    Application.ActivePrinter = StdDrucker

Sub GetStdPrinterName()
    MsgBox "Die Druckerbezeichnung: " & Application.ActivePrinter  
End Sub

Option Explicit
Option Compare Text

Const strComputer = "."  

Const PdfPrinter = "Canon MX850 series Printer"  

Const ErrMsg = "Setzen des Standard-Druckers fehlgeschlagen"  

Private Sub PrintPdf()
    Dim StdPrinter As String
    
    StdPrinter = GetStdPrinter
    
    If SetStdPrinter(PdfPrinter) = False Then MsgBox ErrMsg, vbExclamation, "Fehler":  Exit Sub  
    
   'Pdf's drucken...  
    
    If SetStdPrinter(StdPrinter) = False Then MsgBox ErrMsg, vbExclamation, "Fehler"  
End Sub

Private Function GetStdPrinter() As String
    Dim objWMIService As Object, colItems As Object, objItem As Object
    
    Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\CIMV2")  
    Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_Printer", , 48)  
    
    For Each objItem In colItems
        If objItem.Default = True Then GetStdPrinter = objItem.Name:  Exit For
    Next
End Function

Private Function SetStdPrinter(ByRef Printer) As Boolean
    Dim objWMIService As Object, colItems As Object, objItem As Object
    
    Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\CIMV2")  
    Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_Printer", , 48)  
    
    For Each objItem In colItems
        If objItem.Name Like Printer Then objItem.SetDefaultPrinter:  SetStdPrinter = True:  Exit For
    Next
End Function

("SELECT * FROM Win32_Printer WHERE PortName LIKE 'USB%'", , 48)  

                    
Shell """C:\Programme\Adobe\Reader 9.0\Reader\AcroRd32.exe"" /t " _  
                                & LinkAdresse & " ""Druckername"" ""Druckertreiber"" ""Druckerport""", vbMinimizedNoFocus  

  For Each c In Range(Cells(ZeilenNr, 15), Cells(ZeilenNr, 28))
            If c.Hyperlinks.Count And c.Text <> "" Then  
            For Each Link In c.Hyperlinks
                LinkAdresse = "K:\testordner\" + Link.Address  
                If Fso.FileExists(LinkAdresse) = True Then
                    Shell """C:\Programme\Adobe\Reader 9.0\Reader\AcroRd32.exe"" /t " _   
                               & LinkAdresse & " ""Druckername"" ""Druckertreiber"" ""Druckerport""", vbMinimizedNoFocus  
                End If
            Next
            End If

For r = BegLine To EndLine
    For c = 15 To 28
        If Cells(r, c).Hyperlinks.Count Then
            LinkAdresse = "K:\testordner\" + Cells(r, c).Hyperlinks(1).Address  
            If Fso.FileExists(LinkAdresse) = True Then
                Shell """C:\Programme\Adobe\Reader 9.0\Reader\AcroRd32.exe"" /t " & LinkAdresse & _  
                      " ""Druckername"" ""Druckertreiber"" ""Druckerport""", vbMinimizedNoFocus  
            End If
        End If
    Next
Next

Private Sub AcroReaderBeenden()
 
Dim objWMI As Object
Dim objProcess As Object
Dim colSystem As Object
 
 
Set objWMI = GetObject("winmgmts:")  
Set colSystem = objWMI.InstancesOf("win32_process")  
 
For Each objProcess In colSystem
  If objProcess.Name = "AcroRd32.exe" Then  
    objProcess.Terminate
  End If
Next
 
Set colSystem = Nothing
Set objProcess = Nothing
Set objWMI = Nothing
 
End Sub