hyperlink openen en automatisch laten afdrukken

[kibus]

heeft misschien iemand een code zodra de link is geopend deze zichzelf afdrukt en sluit,?

mvr gr

Edwin

 

[Wigi]

Zoek eens op internet, er zijn massa's sites waar je de code kan vinden om vanuit Excel een Word bestand te openen.

 

[Wigi]

Als je er niet uitkomt kan ik zelf ook een van de dagen wel eens kijken.

 

[kibus]

Beste Wigi,

Allereerst bedankt voor jouw reactie, ik ben vrij nieuw op deze site en heb een lichte vba kennis ik kan dus wel wat hulp gebruiken, het is nl de bedoeling zodra het filter is uitgewerkt dat alle gevonden waarde 1 voor 1 worden uitprint dmv hyperlinks

mvr groet

Edwin

 

[Wigi]

Edwin

Ik heb gezien dat ik jouw test bestand niet op mijn USB stick gezet heb. De code volgt dus morgen.

De code achter de knop kan wel veel korter:

Private Sub CommandButton1_Click()
    Range("A1:C4").AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range("F1:F2"), Unique:=False
    Range("B3").CurrentRegion.Copy Sheets("Blad2").Range("A1")
End Sub

Wigi

 

[kibus]

Dank je wel Wigi die code heb ik gelijk aangepast, en wacht met smart af morgen naar jouw bevindingen.

 

[Wigi]

... en wacht met smart af morgen naar jouw bevindingen.

Maak hier maar van:

"... en wacht in spanning af morgen naar jouw bevindingen, maar weet zeker dat het in orde komt."

Dat klinkt alvast veel beter :thumb:

See you,

Wigi

 

[Wigi]

Voilà, hier is het. Dit is de VBA code voor achter het blad met de links:

Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
    'Maak een referentie naar Word object library. Hoe?
    'In de VB Editor, kies Tools > References. Scroll dan naar beneden
    'tot Microsoft Word n.n Object Library (n.n hangt af van de versie van Word).
    
    'pas de code aan bij target.address: pad erbij (hier: in string of manueel, of bij Hyperlink bewerken).
    
    Dim wdApp As Word.Application
    Dim wdDoc As Word.Document
    
    Application.ScreenUpdating = False
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err.Number <> 0 Then Set wdApp = CreateObject("Word.Application")  'Word was nog niet opgestart
    On Error GoTo 0
    
    With wdApp
        .Visible = True
        Set wdDoc = .Documents.Open(Target.Address)
    End With
    wdDoc.PrintOut
    wdApp.Quit False
    Set wdApp = Nothing
    Set wdDoc = Nothing
    MsgBox "Klaar."
    Application.ScreenUpdating = True
End Sub

Wigi

 

[kibus]

Dank je wel,Wigi ik ben er mee aan het stoeien, maar krijg het nog niet voor elkaar, misschien heb ik toch nog iets te weinig kennis van vba

 

[Wigi]

Dank je wel,Wigi ik ben er mee aan het stoeien, maar krijg het nog niet voor elkaar, misschien heb ik toch nog iets te weinig kennis van vba

2 dingen moet je doen:

- op de tab van je blad met de links, klik je rechts, dan "Programmacode weergeven" kiezen en de gegeven code plakken.

- in VBA, nu je er toch bent, doe bij Tools > References, en zie of er een vinkje staat bij Microsoft Word n.n Object Library (n.n hangt af van de versie van Word). Alles staat alfabetisch, dus scroll naar beneden.

Heb je beide gedaan en werkt het dan nog niet?

Wigi

 

[kibus]

ja heb beide gedaan maar de code loopt vast bij target adress

 

[Wigi]

ja heb beide gedaan maar de code loopt vast bij target adress

Hang je bestandje nog eens bij dan. Zo kunnen we zien wat er mangelt.

 

[kibus]

Ik ga een nieuw voorbeeldje maken ik heb wat dingetjes over het hoofd gezien

 

[kibus]

Een nieuw voorbeeldje . zou je hier eens naar willen kijken Wigi ?

 

[Wigi]

Een nieuw voorbeeldje . zou je hier eens naar willen kijken Wigi ?

Doe ik een dezer dagen.

 

[kibus]

Iedereen een gezond en gelukkig 2007..,

Heeft iemand een oplossing voor mijn vraag ?

 

[Wigi]

Heeft iemand een oplossing voor mijn vraag ?

Hopelijk morgenavond.

 

[kibus]

Enig idee Wigi
ik loop zelf behoorlijk vast

 

[Wigi]

Het is gelukt, maar heb er toch wel lang aan gezeten...

Jouw oorspronkelijke code van de Advanced Filter werd ook opgekuist.

Sub Macro1()
    Dim c As Range
    
    With Sheets("records")
        On Error Resume Next
        .ShowAllData
        On Error GoTo 0
        
        'Range("A11", Range("A11").End(xlDown)).Cut .Range("G5") 'DEZE REGEL NOG AANPASSEN
        .Range("A8").Resize(3).Copy .Range("G5")
        .Range("A4:D10").AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=.Range("G4:G7"), Unique:=False
        .Columns("A:D").Copy Sheets("resultaat ").Cells(1)
        Application.CutCopyMode = False
        
        Sheets("resultaat ").Select
        For Each c In Range("D5", Range("D" & Rows.Count).End(xlUp))
            Call OpenEnPrint(c.Hyperlinks(1))
        Next c
        .ShowAllData
    End With
    MsgBox "Klaar.", vbInformation, "Wim Gielis, 2007"
End Sub

'Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
Sub OpenEnPrint(ByVal hl As Hyperlink)
    'Maak een referentie naar Word object library. Hoe?
    'In de VB Editor, kies Tools > References. Scroll dan naar beneden
    'tot Microsoft Word n.n Object Library (n.n hangt af van de versie van Word).
    
    'pas de code aan bij target.address: pad erbij (hier: in string of manueel, of bij Hyperlink bewerken).
    
    Dim wdApp As Word.Application
    Dim wdDoc As Word.Document
    
    Application.ScreenUpdating = False
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err.Number <> 0 Then Set wdApp = CreateObject("Word.Application")  'Word was nog niet opgestart
    On Error GoTo 0
    
    With wdApp
        .Visible = True
        Set wdDoc = .Documents.Open("C:\Recept\" & hl.Address)  'DEZE REGEL MOGELIJK NOG AANPASSEN
    End With
    
    'wdDoc.PrintOut    'DEZE REGEL NOG AANPASSEN
    MsgBox hl.Address  'DEZE REGEL NOG AANPASSEN
    
    wdApp.Quit False
    Set wdApp = Nothing
    Set wdDoc = Nothing
    Application.ScreenUpdating = True
End Sub

Pas de gemarkeerde regels nog aan.

Wigi

 

[kibus]

Dank je wel, hier moet ik me toch even in verdiepen