Læse antal sider i Wordfil (lukket) fra Excel

I første omgang:
Koden anbringes i det aktuelle ark - i VBA-projektet er der tilføjet en reference til Microsoft Word xx Object Library

I ovennævnte er det fulde filnavn anført i Kolonne A - eller skal koden tilføje "rtf"?
Hvor skal sidetallet anføres?


Dim rtfFil, sti
Sub aflæsDok()
    sti = ActiveWorkbook.Path
    If Right(sti, 1) <> "\" Then
        sti = sti + "\"
    End If
   
    Set rtfFil = CreateObject("Word.Application")
    With rtfFil
        .Documents.Open sti + "dok.rtf"
        antalsider = .ActiveDocument.BuiltinDocumentProperties(wdPropertyPages)
    End With
   
    rtfFil.Application.Quit
    Set rtfFil = Nothing
End Sub

Kode skal tilføje "rtf", da der i kolonne A alene står 18555.

Side antallet skal indsættes i kolonne E.

Der er ca. 300 filnavne oplistet i kolonne A, hvor der skal indsættes antal sider i kolonne E i samme række som filnavnet står i.

Kolonne A              Kolonne E
18500                      2
18505                      3
18507                      2
18544                      9
18699                      3

Rem Koden anbringes i det pågældende ark
Rem RTF-filer forventes at være i samme mappe som XLS-filen
Rem =======================================================
Dim rtfFil
Sub aflæsDok()
Dim sti, antalRæk, filnavn, antalSider
    sti = findSti
    antalRæk = ActiveCell.SpecialCells(xlLastCell).Row
   
    For ræk = 1 To antalRæk
        filnavn = CStr(Cells(ræk, 1))
        antalSider = findAntalSider(sti + filnavn)
        Cells(ræk, 5) = antalSider
    Next ræk
   
    MsgBox ("Gennemgang afsluttet")
End Sub
Private Function findAntalSider(fil)
On Error GoTo fejl

    Set rtfFil = CreateObject("Word.Application")
    With rtfFil
        .Documents.Open fil + ".rtf"
        findAntalSider = .ActiveDocument.BuiltinDocumentProperties(wdPropertyPages)
    End With
   
    rtfFil.Application.Quit
    Set rtfFil = Nothing
    Exit Function
   
fejl:
On Error Resume Next
    findAntalSider = 0
    rtfFil.Application.Quit
    Set rtfFil = Nothing
End Function
Private Function findSti()
    findSti = ActiveWorkbook.Path
    If Right(findSti, 1) <> "\" Then
        findSti = findSti + "\"
    End If
End Function

Har du afprøvet koden?

Jeg har netop afprøvet koden og den driller fortsat.

Den skriver 0 i alle felterne i kolonne E (de rækker hvor der er et filnavn i kolonne A). Det ser dermed ikke ud til at den finder et antal sider.

Når programmet har kørt skal man svarer på om man vil gemme ændringer i de filer den har åbnet - kan man ikke undgå at den åbner filerne så man ikke skal svarer på alle disse bokse?

Ligger RTF-filerne i samme mappe som xls-filen - der returneres 0, hvis der opstår en fejl - f.eks., hvis filen ikkekan findes?

Det sidste spørgsmål - det ser jeg på.

NB: Prøv at sende en af RTF-filerne til: pb@supertekst-it.dk

Nogen afklaring?

Er hermed afsendt ;-)

Hej Supertekst

Det virker perfekt - tak for hjælpen!!!

-------------------- til andre ser den endelige kode sådanne ud --------------

Rem Koden anbringes i det pågældende ark
Rem RTF-filer forventes at være i samme mappe som XLS-filen
Rem =======================================================
Dim rtfFil
Sub aflæsDok()
Dim sti, antalRæk, filnavn, antalSider
    sti = findSti
    antalRæk = ActiveCell.SpecialCells(xlLastCell).Row
   
    For ræk = 1 To antalRæk
        filnavn = CStr(Cells(ræk, 1))
        antalSider = findAntalSider(sti + filnavn)
        Cells(ræk, 5) = antalSider
    Next ræk
   
    MsgBox ("Gennemgang afsluttet")
End Sub
Private Function findAntalSider(fil)
On Error GoTo fejl

    Set rtfFil = CreateObject("Word.Application")
    With rtfFil
        .Documents.Open fil + ".rtf"
       
Rem Sæt visning til "UdskriftsVisning"
    If .ActiveWindow.View.SplitSpecial = wdPaneNone Then
        .ActiveWindow.ActivePane.View.Type = wdPrintView
    Else
        .ActiveWindow.View.Type = wdPrintView
    End If

        findAntalSider = .ActiveDocument.BuiltinDocumentProperties(wdPropertyPages)
    End With
   
    rtfFil.ActiveDocument.Close
    rtfFil.Application.Quit
    Set rtfFil = Nothing
    Exit Function
   
fejl:
On Error Resume Next
    findAntalSider = 0
    rtfFil.Application.Quit
    Set rtfFil = Nothing
End Function
Private Function findSti()
    findSti = ActiveWorkbook.Path
    If Right(findSti, 1) <> "\" Then
        findSti = findSti + "\"
    End If
End Function