VB Mail + Redemption

Er det dig selv, der skal bruge det eller er det til en kunde/kolleger? For hvis det er til dig selv, kan du jo slå sikkerhedsindstillingen fra, så Outlook ikke kommer og spørger om adgang (jeg går ud fra, at det er den, du gerne vil uden om, ikk'?).

Hvis det ikke er en gangbar vej, hvad så med at smide dine variabler (modtager, subject osv.) ned som variabler i OutlookRedemption som Optional? Så kan du bygge proceduren op, så du kan bruge den både med variabler og med de "faste" ting, som du allerede har i proceduren. Og så selvfølgelig fjerne "mail-delen" fra bygMail.

Det er til eget brug... men har prøvet at fjerne den sikkerheds. men det er ikke noget man selv kan gå ind og gøre uden en vb kode.

Har selv prøvet at bygge dem sammen men det er uden helt... kan ikke få dem til at hænge sammen...

Joeh, det kan godt slås fra - har da tidligere selv gjort det, men kan ikke lige finde den rigtige MS-artikel nu.

Jeg har ikke gennemgået din kode minutiøst eller testet nedenstående, men jeg forestillede mig noget i denne stil (har ikke medtaget SendEmail-proceduren; kan ikke lige se, hvor den passer ind/bliver brugt; det ved du bedre end jeg).

*************
Sub OutlookRedemption(strRecipients as optional, strAttachment as optional, strSubject as optional, strBody as optional)
    Dim oOutlook, SafeItem, oItem
    Set oOutlook = CreateObject("Outlook.application")
    Set SafeItem = CreateObject("Redemption.SafeMailItem")
    Set oItem = oOutlook.CreateItem(0)
    SafeItem.Item = oItem

    if strRecipients <> ”” then
        SafeItem.Recipients.Add strRecipients
        SafeItem.Subject = strSubject
        SafeItem.Body = strBody
    else
        SafeItem.Recipients.Add "Bruger@Domæne.dk"
        SafeItem.Subject = ""
    End If
    SafeItem.Recipients.ResolveALL
    SafeItem.Display
End Sub


Private Sub bygMail(r)
  Dim MSG As String
  Dim Email As String
  Dim Subj As String
  Dim Disk As String, Filnavn As String
  Dim x As Long

  Disk = "\\server\Test\log\" & Format(Now(), "dddd") & "\"
  Filnavn = ".pdf"

  Email = Cells(r, 30)
  Subj = ""

  MSG = "Hey " & Cells(r, 3) & vbCrLf

mailThis.Attachments.Add Disk & Format(Now(), "yyyy") & Filnavn

  For x = 1 To 1
        MSG = MSG & "" & vbCrLf
Next

    call OutlookRedemption(Email, Disk & Format(Now(), "yyyy") & Filnavn, Subj, MSG)

End Sub

*************
Jeg har fjernet dit ChDir - det er ikke nødvendigt at skifte bibliotek. Det er nok at "strikke" strengen med filnavnet sammen. Er det til testforsøg, at du har For x = 1 to 1?

Den her linje er rød
Sub OutlookRedemption(strRecipients as optional, strAttachment as optional, strSubject as optional, strBody as optional)
tænker der mangler noget...

Sorry, min hjerne står vist på ferietid.

Sub OutlookRedemption(Optional strRecipients as string, Optional strAttachment as string, Optional strSubject as string, Optional strBody as string)

Det havde jeg også lavet den om til...
Men der virker vist ikke efter hensigt,

Men det kan være man lige skal se koden som den er...


På arket henter den mailadresserne og hvilken filer den skal sende med på mailen.
Min kode som den er nu ser sådan her ud...
'---------------------------------------------------
Option Explicit
Sub SendEMail()
Dim Email As String, Subj As String
Dim MSG As String, URL As String
Dim r As Integer
If Format(Now(), "D") > Format(Now() + 1, "D") Then
  Cells(2, 30) = "1"
Else
  Cells(2, 30) = ""
End If
For r = 4 To 35
  Email = Cells(r, 30)
  If Cells(r, 3) <> "" Then
    If Cells(r, 2) <> "" And Cells(r, 29) <> "" And Cells(r, 30) <> "" Then
      bygMail r
    ElseIf Cells(r, 2) = "" And Cells(r, 3) <> "" Then
      MsgBox Cells(r, 3) & "" & vbCrLf & ""
      Cells(r, 2).Interior.ColorIndex = 3
    ElseIf Cells(r, 29) = "" And Cells(r, 3) <> "" Then
      MsgBox Cells(r, 3) & "" & vbCrLf & ""
      Cells(r, 29).Interior.ColorIndex = 3
    End If
  End If
Next r
End Sub
'---------------------------------------------------
Private Sub bygMail(r)
Dim mailThis As Outlook.MailItem
Dim MSG As String, Email As String, Subj As String, Disk As String, Filnavn As String
Disk = "\\server\Data\" & Format(Now(), "dddd") & "\"
Filnavn = ".pdf"
Vv1 = "Vi"
Kl1 = "KL"
Kl2 = "wL"
Kl3 = "wsL"
Kv1 = "V"
Kv2 = "wV"
Kv3 = "wsV"
Ms1 = "BT. "
Ms2 = "AT. "
Ms3 = "D. "
Ms4 = "S. "
MsH1 = "FT. "
MsH2 = "AT. "
MsH3 = "TT. "
MsH4 = "FTV. "
Fr = " FR ": Ti = " Ti "
C1 = "Bn": C2 = "T": C3 = "D": C4 = "R"
'---------------------------------------------------
Set mailThis = CreateItem(olMailItem)
Email = Cells(r, 30)
Subj = "" & "" & Cells(r, 4) & ": " & Cells(r, 5) & ", " & Cells(r, 11) & ", " & Cells(r, 17) & ", " & Cells(r, 23) & ". Til /" & Format(Now() + 1, "dddd dd mmmm yyyy") & "\ Sendt " & Format(Now(), "dddd mmmm yy hh:mm")

  MSG = "Hey " & Cells(r, 3) & vbCrLf
If (Cells(r, 2)) <> "" Then
  MSG = MSG & "" & Format(Cells(r, 2), "hh:mm") & "" & Format(Cells(r, 29), "hh:mm") & vbCrLf & vbCrLf
End If
If (Cells(1, 4)) <> "" Then
  MSG = MSG & Cells(1, 4) & vbCrLf & vbCrLf
End If
If (Cells(2, 4)) <> "" Then
  MSG = MSG & Cells(2, 4) & vbCrLf & vbCrLf
End If
If (Cells(r, 1)) <> "" Then
  MSG = MSG & Cells(r, 1) & vbCrLf & vbCrLf
End If
'---------------------------------------------------
Select Case (Cells(r, 5))
  Case C1
    MSG = MSG & Ms1 & Fr & Format(Cells(r, 6), "hh:mm") & " " & Cells(r, 7) & Ti & Format(Cells(r, 8), "hh:mm") & " " & Cells(r, 9) & vbCrLf
  Case C2
    MSG = MSG & Ms2 & Fr & Format(Cells(r, 6), "hh:mm") & " " & Cells(r, 7) & Ti & Format(Cells(r, 8), "hh:mm") & " " & Cells(r, 9) & vbCrLf
  Case C3
    MSG = MSG & Ms3 & Fr & Format(Cells(r, 6), "hh:mm") & " " & Cells(r, 7) & Ti & Format(Cells(r, 8), "hh:mm") & " " & Cells(r, 9) & vbCrLf
  Case C4
    MSG = MSG & Ms4 & Fr & Format(Cells(r, 6), "hh:mm") & " " & Cells(r, 7) & Ti & Format(Cells(r, 8), "hh:mm") & " " & Cells(r, 9) & vbCrLf
  Case 11 To 35
    MSG = MSG & MsH1 & Cells(r, 5) & Fr & Format(Cells(r, 6), "hh:mm") & " " & Cells(r, 7) & Ti & Format(Cells(r, 8), "hh:mm") & " " & Cells(r, 9) & vbCrLf
    If Dir(Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 5) & Kl1 & Filnavn) <> "" Then
      If Dir(Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 5) & Kv1 & Filnavn) <> "" Then
        mailThis.Attachments.Add Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 5) & Kl1 & Filnavn
        mailThis.Attachments.Add Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 5) & Kv1 & Filnavn
      Else
        mailThis.Attachments.Add Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 5) & Kl1 & Filnavn
      End If
    Else
      If Dir(Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 5) & Kl2 & Filnavn) <> "" Then
        If Dir(Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 5) & Kv2 & Filnavn) <> "" Then
          mailThis.Attachments.Add Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 5) & Kl2 & Filnavn
          mailThis.Attachments.Add Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 5) & Kv2 & Filnavn
        Else
          mailThis.Attachments.Add Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 5) & Kl2 & Filnavn
        End If
      Else
        If Dir(Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 5) & Kl3 & Filnavn) <> "" Then
          If Dir(Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 5) & Kv3 & Filnavn) <> "" Then
            mailThis.Attachments.Add Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 5) & Kl3 & Filnavn
            mailThis.Attachments.Add Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 5) & Kv3 & Filnavn
          Else
            mailThis.Attachments.Add Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 5) & Kl3 & Filnavn
          End If
        End If
      End If
    End If
  Case Else
