macro starten bij openen

[remcop1989]

Uiteraard ben ik bekend met de document_new, document_open, autoexec en autoopen functies, maar dit geval ligt iets lastiger:

Ik gebruik een programma om offertes mee te maken. In dit programma worden artikelen en "tekstelementen" (standaard stukken tekst) ingevoerd.
Als dit allemaal ingevoerd is, wordt op de knop "offerte maken" geklikt. Het programma pakt nu het vastgelegde Word document met het briefpapier. Word voert op dit moment de document_new actie uit (ben ik achtergekomen door een messagebox te laten tonen). Hierna "pompt" het programma de artikelen en tekstelementen in het nieuwe document.
Als het Word document met offerte verschijnt heb ik een macro in Word staan die een bepaalde opmaak toepast (welke niet in het programma verwerkt kan).

Wat ik nu wil:
Graag zou ik zien dat de macro automatisch uitgevoerd wordt zodra het document klaar is. Ik heb dit al geprobeerd in de document_new actie, maar die wordt te vroeg uitgevoerd en dan staat er nog niets in het document.

Wie heeft ideeën?

 

[SmartThinker]

kan je niet een onzichtbare regel laten overkomen uit je programma. deze zend je als laatste. Als je dan met de document_new een check doet op de aanweizgheid van die data kan je een routine maken die: geen data, start timer, vraag nog een keer in x seconden. Totdat de data er is en dan doe je wat je wil doen.
M.

 

[edmoor]

Hier staat hoe je vanuit Excel VBA een macro in een Word document kunt laten uitvoeren.
Wellicht dat dit je een idee geeft hoe je dit kunt toepassen vanuit je eigen programma:
http://stackoverflow.com/questions/9535959/calling-a-word-vba-sub-with-arguments-from-excel-vba

 

[remcop1989]

Hier staat hoe je vanuit Excel VBA een macro in een Word document kunt laten uitvoeren.
Wellicht dat dit je een idee geeft hoe je dit kunt toepassen vanuit je eigen programma:
http://stackoverflow.com/questions/9535959/calling-a-word-vba-sub-with-arguments-from-excel-vba

Bedankt voor de info. Helaas kan ik niet ingrijpen in het programma. Dat is een stuk waar ik niet aan kan. Bovendien is het gemaakt op basis van visual fox pro

kan je niet een onzichtbare regel laten overkomen uit je programma. deze zend je als laatste. Als je dan met de document_new een check doet op de aanweizgheid van die data kan je een routine maken die: geen data, start timer, vraag nog een keer in x seconden. Totdat de data er is en dan doe je wat je wil doen.
M.

Dat is een idee dat wellicht kan werken! Ik ga eens wat googlen of ik iets concreets vind. Ik hou jullie op de hoogte.

 

[OctaFish]

Of de gebeurtenis Private Sub Document_Close(), als je verder niks in het document hoeft te doen en het automatisch afgesloten wordt door je programma.

 

[remcop1989]

Of de gebeurtenis Private Sub Document_Close(), als je verder niks in het document hoeft te doen en het automatisch afgesloten wordt door je programma.

De offerte moet gecontroleerd kunnen worden nadat de macro is uitgevoerd.

Ik heb nu het volgende:

Private Sub document_new()
MsgBox "dit is de document_new melding"

Do
zoekopdracht
    If ActiveDocument.Content.Find.Found = True Then
    MsgBox "de tekst is gevonden."
    Exit Do
    End If
Application.OnTime when:=Now + TimeValue("00:00:10"), Name:="zoekopdracht"
Loop

End Sub

Private Sub zoekopdracht()

With ActiveDocument.Content.Find
 .Text = "Deze offerte is gemaakt met behulp van Accountview."
 .Forward = True
 .Format = False
End With

End Sub

Het probleem is nu dat hij niet uit de loop komt om de offerte te kunnen laten maken door het programma.
Als ik een messagebox vbOkOnly laat lopen op de Private Sub document_new() en ik klik op ok (waardoor de macro eindigt), dan begint hij de offerte te maken. Anders niet.

Ik wil hem eigenlijk het volgende laten doen:
- zoek naar tekst
- als de tekst gevonden is, start dan de macro FormatTableQuotationLines
- als tekst niet gevonden is, stop dan de Private Sub document_new() en probeer het na X seconden nog eens


Gezien de offerte "op de achtergrond" in elkaar wordt gezet in Word (Het Word venster is niet beschikbaar), is het misschien mogelijk om iets te laten doen zodra het Word venster naar de voorgrond wordt gezet?

 

[remcop1989]

Ik heb het opgelost:

