Makro i Word

Hvor skulle mailadressen placeres?
- emne
- body
- eller??

Den skal placeres i til feltet.

Der kan skrives en VBA-rutine, der opbygger mailen med modtageradresse og sender inkl. vedhæftet fil.

Kunne du vise makroen?

Det er en lang fætter med se om du kan finde hoved og hale i den...

Modtager adressen er forskelling fra dokument til dokument, så det duer ikke at det er en fast mailto adresse.

Sub Gem_send_pdf()

   
'Gem dokument
ActiveDocument.Save

ActiveDocument.PageSetup.DifferentFirstPageHeaderFooter = True
'indsæt sidehoved og -fod
Const pPath As String = "U:\logo regnskab\14\"
Dim oAI As AddIn
Dim oTemplate As Template
Dim bAvailable As Boolean
Dim oHeader As HeaderFooter
Dim oFooter As HeaderFooter
bAvailable = False
'Determine if the template is available as an AddIn
For Each oAI In AddIns
  If oAI.Name = "Tester.dotx" Then
    bAvailable = True
    'Load it if not already loaded
    If oAI.Installed = False Then oAI.Installed = True
    Exit For
  End If
Next
'If not available then add it to the AddIn collection
If Not bAvailable Then
  AddIns.Add FileName:=pPath & "Tester.dotx", Install:=True
End If
Set oTemplate = Templates(pPath & "Tester.dotx")
Set oHeader = ActiveDocument.Sections(1).Headers(wdHeaderFooterFirstPage)
Set oFooter = ActiveDocument.Sections(1).Footers(wdHeaderFooterFirstPage)
oTemplate.BuildingBlockTypes(wdTypeHeaders).Categories("Generelt").BuildingBlocks("Hflc sidehoved").Insert Where:=oHeader.Range
oTemplate.BuildingBlockTypes(wdTypeFooters).Categories("Generelt").BuildingBlocks("Hflc side fod").Insert Where:=oFooter.Range


    On Error Resume Next

    'Verify if the docment has been saved before so that we have a path to work with.
    'If not, notify the user that there will be a safe dialog first.
    If ActiveDocument.Path <> "" Then
        ActiveDocument.Save
    Else
        Dim Msg, Style, Title, Response
        Msg = "This document has not been saved before." & vbLf & _
        "Please save the document to disk first." & vbLf & _
        "Without saving first, only the pdf-file will be attached."
        Style = vbInformation + vbOKOnly
        Title = "Save current presentation"
        Response = MsgBox(Msg, Style, Title)
       
        Dim dlgSaveAs As FileDialog
        Dim strCurrentFile As String
        Set dlgSaveAs = Application.FileDialog(msoFileDialogSaveAs)
       
        If dlgSaveAs.Show = -1 Then
            strCurrentFile = dlgSaveAs.SelectedItems(1)
            ActiveDocument.SaveAs (strCurrentFile)
        End If
        Set dlgSaveAs = Nothing
    End If

    'Get the name of the open file and strip any extension.
    Dim MyFile As String
    MyFile = ActiveDocument.Name
    intPos = InStrRev(MyFile, ".")
    If intPos > 0 Then
        MyFile = Left(MyFile, intPos - 1)
    End If

    'Get the user's TempFolder to store the created pdf item in.
    Dim FSO As Object, TmpFolder As Object
    Set FSO = CreateObject("scripting.filesystemobject")
    Set FileName = FSO.GetSpecialFolder(2)
   
    'Create the full path name for the pdf-file
    FileName = FileName & "\" & MyFile & ".pdf"

    'Save the current document as pdf in the user's temp folder.
    'Note that we are going to include the document properties as well.
    'If you do not want this set "IncludeDocProps" to False.
    ActiveDocument.ExportAsFixedFormat OutputFileName:= _
        FileName, ExportFormat:= _
        wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
        wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=0, To:=0, _
        Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
        CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
        BitmapMissingFonts:=True, UseISO19005_1:=False



    'Start Outlook if it isn't running.
    Set oOutlookApp = GetObject(, "Outlook.Application")
    If Err <> 0 Then
        Set oOutlookApp = CreateObject("Outlook.Application")
    End If

    'Create a new message.
    Set oItem = oOutlookApp.CreateItem(olMailItem)

    'Add the attachments.
    oItem.Attachments.Add FileName
    'oItem.Attachments.Add ActiveDocument.FullName

    'Show the message.
    oItem.Display
   
    'Cleanup
    Set FSO = Nothing
    Set FileName = Nothing
    Set oOutlookApp = Nothing
    Set oItem = Nothing
 