End Select
'---------------------------------------------------
Select Case (Cells(r, 11))
  Case C1
    MSG = MSG & Ms1 & Fr & Format(Cells(r, 12), "hh:mm") & " " & Cells(r, 13) & Ti & Format(Cells(r, 14), "hh:mm") & " " & Cells(r, 15) & vbCrLf
  Case C2
    MSG = MSG & Ms2 & Fr & Format(Cells(r, 12), "hh:mm") & " " & Cells(r, 13) & Ti & Format(Cells(r, 14), "hh:mm") & " " & Cells(r, 15) & vbCrLf
  Case C3
    MSG = MSG & Ms3 & Fr & Format(Cells(r, 12), "hh:mm") & " " & Cells(r, 13) & Ti & Format(Cells(r, 14), "hh:mm") & " " & Cells(r, 15) & vbCrLf
  Case C4
    MSG = MSG & Ms4 & Fr & Format(Cells(r, 12), "hh:mm") & " " & Cells(r, 13) & Ti & Format(Cells(r, 14), "hh:mm") & " " & Cells(r, 15) & vbCrLf
  Case 11 To 35
    MSG = MSG & MsH2 & Cells(r, 11) & Fr & Format(Cells(r, 12), "hh:mm") & " " & Cells(r, 13) & Ti & Format(Cells(r, 14), "hh:mm") & " " & Cells(r, 15) & vbCrLf
    If Dir(Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 11) & Kl1 & Filnavn) <> "" Then
      If Dir(Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 11) & Kv1 & Filnavn) <> "" Then
        mailThis.Attachments.Add Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 11) & Kl1 & Filnavn
        mailThis.Attachments.Add Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 11) & Kv1 & Filnavn
      Else
        mailThis.Attachments.Add Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 11) & Kl1 & Filnavn
      End If
    Else
      If Dir(Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 11) & Kl2 & Filnavn) <> "" Then
        If Dir(Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 11) & Kv2 & Filnavn) <> "" Then
          mailThis.Attachments.Add Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 11) & Kl2 & Filnavn
          mailThis.Attachments.Add Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 11) & Kv2 & Filnavn
        Else
          mailThis.Attachments.Add Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 11) & Kl2 & Filnavn
        End If
      Else
        If Dir(Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 11) & Kl3 & Filnavn) <> "" Then
          If Dir(Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 11) & Kv3 & Filnavn) <> "" Then
            mailThis.Attachments.Add Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 11) & Kl3 & Filnavn
            mailThis.Attachments.Add Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 11) & Kv3 & Filnavn
          Else
            mailThis.Attachments.Add Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 11) & Kl3 & Filnavn
          End If
        End If
      End If
    End If
  Case Else