Private Sub document_new()
Application.OnTime when:=Now + TimeValue("00:00:15"), Name:="FormatTableQuotationLines"
End Sub

Vervolgens voert hij de macro "FormatTableQuotationLines" uit:

Sub FormatTableQuotationLines()
    
    Dim tbl As Table
    Dim r As Integer
    Dim c As Integer
    Dim strVal1 As String
    Dim strVal2 As String
    Dim strVal3 As String
    Dim strPrev As String
    
     
    If activedocument.Tables.Count < 2 Then
        ' Verlaat macro er zijn geen tabellen beschikbaar.
        Exit Sub
    End If
    
    ' Ga de 2e tabel doorlopen.
    Set tbl = activedocument.Tables(2)
    
    
    If tbl.Rows.Count > 0 Then
        strVal1 = tbl.Cell(1, 1).Range.Text
        strVal1 = Trim(Left(strVal1, Len(strVal1) - 2))
        If Len(strVal1) = 0 Then
            MsgBox "Formatering van offerteregels is reeds uitgevoerd."
            Exit Sub
        End If
    End If
    
    tbl.Select
    
    Selection.InsertBreak wdSectionBreakContinuous

   
    With Selection.Sections(1).PageSetup
        .Orientation = wdOrientLandscape
        '.PaperSize = wdPaperA3
    End With

    
    ' Probeer de hele tabel landscape te tonen.
    
    On Error Resume Next
    
    Selection.InsertRowsAbove 1
    
    
    For r = 1 To tbl.Rows.Count + 1
        
        If r = 3 Then
            ' probeer een lege regel tussen te voegen
            tbl.Cell(r, 1).Select
            Selection.InsertRowsAbove 1
            r = 4
        End If
        
        strVal1 = tbl.Cell(r, 1).Range.Text
        ' Verwijder regeleindes
        strVal1 = Trim(Left(strVal1, Len(strVal1) - 2))
        
        strVal2 = tbl.Cell(r, 2).Range.Text
        ' Verwijder regeleindes
        strVal2 = Trim(Left(strVal2, Len(strVal2) - 2))
        
        strVal3 = tbl.Cell(r, 3).Range.Text
        ' Verwijder regeleindes
        strVal3 = Trim(Left(strVal3, Len(strVal3) - 2))
        
        If strVal1 = Empty And strVal2 = Empty And strVal3 <> Empty Then
            ' MsgBox "Regel samenvoegen en vet maken en onderstrepen" & r
            tbl.Cell(r, 1).Merge MergeTo:=tbl.Cell(r, 2)
            tbl.Cell(r, 1).Merge MergeTo:=tbl.Cell(r, 3)
            'tbl.Cell(r, 1).Range.Underline = wdUnderlineSingle
            If LCase(Left(tbl.Cell(r, 1).Range.Text, 6)) = "let op" Then
                ' Cursief weergeven en niet vet
                tbl.Cell(r, 1).Range.Italic = True
                tbl.Cell(r, 1).Range.Bold = False
            Else
                ' Anders alleen vet formateren
                tbl.Cell(r, 1).Range.Bold = True
            End If
             
        Else
             'MsgBox "Row " & r & ": " & strVal1 & " Artikel: " & strVal2
        End If
        
        
    Next r
    
    For c = 1 To tbl.Columns.Count
        ' Ga hier pas de 2e regel van lijnen voorzien van de tabel.
        tbl.Cell(2, c).Select
        With Selection.Cells
            .Borders(wdBorderLeft).LineStyle = wdLineStyleNone
            .Borders(wdBorderRight).LineStyle = wdLineStyleNone
            .Borders(wdBorderTop).LineStyle = wdLineStyleSingle
            .Borders(wdBorderBottom).LineStyle = wdLineStyleSingle
            
            .Borders(wdBorderVertical).LineStyle = wdLineStyleNone
            .Borders(wdBorderDiagonalDown).LineStyle = wdLineStyleNone
            .Borders(wdBorderDiagonalUp).LineStyle = wdLineStyleNone
            .Borders.Shadow = False
        End With
    Next

    ' vergroot de tabelbreedte naar 10 centimeter
    tbl.PreferredWidthType = wdPreferredWidthPoints
    tbl.PreferredWidth = CentimetersToPoints(25)
    'With Selection.Tables(1)
    '    .PreferredWidthType = wdPreferredWidthPoints
    '    .PreferredWidth = CentimetersToPoints(10)
    'End With

    
    ' Probeer na de laatste regel te gaan
    tbl.Cell(r, 1).Select
    ' Ga daarna 9 regels lager staan
    Selection.MoveDown Unit:=wdLine, Count:=9
    ' Zet de paginaindeling weer op portrait
    Selection.InsertBreak Type:=wdSectionBreakContinuous
    If Selection.PageSetup.Orientation = wdOrientPortrait Then
        Selection.PageSetup.Orientation = wdOrientLandscape
    Else
        Selection.PageSetup.Orientation = wdOrientPortrait
    End If
    
    'probeer de focus naar het begin van het document te zetten
    Selection.HomeKey Unit:=wdStory
    
    ' Roep functie Convert_2_PDF aan om direct een PDF aan te maken
    Convert_2_PDF
    