'gem som pdf
With ActiveDocument
  .ExportAsFixedFormat OutputFileName:=Split(.FullName, ".")(0) & ".pdf", _
  ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, _
  OptimizeFor:=wdExportOptimizeForPrint, Range:=wdExportAllDocument, _
  Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
  CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
  BitmapMissingFonts:=True, UseISO19005_1:=False
 
'fjern sidehoved og -fod
    If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
        ActiveWindow.Panes(2).Close
    End If
    If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
        ActivePane.View.Type = wdOutlineView Then
        ActiveWindow.ActivePane.View.Type = wdPrintView
    End If
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
    Selection.WholeStory
    Selection.Delete Unit:=wdCharacter, Count:=1
    If Selection.HeaderFooter.IsHeader = True Then
        ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
    Else
        ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
    End If
    Selection.WholeStory
    Selection.Delete Unit:=wdCharacter, Count:=1
    If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
        ActiveWindow.Panes(2).Close
    End If
    If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
        ActivePane.View.Type = wdOutlineView Then
        ActiveWindow.ActivePane.View.Type = wdPrintView
    End If
    ActiveDocument.Save
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument

Ok - lidt at se på.

@-adressen var heller ikke tænkt som en fast :-)

Godt skulle bare lige være sikker :-)

Ok..

Har ikke nærlæst koden endnu - men optræder mailadressen i denne?

Ellers skal den jo nok sendes dertil som parameter..

Nej mail adressen fremgår ikke af koden. Tænker at mailadressen skal indsættes i dokumentets øveste linie og så kopieres fra word og indsættes i mailen. Altså noget i stil med:

Selection.MoveUp unit:=wdLine, Count:=1024
Selection.MoveLeft unit:=wdLine, Count:=Line
Selection.MoveRight unit:=wdCharacter, Count:=Line, Extend:=wdExtend
Selection.MoveDown unit:=wdLine, Count:=1, Extend:=wdExtend
Selection.MoveLeft unit:=wdCharacter, Count:=1, Extend:=wdExtend
Selection.Copy


Men det kan også være at mailadressen skal stå i et felt som der så søges ud via scribtet

Tilføjelser er markeret med '<------- eller '<+++++++++

Dim mailAdresse As String                  '<----------------------------

Sub Gem_send_pdf()
Const pPath As String = "U:\logo regnskab\14\"
Dim oAI As AddIn
Dim oTemplate As Template
Dim bAvailable As Boolean
Dim oHeader As HeaderFooter
Dim oFooter As HeaderFooter

'hent mailadresse øverst i dokument
    mailAdresse = hentMailAdresse

'Gem dokument
    ActiveDocument.Save

    ActiveDocument.PageSetup.DifferentFirstPageHeaderFooter = True
'indsæt sidehoved og -fod
    bAvailable = False
'Determine if the template is available as an AddIn
    For Each oAI In AddIns
        If oAI.Name = "Tester.dotx" Then
          bAvailable = True
          'Load it if not already loaded
          If oAI.Installed = False Then oAI.Installed = True
          Exit For
        End If
    Next
   
