Új hozzászólás Aktív témák

• #14699 zhari csendes tag lappy #14694

  Új Válasz 2012-08-22 14:16:24 #14699

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  zhari

  csendes tag

  válasz lappy #14694 üzenetére

  90%-ban sikerült. Pár módosítással:

  B oszlopból szedi a címeket. D-E oszlopokból a csatolmányokat.
  Abban tudnátok segíteni, hogy CC-be tegye a C oszlopban szereplő mail címet?

  Sub email_kuld()
  Dim OutApp As Object
  Dim OutMail As Object
  Dim sh As Worksheet
  Dim cell As Range, FileCell As Range, rng As Range

  With Application
  .EnableEvents = False
  .ScreenUpdating = False
  End With

  Set sh = Sheets("lista") 'munkalap neve

  Set OutApp = CreateObject("Outlook.Application")

  For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)

  Set rng = sh.Cells(cell.Row, 1).Range("D1:E1") 'D-E oszlopig a csatolmányok. Bármi lehet.ok

  If cell.Value Like "?*@?*.?*" And _
  Application.WorksheetFunction.CountA(rng) > 0 Then
  Set OutMail = OutApp.CreateItem(0)

  With OutMail
  .To = cell.Value
  .cc = "" 'CC-ket a C oszlopból kellene hivatkozni
  .Subject = "teszt tárgya " & cell.Offset(0, -1).Value & " 2013.01.02 riport" ' Tárgyat frissíteni.ok
  .Body = "Tisztelt " & cell.Offset(0, -1).Value & "!"

  For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
  If Trim(FileCell) <> "" Then
  If Dir(FileCell.Value) <> "" Then
  .Attachments.Add FileCell.Value
  End If
  End If
  Next FileCell

  .Send 'Or use Display.
  End With

  Set OutMail = Nothing
  End If
  Next cell

  Set OutApp = Nothing

  With Application
  .EnableEvents = True
  .ScreenUpdating = True
  End With
  MsgBox "E-mailek elküldve."
  End Sub

Új hozzászólás Aktív témák