Mail sheet as outlook body

wiki · 8 jun 2009

De bijlage is een verzameldocument van meldingen. De meldingen worden automatisch met VBA in Verzamel gekopieerd. In het blad verzamel worden de meldingen geupdate en vervolgens als outlookbody verzonden naar de melder.

Deze functie werkte goed, maar opeens krijg ik geen outlookbody als in cel c2 een volgnummer geselecteerd wordt.

Resume, c2 waarde "selecteer vogorde" klik verwerken = gewenste mail
c2 volgnummer geselecteerd outlookbody is leeg

Wie heeft een oplossing of weet wat fout gaat???

snb · 8 jun 2009

Zet in een function geen bewerkingen die niets met de funktie te maken hebben (jouw log-verhaal) en in een mactro (sub) thuishoren.

Vermijd Select en activate in VBA, overbodig, vertragend en verwarrend (zoals in jouw geval)

Kopieer en plak alleen code die je zelf begrijpt.
Voorbeeld: deze code doet hetzelfde als wat jij gebruikt:

Code:

Sub Mail_Sheet_Outlook_Body()
    On Error Resume Next
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
 
    With CreateObject("Outlook.Application").CreateItem(0)
        .To = [lijst!c3]
        .CC = ""
        .BCC = ""
        .Subject = "Reactie op " & [lijst!c6] & " volgnummer " & [lijst!c2]
        .HTMLBody = RangetoHTML(Sheets("lijst").UsedRange)
        .display
    End With
 
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

wiki · 8 jun 2009

SNB

Inderdaad knip en plak ik veel, maar het resultaat is leidend. Begrijp er vaak geen snars van dus met trial on error (en hulp) kom je toch steeds een stukje verder .
Ik heb je code gebruikt en het logverhaal verplaatst. Ik heb het idee dat het nu werkt, maar zal moeten testen.

Kan het nu je goedkeuring krijgen

Code:

Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2007
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
  ActiveSheet.Unprotect Password:=""
    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
 
    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
 
    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
 
    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
 
    'Close TempWB
    TempWB.Close savechanges:=False
 
    'Delete the htm file we used in this function
    Kill TempFile
 
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
   

End Function

 Sub Mail_Sheet_Outlook_Body()
   ActiveSheet.Unprotect Password:=""
    Range("d15").Formula = "=Now()"
    Range("d15").Value = Range("d15").Value

'log bijwerken
Sheets("Log").Select
     ActiveSheet.Unprotect Password:=""

    Rows("2:2").Select
    Selection.Insert Shift:=xlDown
    Selection.Font.ColorIndex = 0
    Selection.Interior.ColorIndex = xlNone
    Selection.Font.Bold = False
    Range("A2").FormulaR1C1 = "=Formulier!RC[2]"
    Range("B2").FormulaR1C1 = "=Formulier!R[13]C[1]"
    Range("C2").FormulaR1C1 = "=Formulier!R[13]C[1]"
    Range("D2").FormulaR1C1 = "=Formulier!R[14]C[-1]"
    Range("E2").FormulaR1C1 = "=Formulier!R[14]C[-1]"
    Range("F2").FormulaR1C1 = "=Formulier!R[15]C[-3]"
    Range("G2").FormulaR1C1 = "=Formulier!R[15]C[-3]"
    Range("H2").FormulaR1C1 = "=Formulier!R[16]C[-5]"
    Range("I2").FormulaR1C1 = "=Formulier!R[16]C[-5]"
    Rows("2:2").Value = Rows("2:2").Value
    ActiveSheet.Protect Password:=""
   
    'nieuwe waarden copieren naar lijst
    Range("D15:D18").Copy
    Set PN = Worksheets("Lijst").Range("Volgnummer").Find(Range("c2").Value, LookIn:=xlValues, lookat:=xlWhole)
If Not PN Is Nothing Then
    Worksheets("Lijst").Unprotect Password:=""
    Worksheets("Lijst").Range("M" & PN.row & ":P" & PN.row).PasteSpecial , Values:=True
    Worksheets("Lijst").Protect Password:=""
End If
Application.CutCopyMode = False
Range("a1").Select
    On Error Resume Next
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
 
    With CreateObject("Outlook.Application").CreateItem(0)
        .To = [lijst!c3]
        .CC = ""
        .BCC = ""
        .Subject = "Reactie op " & [lijst!c6] & " volgnummer " & [lijst!c2]
        .HTMLBody = RangetoHTML(Sheets("formulier").UsedRange)
        .display
    End With
 
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
    Range("D16:D18").ClearContents
  
    Range("c2").Value = "Selecteer volgnummer uit lijst"
    ActiveSheet.Protect Password:=""
End Sub

gr wim

wiki · 8 jun 2009

De html outlookbody loopt nu prima

Bedankt SNB

Poging om de code netjes te krijgen:

Code:

 Sub Mail_Sheet_Outlook_Body()
   ActiveSheet.Unprotect Password:=""
    Range("d15").Formula = "=Now()"
    Range("d15").Value = Range("d15").Value