'If not available then add it to the AddIn collection
    If Not bAvailable Then
        AddIns.Add FileName:=pPath & "Tester.dotx", Install:=True
    End If
   
    Set oTemplate = Templates(pPath & "Tester.dotx")
    Set oHeader = ActiveDocument.Sections(1).Headers(wdHeaderFooterFirstPage)
    Set oFooter = ActiveDocument.Sections(1).Footers(wdHeaderFooterFirstPage)
    oTemplate.BuildingBlockTypes(wdTypeHeaders).Categories("Generelt").BuildingBlocks("Hflc sidehoved").Insert Where:=oHeader.Range
    oTemplate.BuildingBlockTypes(wdTypeFooters).Categories("Generelt").BuildingBlocks("Hflc side fod").Insert Where:=oFooter.Range


    On Error Resume Next

'Verify if the docment has been saved before so that we have a path to work with.
'If not, notify the user that there will be a safe dialog first.
    If ActiveDocument.Path <> "" Then
        ActiveDocument.Save
    Else
        Dim Msg, Style, Title, Response
        Msg = "This document has not been saved before." & vbLf & _
        "Please save the document to disk first." & vbLf & _
        "Without saving first, only the pdf-file will be attached."
        Style = vbInformation + vbOKOnly
        Title = "Save current presentation"
        Response = MsgBox(Msg, Style, Title)
       
        Dim dlgSaveAs As FileDialog
        Dim strCurrentFile As String
        Set dlgSaveAs = Application.FileDialog(msoFileDialogSaveAs)
       
        If dlgSaveAs.Show = -1 Then
            strCurrentFile = dlgSaveAs.SelectedItems(1)
            ActiveDocument.SaveAs (strCurrentFile)
        End If
        Set dlgSaveAs = Nothing
    End If

'Get the name of the open file and strip any extension.
    Dim MyFile As String
    MyFile = ActiveDocument.Name
    intPos = InStrRev(MyFile, ".")
    If intPos > 0 Then
        MyFile = Left(MyFile, intPos - 1)
    End If

'Get the user's TempFolder to store the created pdf item in.
    Dim FSO As Object, TmpFolder As Object
    Set FSO = CreateObject("scripting.filesystemobject")
    Set FileName = FSO.GetSpecialFolder(2)
   
'Create the full path name for the pdf-file
    FileName = FileName & "\" & MyFile & ".pdf"

'Save the current document as pdf in the user's temp folder.
'Note that we are going to include the document properties as well.
'If you do not want this set "IncludeDocProps" to False.
    ActiveDocument.ExportAsFixedFormat OutputFileName:= _
        FileName, ExportFormat:= _
        wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
        wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=0, To:=0, _
        Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
        CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
        BitmapMissingFonts:=True, UseISO19005_1:=False

'Start Outlook if it isn't running.
    Set oOutlookApp = GetObject(, "Outlook.Application")
    If Err <> 0 Then
        Set oOutlookApp = CreateObject("Outlook.Application")
    End If

'Create a new message.
    Set oitem = oOutlookApp.CreateItem(olMailItem)

'modtageradresse                            '<--------
    Set nymod = oitem.Recipients            '<--------
    nymod.Add mailAdresse                  '<--------

'Add the attachments.
    oitem.Attachments.Add FileName
    'oItem.Attachments.Add ActiveDocument.FullName

'Show the message.
    oitem.Display
   
'Cleanup
    Set FSO = Nothing
    Set FileName = Nothing
    Set oOutlookApp = Nothing
    Set oitem = Nothing
 
'gem som pdf
    With ActiveDocument
        .ExportAsFixedFormat OutputFileName:=Split(.FullName, ".")(0) & ".pdf", _
        ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, _
        OptimizeFor:=wdExportOptimizeForPrint, Range:=wdExportAllDocument, _
        Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
        CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
        BitmapMissingFonts:=True, UseISO19005_1:=False
    End With
   