End Select
'---------------------------------------------------
Select Case (Cells(r, 17))
  Case C1
    MSG = MSG & Ms1 & Fr & Format(Cells(r, 18), "hh:mm") & " " & Cells(r, 19) & Ti & Format(Cells(r, 20), "hh:mm") & " " & Cells(r, 21) & vbCrLf
  Case C2
    MSG = MSG & Ms2 & Fr & Format(Cells(r, 18), "hh:mm") & " " & Cells(r, 19) & Ti & Format(Cells(r, 20), "hh:mm") & " " & Cells(r, 21) & vbCrLf
  Case C3
    MSG = MSG & Ms3 & Fr & Format(Cells(r, 18), "hh:mm") & " " & Cells(r, 19) & Ti & Format(Cells(r, 20), "hh:mm") & " " & Cells(r, 21) & vbCrLf
  Case C4
    MSG = MSG & Ms4 & Fr & Format(Cells(r, 18), "hh:mm") & " " & Cells(r, 19) & Ti & Format(Cells(r, 20), "hh:mm") & " " & Cells(r, 21) & vbCrLf
  Case 11 To 35
    MSG = MSG & MsH3 & Cells(r, 17) & Fr & Format(Cells(r, 18), "hh:mm") & " " & Cells(r, 19) & Ti & Format(Cells(r, 20), "hh:mm") & " " & Cells(r, 21) & vbCrLf
    If Dir(Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 17) & Kl1 & Filnavn) <> "" Then
      If Dir(Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 17) & Kv1 & Filnavn) <> "" Then
        mailThis.Attachments.Add Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 17) & Kl1 & Filnavn
        mailThis.Attachments.Add Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 17) & Kv1 & Filnavn
      Else
        mailThis.Attachments.Add Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 17) & Kl1 & Filnavn
      End If
    Else
      If Dir(Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 17) & Kl2 & Filnavn) <> "" Then
        If Dir(Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 17) & Kv2 & Filnavn) <> "" Then
          mailThis.Attachments.Add Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 17) & Kl2 & Filnavn
          mailThis.Attachments.Add Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 17) & Kv2 & Filnavn
        Else
          mailThis.Attachments.Add Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 17) & Kl2 & Filnavn
        End If
      Else
        If Dir(Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 17) & Kl3 & Filnavn) <> "" Then
          If Dir(Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 17) & Kv3 & Filnavn) <> "" Then
            mailThis.Attachments.Add Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 17) & Kl3 & Filnavn
            mailThis.Attachments.Add Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 17) & Kv3 & Filnavn
          Else
            mailThis.Attachments.Add Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 17) & Kl3 & Filnavn
          End If
        End If
      End If
    End If
  Case Else