'log bijwerken
With Sheets("log")
    .Unprotect Password:=""
    .Rows("2:2").Insert Shift:=xlDown
    .Rows("2:2").Font.ColorIndex = 0
    .Rows("2:2").Interior.ColorIndex = 0
    .Rows("2:2").Font.Bold = False
    .Range("A2").Value = "=Formulier!c2"
    .Range("B2").Value = "=Formulier!c15"
    .Range("C2").Value = "=Formulier!d15"
    .Range("D2").Value = "=Formulier!c16"
    .Range("E2").Value = "=Formulier!d16"
    .Range("F2").Value = "=Formulier!c17"
    .Range("G2").Value = "=Formulier!d17"
    .Range("H2").Value = "=Formulier!c18"
    .Range("I2").Value = "=Formulier!d18"
    .Rows("2:2").Value = Sheets("log").Rows("2:2").Value
    .Protect Password:=""
End With
    
    'nieuwe waarden copieren naar lijst
    Worksheets("formulier").Range("D15:D18").Copy
    Set PN = Worksheets("Lijst").Range("Volgnummer").Find(Range("c2").Value, LookIn:=xlValues, lookat:=xlWhole)
If Not PN Is Nothing Then
    Worksheets("Lijst").Unprotect Password:=""
    Worksheets("Lijst").Range("M" & PN.row & ":P" & PN.row).PasteSpecial , Values:=True
    Worksheets("Lijst").Protect Password:=""
End If

Application.CutCopyMode = False
Range("a1").Select
    On Error Resume Next
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
 
    With CreateObject("Outlook.Application").CreateItem(0)
        .To = [formulier!c3]
        .CC = ""
        .BCC = ""
        .Subject = "Reactie op " & [formulier!c6] & " volgnummer " & [formulier!c2]
        .HTMLBody = RangetoHTML(Sheets("formulier").UsedRange)
        .display
    End With
 
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
    Worksheets("formulier").Range("D16:D18").ClearContents
  
    Worksheets("formulier").Range("c2").Value = "Selecteer volgnummer uit lijst"
    ActiveSheet.Protect Password:=""
End Sub

krijg alleen de volgende bijdrage van Roncancio niet meer werkend:

Code:

 'nieuwe waarden copieren naar lijst
    Worksheets("formulier").Range("D15:D18").Copy
    Set PN = Worksheets("Lijst").Range("Volgnummer").Find(Range("c2").Value, LookIn:=xlValues, lookat:=xlWhole)
If Not PN Is Nothing Then
    Worksheets("Lijst").Unprotect Password:=""
    Worksheets("Lijst").Range("M" & PN.row & ":P" & PN.row).PasteSpecial , Values:=True
    Worksheets("Lijst").Protect Password:=""
End If

Iemand een idee?

gr Wim

snb · 8 jun 2009

Code:

Sub Mail_Sheet_Outlook_Body()
   with Sheets("lijst")
     .Unprotect Password:=""
     .Range("d15") = format(Date,"dd-mm-yyyy hh:mm:ss")
   end with

'log bijwerken
With Sheets("log")
    .Unprotect Password:=""
    .Rows(2).Insert Shift:=xlDown
    with .Rows(2)
       .Font.ColorIndex = 0
       .Interior.ColorIndex = 0
       .Font.Bold = False
    end with
 
    [Formulier!C2].copy .Range("A2")
    For j =1 to 4
       [Formulier!C14].offset(j).resize(,2).copy .cells(2,2*j)
    next
    .Rows(2).Value = .Rows(2).Value
    .Protect Password:=""
End With
    
    on error resume next
    With Sheets("Lijst")
      .Unprotect Password:=""
      [formulier!D15:D18].Copy .cells(.range("Volgnummer").Find(.[A2]).row,13)
      .Protect Password:=""
    end with

wiki · 8 jun 2009

SNB ziet er strak uit:thumb:
Alleen de volgende code zet de aangepaste gegevens verticaal neer ipv horizontaal. De begincel is wel goed.

Code:

On Error Resume Next
    With Sheets("Lijst")
      .Unprotect Password:=""
      [formulier!D15:D18].Copy .Cells(.Range("Volgnummer").Find(.[A2]).row, 13)
      .Protect Password:=""
    End With

Ik heb het geprobeerd aan te vullen met

Code:

.transpose=true

, maar zonder het gewenste resultaat.

Wat ik mij verder afvraag is of ik bij de mail ook een attachment kan voegen. Ik heb dit geprobeerd met:

Code:

 .Attachments.Add = "c:\test"

, maar dat werkte niet. Heb jij een suggestie? Met deze regel is het wel gelukt om een bijlage te koppelen maar niet samen met een html outlookbody.

gr wim

wiki · 8 jun 2009

Probleem met wegschrijven in lijst is opgelost in de code van Roncancio had ik een fout gemaakt. Nu werkt deze prima

Code:

Set PN = Worksheets("Lijst").Range("Volgnummer").Find(Range("c2").Value, LookIn:=xlValues, lookat:=xlWhole)
If Not PN Is Nothing Then
    Range("D15:D18").Copy
    Worksheets("Lijst").Range("M" & PN.row & ":P" & PN.row).PasteSpecial , Transpose:=True
End If

Ik hoop dat iemand weet hoe ik ook een attachement kan toevoegen.

gr wim

Mail sheet as outlook body

wiki

Gebruiker

Bijlagen

snb

Verenigingslid

wiki

Gebruiker

wiki

Gebruiker

snb

Verenigingslid

wiki

Gebruiker

wiki

Gebruiker

Nieuwste berichten

Wij waarderen jouw privacy