End Sub

Sub Convert_2_PDF()
    
    Dim XDocument As String
    Dim Xname As String
    
    ' Let op vervang ook de extensies .docx en .doc
    
    'If activedocument.Path = "" Then
    '    MsgBox "Er is geen PDF Document aangemaakt omdat het huidige document nog niet is opgeslagen."
    '    Exit Sub
    'End If
    
    Xname = Strtran(Strtran(LCase(activedocument.Name), ".docx", ""), ".doc", "") & ".pdf"
    Xname = UCase(Left(Xname, 1)) + Right(Xname, Len(Xname) - 1)
    
    XDocument = activedocument.Path & "\" & Xname
    
    activedocument.ExportAsFixedFormat OutputFileName:= _
    XDocument, ExportFormat:= _
    wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
    wdExportOptimizeForPrint, Range:=wdExportAllDocument, _
    Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
    CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
    BitmapMissingFonts:=True, UseISO19005_1:=False
    
    If Dir(XDocument) <> "" Then
        MsgBox "Er is een PDF document aangemaakt locatie: " + XDocument
    'Else
    '    MsgBox "Er is geen PDF Document aangemaakt omdat het huidige document nog niet is opgeslagen."
    End If
    
End Sub

Function Strtran(Search As String, Find As String, Replace As String, Optional Start As Long, Optional HowMuch As Long) As String
    
    '
    ' Strtran Functie, afgeleid van Microsoft Foxpro
    '
    Dim Begin%
    Dim Count%
    Dim CountRep%
    Dim Deel1$
    Dim Deel2$
    Dim Help$
    Dim LenFind%
    Dim LenHelp%
    Dim LenSearch%
    Dim Part1%
    Dim Part2%
    
    Help$ = Search                 ' HelpString
    Strtran = Help$                ' Returnwaarde functie

    If Find = Replace Then
        '
        ' Zoekstring is gelijk aan de tee vervangen string
        ' Verlaat de Functie
        '
        Exit Function
    End If
    
    LenFind% = Len(Find)           ' Lengte te vervangen str$
                                    ' Indien 0, Vervang met space(0)
    Count% = 0                      ' Aantal keren dat de Find$ gevonden is.
    CountRep% = 0                   ' Aantal keren dat Find$ vervangen is.

    LenSearch% = Len(Help$)         ' Lengte te doorzoeken String
    
    Begin% = 1                      ' Startwaarde met zoeken Find$
    
    Do
        '
        ' Lus om de string die doorzocht moet worden te ontleden.
        '

        Begin% = InStr(Begin%, Help$, Find)
        LenHelp% = Len(Help$)
        
        If Begin% > 0 Then
            '
            ' De te zoeken string komt voor
            '
            
            Count% = Count% + 1

            If Count% >= Start Or Start = 0 Then
                '
                ' Indien Start%>0 dan wordt pas vanaf de Start%-waarde
                ' begonnen met het vervangen.
                '
                
                If CountRep% < HowMuch Or HowMuch = 0 Then
                    '
                    ' Indien HowMuch%>0 dan maximaal HowMuch% keer
                    ' Find$ laten vervangen door replace$
                    '
                    CountRep% = CountRep% + 1
                    
                    Part1% = Begin% - 1
            
                    If Part1% < 1 Then
                        Deel1$ = ""
                    Else
                        Deel1$ = Left(Help$, Part1%)
                    End If
            
                    Part2% = LenHelp% - Begin% - LenFind% + 1

                    If Part2% < 1 Then
                        Deel2$ = ""
                    Else
                        Deel2$ = Right(Help$, Part2%)
                    End If
                    Help$ = Deel1$ + Replace + Deel2$
                Else
                    Exit Do
                End If
            Else
                Begin% = Begin% + 1
            End If
        Else
            '
            ' Niets meer gevonden verlaat lus
            '
            Exit Do
        End If
        
    Loop

    '
    ' Geef de opgebouwde string terug
    '
    Strtran = Help$

End Function

Hoe makkelijk het kan zijn.

 

[SmartThinker]

dank voor de "opgelost" status!