End Select
'---------------------------------------------------
Select Case (Cells(r, 23))
  Case C1
    MSG = MSG & Ms1 & Fr & Format(Cells(r, 24), "hh:mm") & " " & Cells(r, 25) & Ti & Format(Cells(r, 26), "hh:mm") & " " & Cells(r, 27) & vbCrLf
  Case C2
    MSG = MSG & Ms2 & Fr & Format(Cells(r, 24), "hh:mm") & " " & Cells(r, 25) & Ti & Format(Cells(r, 26), "hh:mm") & " " & Cells(r, 27) & vbCrLf
  Case C3
    MSG = MSG & Ms2 & Fr & Format(Cells(r, 24), "hh:mm") & " " & Cells(r, 25) & Ti & Format(Cells(r, 26), "hh:mm") & " " & Cells(r, 27) & vbCrLf
  Case C4
    MSG = MSG & Ms4 & Fr & Format(Cells(r, 24), "hh:mm") & " " & Cells(r, 25) & Ti & Format(Cells(r, 26), "hh:mm") & " " & Cells(r, 27) & vbCrLf
  Case 11 To 35
    MSG = MSG & MsH4 & Cells(r, 23) & Fr & Format(Cells(r, 24), "hh:mm") & " " & Cells(r, 25) & Ti & Format(Cells(r, 26), "hh:mm") & " " & Cells(r, 27) & vbCrLf
  If Dir(Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 23) & Kl1 & Filnavn) <> "" Then
    If Dir(Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 23) & Kv1 & Filnavn) <> "" Then
      mailThis.Attachments.Add Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 23) & Kl1 & Filnavn
      mailThis.Attachments.Add Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 23) & Kv1 & Filnavn
    Else
      mailThis.Attachments.Add Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 23) & Kl1 & Filnavn
    End If
  Else
    If Dir(Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 23) & Kl2 & Filnavn) <> "" Then
      If Dir(Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 23) & Kv2 & Filnavn) <> "" Then
        mailThis.Attachments.Add Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 23) & Kl2 & Filnavn
        mailThis.Attachments.Add Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 23) & Kv2 & Filnavn
      Else
        mailThis.Attachments.Add Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 23) & Kl2 & Filnavn
      End If
    Else
      If Dir(Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 23) & Kl3 & Filnavn) <> "" Then
        If Dir(Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 23) & Kv3 & Filnavn) <> "" Then
          mailThis.Attachments.Add Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 23) & Kl3 & Filnavn
          mailThis.Attachments.Add Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 23) & Kv3 & Filnavn
        Else
          mailThis.Attachments.Add Disk & Format(Now(), "yyyy") & Format(Now() + Cells(2, 30), "mm") & Format(Now() + 1, "dd") & Vv1 & Cells(r, 23) & Kl3 & Filnavn
        End If
      End If
    End If
  End If
  Case Else
