12. september 2006 - 14:16Der er
61 kommentarer og 1 løsning
fiks vba kode vedhæft fil
er der ikke en som kan få denne kode til at virke så den vedhæfter filer
Private Declare Function ShellExecute Lib "shell32.dll" _ Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _ ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _ ByVal nShowCmd As Long) As Long Sub SendEMail() Dim Email As String, Subj As String Dim Msg As String, URL As String Dim r As Integer, x As Double Dim Disk As String, Filnavn As String Disk = C: ChDir Disk Filnavn = .pdf 'vedhæfted filer skal den finde i c:/text/ For r = 2 To 25 'data in rows 2-4 Rem Get the email address Email = Cells(r, 21)
If Cells(r, 21) <> "" Then bygMail r End If Next r End Sub Private Sub bygMail(r) Email = Cells(r, 21) ' Message subject Format(Cells(r, 2), "hh:mm:ss") Subj = "" & "" & Cells(r, 4) & "" & Cells(r, 10) & "" & Cells(r, 16) & "" & Format(Now() + 1, "dddd dd mmmm yyyy") & "" & Format(Now(), "dddd mmmm yy hh:mm")
If (Cells(r, 1)) <> "" Then Msg = Msg & vbCrLf & vbCrLf End If
Select Case (Cells(r, 4)) Case Is = "A" Msg = Msg & vbCrLf Case Is = "B" Msg = Msg & vbCrLf Case Is = "C" Msg = Msg & vbCrLf Case Is = "D" Msg = Msg & vbCrLf Case Is > 0 Msg = Msg & vbCrLf .Attachments.Add Disk & "/text/" & Cells(r, 4) & "a" & Filnavn .Attachments.Add Disk & "/text/" & Cells(r, 4) & "B" & Filnavn End Select
Select Case (Cells(r, 10)) Case Is = "A" Msg = Msg & vbCrLf Case Is = "B" Msg = Msg & vbCrLf Case Is = "C" Msg = Msg & vbCrLf Case Is > 0 Msg = Msg & vbCrLf 'Vedhæft fil her .Attachments.Add Disk & "/text/" & Cells(r, 10) & "a" & Filnavn .Attachments.Add Disk & "/text/" & Cells(r, 10) & "B" & Filnavn End Select
Select Case (Cells(r, 16)) Case Is = "A" Msg = Msg & vbCrLf Case Is = "B" Msg = Msg & vbCrLf Case Is = "C" Msg = Msg & vbCrLf Case Is > 0 Msg = Msg & vbCrLf 'Vedhæft fil her .Attachments.Add Disk & "/text/" & Cells(r, 16) & "a" & Filnavn .Attachments.Add Disk & "/text/" & Cells(r, 16) & "B" & Filnavn End Select
Sub SendEMail() Dim Email As String, Subj As String Dim MSG As String, URL As String Dim r As Integer, x As Double
'vedhæfted filer skal den finde i c:/text/ For r = 2 To 25 'data in rows 2-4 Rem Get the email address 'Email = Cells(r, 21) If Cells(r, 21) <> "" Then bygMail r End If Next r End Sub Private Sub bygMail(r) Dim mailThis As Outlook.MailItem Dim MSG As String Dim Email As String Dim Subj As String Dim Disk As String, Filnavn As String Dim x As Long Disk = C: ChDir Disk Filnavn = .pdf
akyhne Jeg har ikke faste filer der er hele tiden nye.
supertekst. nu er den men så og har fikset Disk = "C:" ChDir Disk Filnavn = ".pdf" men så køre koden men man kan ikke se om den har sendt noget i outlook!?
Som jeg forstår det: Hvis der står A, B, C eller D i celle B, skal der sendes en mail til adressen der står i U. Vedhæftede filer i D, J og P skal medsendes. Er det det?
Fra A2:T31 er der data og U2:U31 er opslageværdi fra B2:B31,
C, = Id nr D, J, P, = aktivitets Id som a, b, c, d, & tal, hver af dem giver sin egen "msg" men hvis tal skal den vedhæfte filer så hvis "D4" = 44 skal den vedhæfte 44a.pdf & 44b.pdf på mailen det er så ud for hver række den skal gøre det.
Men det den endlig bare skal er at kunne ved hæfte filer ud fra en celle værdi. Som men. hvis sagen er = Select Case (Cells(r, 4)) Case Is = "A" Msg = Msg & "Besked A" & vbCrLf Case Is = "B" Msg = Msg & "Besked B" & vbCrLf Case Is = "C" Msg = Msg & "Besked C" & vbCrLf Case Is = "D" Msg = Msg & "Besked d" & vbCrLf Case Is > 0 Msg = Msg & "Besked 0" & vbCrLf 'Vedhæft fil her hvis a, b, c, d, ej er sagen. mailThis.Attachments.Add Disk & "/text/" & Cells(r, 16) & "a" & Filnavn mailThis.Attachments.Add Disk & "/text/" & Cells(r, 16) & "B" & Filnavn End Select
Så koden skal kigge efter mailadresse i U, vedhæfte filer med sammenkædet navn fra B-D, B-J og B-P, altså 3 vedhæftede filer hver gang, og sende til adressen i U?
Sub Send() Dim I, L, Y, Filer, Tekst Dim Besked As String, Drev As String, MinExt As String Dim MitArray Drev = "C:\text\" MinExt = ".pdf" MitArray = Range("A2:U25") For I = 1 To UBound(MitArray) If MitArray(I, 21) Like "*@*" Then GoSub SendEnMail End If Next
Exit Sub SendEnMail: L = 0 Filer = Array(MitArray(I, 4), MitArray(I, 10), MitArray(I, 16)) Tekst = Array(MitArray(I, 5), MitArray(I, 6), MitArray(I, 7), MitArray(I, 8), MitArray(I, 11), MitArray(I, 12), MitArray(I, 13), MitArray(I, 14), MitArray(I, 17), MitArray(I, 18), MitArray(I, 19), MitArray(I, 20)) Dim ObjOutlook As Outlook.Application Dim ObjOutLookMsg As Outlook.MailItem Dim ObjOutLookRecip As Outlook.Recipient
Set ObjOutlook = CreateObject("Outlook.Application") Set ObjOutLookMsg = ObjOutlook.CreateItem(olMailItem)
ObjOutLookMsg.Save Besked = "Hermed fremsendes " & vbCrLf With ObjOutLookMsg Set ObjOutLookRecip = .Recipients.Add(MitArray(I, 21)) ObjOutLookRecip.Type = olTo For Y = 0 To 2 If Filer(Y) > 0 And IsNumeric(Filer(Y)) Then If Dir(Drev & Filer(Y) & "a" & MinExt) <> "" And Dir(Drev & Filer(Y) & "b" & MinExt) <> "" Then .Attachments.Add Drev & Filer(Y) & "a" & MinExt .Attachments.Add Drev & Filer(Y) & "b" & MinExt Besked = Besked & Filer(Y) & "a" & MinExt & ", " & Filer(Y) & "b" & MinExt & vbCrLf Else Besked = Besked & "Fejl! Filen " & Drev & Filer(Y) & " version a eller b, kunne ikke findes!" & vbCrLf End If Else Select Case Filer(Y) Case "A" Besked = Besked & Tekst(L + Y + 0) & vbCrLf Case "B" Besked = Besked & Tekst(L + Y + 1) & vbCrLf Case "C" Besked = Besked & Tekst(L + Y + 2) & vbCrLf Case "D" Besked = Besked & Tekst(L + Y + 3) & vbCrLf End Select End If L = L + 3 Next .Subject = "Hej" .Body = Besked .Save '.Send 'Fjern det første ' hvis mailen skal sendes og ikke puttes i kladde End With Set ObjOutlook = Nothing Return
Kan du ikke fortælle hvad der står i de respektive celler? Er den ovenstående kode en erstatning for hvad du tidligere skrev om tekster? Eller kan der stadig stå A, B, C og D, samt tal. Skal tallene være mellem 05 og 56?
Send evt et prøveark til gt4 at racingcar punkt dk. Det gør det meget nemmere!
Den virker med at vedhæfte filer A = tid B = Navn C = Type ---------- Besked 1 hvis det er værdi D = Id E = Start F = Sted G = Slut h = Sted ---------- Besked 1 Slut I = Bemærkning til den som laver planen ---------- Besked 2 hvis det er værdi J = Id K = Start L = Sted M = Slut N = Sted ---------- Besked 2 Slut O = Bemærkning ---------- Besked 3 hvis det er værdi P = Id Q = Start R = Sted S= Slut T = Sted ---------- Besked 3 Slut U = Mail Adresser
Altså, hvis (ID er A eller B eller C eller D) & celle D er mellem 11 og 55), vedhæft filer og sæt tekst i mailbody fra celle E, F, G og H. Er det forstået korrekt.
Hvis ovenstående betingelser ikke er tilstede, så gør det samme med bodytekst. Skal det forstås sådan?
Skriv og forklar i stedet at give en masse formler.
Hvis betingelser = a, b, c, d, skal den ikke vedhæfte noget. men er den i mellem 11 <> 55 skal den og hvis betingelser ikke findes skal den ikke gøre noget.
If D = betingelser, skriv / vedhæft next if J = betingelser, skriv / vedhæft og if p = betingelser, skriv / vedhæft. for hver mail hvis id et tom skal den gå til næste besked.
Sub Send() Dim I, L, Y, Filer, Tekst Dim Besked As String, Drev As String, MinExt As String, Subj As String Dim MitArray As Variant Drev = "C:\text\" MinExt = ".pdf" MitArray = Range("A2:U25") For I = 1 To UBound(MitArray) If MitArray(I, 21) Like "*@*" Then GoSub SendEnMail End If Next
Hvis den er = "A" skriv eks. anden dør Hvis den er = "B" skriv eks. uden for OSV... Hvis den er = 11 <> 55 skriv eks. opgaver og vedhæft filer det er kun for "D:D" så skal der være en for "J:J" og en for "P:P"
Men tror den bak har lavet virker har fjernet den hex del og lavet lidt om på den så virker den.
Sub SendEMail() Dim Email As String, Subj As String Dim MSG As String, URL As String Dim r As Integer, x As Double
For r = 4 To 30 'data in rows 2-4 Rem Get the email address 'Email = Cells(r, 21) If Cells(r, 22) <> "" Then bygMail r End If Next r End Sub Private Sub bygMail(r) Dim mailThis As Outlook.MailItem 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\Data\Test\" & Format(Cells(r, 25), "DDDD") ChDir Disk Filnavn = ".pdf"
For x = 1 To 1 MSG = MSG & "Fast Text" & vbCrLf MSG = MSG & "Fast Text" & vbCrLf & vbCrLf & vbCrLf
MSG = MSG & "Husk af se på de tider som er skrevet ud for hver løb, om der er klippet i ens ture" & vbCrLf MSG = MSG & "Fast Text" & vbCrLf & vbCrLf MSG = MSG & "Fast Text" & vbCrLf MSG = MSG & "Fast Text" & vbCrLf & vbCrLf MSG = MSG & "Fast Text" Next
nu virker det med ar vedhæfte filer. lille tryk fejl fra min side...
Her er et mail setup
Subject Fast Besked + "B:B" ' Navn Besked hvis celle har værdi = A:A Fast besked + A:A ' Tid 1. Plan Besked ' Hvis betingelser er der skriv beskedne og ny linje betingelser Hvis D:D = "A" Besked = Fast Besked + "E:H" ' E & G er tider "B" Besked = Fast Besked + "E:H" ' E & G er tider "C" Besked = Fast Besked + "E:H" ' E & G er tider "D" Besked = Fast Besked + "E:H" ' E & G er tider 11<>55 Besked = Fast Besked + "E:H" ' E & G er tider 2. Plan Besked ' Hvis betingelser er der skriv beskedne og ny linje betingelser Hvis J:J = "A" Besked = Fast Besked + "K:N" ' K & M er tider "B" Besked = Fast Besked + "K:N" ' K & M er tider "C" Besked = Fast Besked + "K:N" ' K & M er tider "D" Besked = Fast Besked + "K:N" ' K & M er tider 11<>55 Besked = Fast Besked + "K:N" ' K & M er tider 3. Plan Besked ' Hvis betingelser er der skriv beskedne og ny linje betingelser Hvis P:P = "A" Besked = Fast Besked + "Q:T" ' Q & S er tider "B" Besked = Fast Besked + "Q:T" ' Q & S er tider "C" Besked = Fast Besked + "Q:T" ' Q & S er tider "D" Besked = Fast Besked + "Q:T" ' Q & S er tider 11<>55 Besked = Fast Besked + "Q:T" ' Q & S er tider Fast Besked Fast Besked Fast Besked Fast Besked
Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.