'fjern sidehoved og -fod
    If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
        ActiveWindow.Panes(2).Close
    End If
   
    If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
        ActivePane.View.Type = wdOutlineView Then
        ActiveWindow.ActivePane.View.Type = wdPrintView
    End If
   
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
    Selection.WholeStory
    Selection.Delete unit:=wdCharacter, Count:=1
   
    If Selection.HeaderFooter.IsHeader = True Then
        ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
    Else
        ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
    End If
   
    Selection.WholeStory
    Selection.Delete unit:=wdCharacter, Count:=1
   
    If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
        ActiveWindow.Panes(2).Close
    End If
   
    If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
        ActivePane.View.Type = wdOutlineView Then
        ActiveWindow.ActivePane.View.Type = wdPrintView
    End If
   
    ActiveDocument.Save
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End Sub
Private Function hentMailAdresse()                  '<+++++++++++++++
    Selection.MoveUp unit:=wdLine, Count:=1024
    Selection.MoveLeft unit:=wdLine, Count:=Line
    Selection.MoveRight unit:=wdCharacter, Count:=Line, Extend:=wdExtend
    Selection.MoveDown unit:=wdLine, Count:=1, Extend:=wdExtend
    Selection.MoveLeft unit:=wdCharacter, Count:=1, Extend:=wdExtend
   
    hentMailAdresse = Selection.Text
'  Selection.Copy
End Function

Okay tak for det. Jeg prøver lige at indsætte i morgen når jeg er på arbejde og ser om det er som ønsket, så hører du nærmere.

Selv tak - vi får se..

Det virker bare super. Det er virkeligt fedt. Du ligger bare et svar.

Vil lige høre om det også er muligt indsætte en adresse i bcc feltet. F.eks. fra 2.linie  i dokumentet.

Du får et svar..

Vender tilbage vedr. bcc

Man kunne vel egentligt indsætte begge mail adresser i bcc feltet, og så have begge mailadresser stående på øverste linie adskilt af et semikolon.

Der skal vel også være en adresse til Til-feltet - det kunne så være egen adresse?

Om igen - der behøver ikke være nogen i Til-feltet - så ja - det kunne man så..

Prøv at ændre til:

'modtageradresse                 
    Set nymod = oitem.BCCRecipients            '<--------

Når jeg ændrer det til bcc indsætter den ikke adresserne, men ændre jeg det tilbage til .recipients så indsættes begge adresser i til feltet.

Havde ikke testet  det - vender tilbage, hvis jeg finder en løsning..

Er testet = ok

'Start Outlook if it isn't running.
    Set oOutlookApp = GetObject(, "Outlook.Application")
    If Err <> 0 Then
        Set oOutlookApp = CreateObject("Outlook.Application")
    End If

'Create a new message.
    Set oitem = oOutlookApp.CreateItem(olMailItem)

'modtageradresse
    Set nymod = oitem.Recipients.Add(mailAdresse)  '<--------
    nymod.Type = olBCC                              '<--------
   
'Add the attachments.
    oitem.Attachments.Add FileName
    'oItem.Attachments.Add ActiveDocument.FullName

'Show the message.
    oitem.Display

Hmm jeg synes ikke at jeg kan få det til at lykkes. Du har ikke ændret i koden flere steder?

OBS: Prøv at sætte referencen til Outlook:

Alt+F11 / Tools / References / Microsoft Outlook xx Object Library (udpeges og markeres i listen - alfabetisk) - gem og luk..

Nå det hjalp desværre ikke. Den indsætter stadigvæk ikke.

Markeres modtager-adresser korrekt i dokumentet?
Gør såvel dokument & VBA-kode synlige

Alt+F11 - Thisdocument
Prøv at "steppe" gennem koden m/F8? Så vil du kunne følge "udviklingen".

Umiddelbart kan jeg ikke se nogen forskel når jeg kører de forskellig setups igennem med F8. Som jeg kan se det bliver øverste linie markeret i begge setups.

Hvis du er interesseret - vil jeg godt se på det via Teamviewer.

Du kan sende direkte mail - @-adresse under min profil.