End Select
'---------------------------------------------------
MSG = MSG & "" & vbCrLf
MSG = MSG & "" & vbCrLf & vbCrLf
MSG = MSG & Cells(5, 33) & vbCrLf
MSG = MSG & Cells(6, 33) & vbCrLf
MSG = MSG & Cells(7, 33) & vbCrLf
MSG = MSG & Cells(8, 33) & vbCrLf
MSG = MSG & Cells(9, 33) & vbCrLf
MSG = MSG & Cells(10, 33) & vbCrLf
MSG = MSG & Cells(12, 33) & vbCrLf
MSG = MSG & Cells(13, 33) & vbCrLf
MSG = MSG & Cells(14, 33) & vbCrLf
MSG = MSG & Cells(15, 33) & vbCrLf
'---------------------------------------------------
If Application.Wait(Now + TimeValue("0:00:03")) Then
'MsgBox "Mail til " & Cells(r, 3) & " Klar"
Cells(r, 30).Interior.ColorIndex = 4
End If
'---------------------------------------------------
mailThis.Recipients.Add Email
mailThis.Subject = Subj
mailThis.Body = MSG
mailThis.Display 'mailThis.Save 'mailThis.Send
End Sub

Kan du ikke i stedet fortælle mig, hvad det er, der ikke virker efter hensigten? Jeg vil gerne hjælpe, men jeg er ikke helt hooked på at sidde og kigge alle dine kodelinjer igennem.

Sorry,
PÅ mit ark i AD4:AD35 Finder den mailadresserne
For r = 4 To 35
  Email = Cells(r, 30)
Next r
Hvis der er en mailadresser
skal den lave en mail ud for hver række, med mailadresser
De filer og den tekst som den skal sende med står også på det ark, ud for hver række.

Så hvis Ad4"cells(r,30)" har en mailadresser, skal den ud fra værdien i E4:K4:Q4:W4 finder den navnene på de filer som den skal sende med. og cellerne i mellem er teksten den sender med,

Den sidste mappe er dagen i dag
Disk = "\\server\Data\" & Format(Now(), "dddd") & "\"

filendelsen er fast ".pdf"

Men filhavnet er dagen i morgen "DD" og måned "MM" , år"YYYY" + fast tekst og E4:K4:Q4:W4 og filendelsen.

den stopper ved "mailThis.Attachments.Add Disk & Filnavn
Der er mange if og if else osv.
Filen = "\\server\Data\Fredag\2007Fast tekst5.pdf"
Disk & Format(Now(), "YYYY") &"Fast tekst" Cells(r, 10) & Filnavn

Den laver mailen hvis jeg fjerner mailThis.Attachments.Add
men ikke for hver række.

så den kan ikke finde ud af at vedhæfte filerne.
eller gøre det ud for hver række..

jeg har lige prøvet dette her...
Det er bare at få vedhæftede de filer så vil det virke...

MSG = A2:A5
Subj = B2:B5
Filmane = C2:C5
Email = D2:D5
Men den stopper stadig ved "mailThis.Attachments.Add"

