VBA og Word

Hej eksperter

Nedenstående VBA (placeret i Normal.dot) fungerer egentlig nogenlunde men
det er ikke speciel flot programmering så jeg håber at en eller anden kan
gøre den bedre.
Meningen er som følger:

- Worddokumentet (gemt som cpr.nr med ekstensionen: .epi) hvorfra makroen
skal aktiveres består af 2 sider
- Først skal dokumenterne kopieres
- Der skal startes et nyt dokument fra skabelonen Epikrise.dot bestående af
2 "ark"
- De kopierede dokumenter skal indsættes efter de nye dokumenter men således
at de starter på et nyt ark og ikke midt i et allerede eksisterende ark
- Herefter skal dokumentet gemmes som det hedder det samme som de første
dokumenter (Cpr.nr med ekstensionen: .epi)
- Ovenstående skulle gerne kunne gentages et større antal gange (det kan man
IKKE med det jeg har konstrueret)

Pyh jeg håber at ovenstående er forståeligt og at en ekspert gider at gøre
et forsøg.


vh Steen

Sub NyEpikrise1()


' NyEpikrise Makro
' Makro indspillet 06-12-2004 af Steen Sommer Andersen

'Vi erklærer lige nogen variable
    Dim Navn As String
    Dim Cpr As String
    Dim Hcv As String
    Dim Adr As String
    Dim PostBy As String
    Dim IDato As String

Dim Cprnr As String, sPath As String, WB As String, Epi As String, AD As
Document
'On Error Resume Next

    Set AD = ActiveDocument
    Epi = ActiveDocument.Name
    Cprnr = Left(ActiveDocument.Name, 11)
    sPath = "\\server\faelles\index data\patientmapper\"
    pPath = "\\server\faelles\index data\epikriser\"

Dim B As Bookmark
For Each B In ActiveDocument.Bookmarks
    ActiveDocument.Bookmarks(B).Delete
Next B

    Selection.MoveUp Unit:=wdLine, Count:=2000

    Selection.MoveDown Unit:=wdLine, Count:=2000, Extend:=wdExtend
'Count:=106,
    Selection.Copy
  'ActiveDocument.Close False
    Documents.Add
("\\server\faelles\Index\dokumenter\Epikriseskabelon\Epikrise.dot")

Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook

    Set xlApp = CreateObject("Excel.Application")
    xlApp.ScreenUpdating = False
    WB = sPath & Cprnr & ".opr"
    Set xlWB = xlApp.Workbooks.Open(WB)

    With ActiveDocument
        .Bookmarks("Navn").Range.Text =
xlWB.Worksheets("Stamkort").Range("D6").Value
        .Bookmarks("Cpr").Range.Text = Cprnr
        .Bookmarks("Adr").Range.Text =
xlWB.Worksheets("Stamkort").Range("D8").Value
        .Bookmarks("PostBy").Range.Text =
xlWB.Worksheets("Stamkort").Range("D9").Value
        .Bookmarks("Hcv").Range.Text =
xlWB.Worksheets("Stamkort").Range("M6").Value
    End With

    xlWB.Close False ' close the workbook without saving
    xlApp.Quit ' close the Excel application
    Set xlWB = Nothing
    Set xlApp = Nothing

    Selection.MoveDown Unit:=wdLine, Count:=2000

    Selection.TypeParagraph
    Selection.TypeParagraph
    Selection.TypeParagraph
    Selection.TypeParagraph
    Selection.TypeParagraph
    Selection.TypeParagraph
    Selection.TypeParagraph
    Selection.TypeParagraph
    Selection.TypeParagraph
    Selection.TypeParagraph
    Selection.TypeParagraph
    Selection.TypeParagraph
    Selection.TypeParagraph
    Selection.TypeParagraph
    Selection.TypeParagraph
    Selection.TypeParagraph
    Selection.TypeParagraph

    Selection.PasteAndFormat (wdPasteDefault)

    Selection.MoveUp Unit:=wdLine, Count:=2000

    AD.Close False

        'Så skal dokumentet gemmes med indholdet af cpr variable som filnavn
    ActiveDocument.SaveAs FileName:=pPath & Epi

End Sub