/Run-time error '424':
/Object reguired

*OutlookRedemption er som du lavet den!!

Private Sub bygMail()
Dim MSG As String
Dim Email As String
Dim Subj As String
Dim Disk As String, Filnavn As String
Dim r As Integer
For r = 2 To 5
Disk = "C\Test\" & Format(Now(), "dddd") & "\"
Filtype = ".pdf"
Filname = Cells(r, 3)
Email = Cells(r, 4)
Subj = Cells(r, 2)
MSG = "Hey " & Cells(r, 1) & vbCrLf
mailThis.Attachments.Add Disk & Format(Now(), "yyyy") & Filname & Filtype
Call OutlookRedemption(Email, Disk & Format(Now(), "yyyy") & Filnavn & Filtype, Subj, MSG)
Next r
End Sub

Jamen, det er da også galt ;-) Den skal jo ikke vedhæfte en fil til en mail, der ikke eksisterer i proceduren. Alt vedr. mail skal fjernes fra bygMail - ergo skal linjen mailThis.... osv også væk. Jeg kan godt se, at jeg ikke fik den fjernet. Ud med den. Din fil skal først vedhæftes i OutlookRedemption, hvor du danner selve mailen.

ps! Jeg ved ikke, hvad du mener med 2 udråbstegn efter hinanden, men de har en ret voldsom effekt på mig, og den er ikke positiv. Jeg forsøger faktisk at hjælpe dig.

Arr det var ikke ment på nogle måde andet end at vise hvor jeg har smide
OutlookRedemption koden du har fikset... ikke andet.. og jah jeg er meget taknemmelig for din hjælp..
Så det er ikke ment på en voldsom måde,

Okay - jeg er bare lidt sensitiv omkring ! :-)

Men hvor står vi så nu?

vi skal have den til at vedhæfte filer...

jeg har alt fra 0 til 8 filer som skal vædhæftede på mailen..

fil sæt 1 til 4 hvert sæt kan have ingen eller på til 2 filer ud fra værdien i cellen.
If case = a, b, c, d,'skal det ikke være nogle vædhæftning.
If case = 11 to 35'skal den køre if.
If fil x = f1 'vædhæft fil
If fil x = f2 'vædhæft fil
If fil x = f3 'vædhæft fil
-----
Det vil den gøre for hver række,

Reelt skal vi jo bare have lavet et loop af en slags i OutlookRedemption-proceduren.

Hvor har du navnene på de filer, der skal vedhæftes (hvis der skal vedhæftes nogen)?

Filerne er byggede op efter dato og tekst

Der er 4 cases som finder ud af om der er filer som skal vedhæftes
Select Case (Cells(r, 5))
Select Case (Cells(r, 11))
Select Case (Cells(r, 17))
Select Case (Cells(r, 23))

Ud fra hver Case finder den ud af om det er en file eller 2 filer par case.
Det vil sige for hver række/"Mail" kan der være mellem 1 og 8 filer som skal vedhæftes, alle filerne vil have hvert sit navn.. ud for de kolonner med nr, i cellerne.

F. eks
Hvis "20070508Vv112Kv1.pdf" <> "": Skal den vedhæfte "20070508Vv112Kl1.pdf"
Ellers skal den vedhæfte
"20070508Vv112Kv1.pdf" og "20070508Vv112Kl1.pdf"

Du kunne så lave et array med det/de filnavne, som skal vedhæftes (husk at det skal være HELE filnavnet), som du sender med i OutlookRedemption i stedet for den ene string, som jeg har bygget den op med. Derefter kan du - i OutlookRedemption - loope dit array igennem og vedhæfte hver enkelt fil.

Hvis du ikke ved, hvordan du får strikket et array sammen, vil jeg i stedet foreslå, at du laver en string med alle filnavnene adskilt af f.eks. et #. Den kan du så sende med i OutlookRedemption via den eksisterende string.

Giv mig lige en melding på hvilken en af metoderne, du vil bruge, hvis du har behov for, at jeg hjælper dig videre.

kom med et svar her ikke haft tiden til at fikse det..

Svar