"Send from" vba trough outlook
Hi all,
I have written a code in VBA and so faar it works great. BUT not i want to be abel to send my mails trough the account called "pp.sales" what do i need to change in my code to get it to work.
I have tried MailItem.SendUsingAccount but i must be doing it wrong.
I use outlook 2007
Hope you can help me!!! :)
Best Regards!!
[VBA]Sub SendINotesFraExcel()
'********************************************************************
'Sender mailen fra søjlen hvor markøren aktuelt er placeret. Når der sendes
'flere filer på en gang flytter markøren automatisk søjle
'********************************************************************
'Variable til indholdet og udseendet af mailen
Dim FontSize(60) As Integer
Dim FontFed(60) As Boolean
Dim FontKursiv(60) As Boolean
'Variablene der styrer notes
Dim Session As Object
Dim Db As Object
Dim Doc As Object
Dim Item As Object
Dim Style As Object
Dim objNotesField As Object
'Variabel der styrer hvilken mail der bliver sendt - afhængig af hvilken kolonne man står i
Dim KolonneNr As Integer
'Tællervariabel
Dim N As Integer
Dim BrugerNavn As String 'Brugerens initialer - bruges til bestemmelse af afsender emailadresse
' OUTLOOK definitioner.
' DSTI & JEPA, 2009-07-13
Dim objOL As Outlook.Application
Dim objNS As Outlook.Namespace
Dim objFolder As Outlook.Folder
Dim oItem As Outlook.MailItem
Set objOL = New Outlook.Application
Set objNS = objOL.GetNamespace("MAPI")
Set objFolder = objNS.GetDefaultFolder(olFolderContacts)
KolonneNr = ActiveCell.Column
BrugerNavn = MailData(2)
'Hvis den aktuelle mail er en opdateres ODBC forespørgslen
If Cells(31, KolonneNr).Value = "" Or Cells(31, KolonneNr).Value = "" Then
Sheets("").QueryTables(1).Refresh BackgroundQuery:=False
End If
'Lægger data for den aktuelle mail ind i vektorerne
For N = 1 To 60
MailData(N) = Cells(N, KolonneNr).Value
FontSize(N) = Cells(N, KolonneNr).Font.Size
If Cells(N, KolonneNr).Font.Bold = True Then
FontFed(N) = True
End If
If Cells(N, KolonneNr).Font.Italic = True Then
FontKursiv(N) = True
End If
Next N
'Kontrollerer om alle de vedhæftede filer eksisterer - hvis de ikke eksisterer forlades proceduren
For N = 3 To 22
If Not MailData(N) = "" Then
If Dir(MailData(N)) = "" Then
msgboxRes = MsgBox("Du forsøgte at vedhæfte en filen " & MailData(N) & Chr(13) & Chr(13) & _
"Filen findes ikke - mailen sendes derfor ikke.", vbCritical, "Fejl i vedhæftede fil")
Exit Sub
End If
End If
Next N
'Starter Menuen
If Not UCase(Cells(30, KolonneNr).Value) = "NEJ" Then
Call UdfyldUserForm 'Udfylder userform
UFSendMail.Show 'Viser userform
'Udfylder variabler med rettelserne indtastet i userformen
MailData(23) = UFSendMail.TBto.Text
MailData(24) = UFSendMail.TBcc.Text
MailData(25) = UFSendMail.TBBcc.Text
MailData(26) = UFSendMail.TBSubject.Text
MailData(27) = UFSendMail.TBTekst.Text
Else
'Når menuen ikke bruges kan der ikke annulleres og mailen sendes derfor forsættes sendstatus til true
UFSendMail.SendStatus = "Send"
End If
'Hvis enten alle eller 1 mail annulleres stoppes proceduren. Tester i anden procedure om der skal stoppes fuldstændig
If UFSendMail.SendStatus = "AnnullerAlle" Or UFSendMail.SendStatus = "AnnullerAktuel " Then
Exit Sub
End If
'Create a new message.
Set oItem = objOL.CreateItem(olMailItem)
oItem.Subject = MailData(26)
oItem.Body = MailData(27)
arrayto = Join(MultiAddresses(MailData(23)), ";")
Arraycopyto = Join(MultiAddresses(MailData(24)), ";")
ArrayBlindCopy = Join(MultiAddresses(MailData(25)), ";")
If arrayto = "" And Arraycopyto = "" And ArrayBlindCopy = "" Then
MsgboxSvar = MsgBox("Der er ikke indtastet nogen modtager af e-mailen." & Chr(13) & Chr(13) & _
"E-mailen blev ikke sendt !", vbCritical, "Fejl i modtagerfelterne")
Exit Sub
End If
If arrayto <> "" Then oItem.To = arrayto
If Arraycopyto <> "" Then oItem.CC = Arraycopyto
If ArrayBlindCopy <> "" Then oItem.BCC = ArrayBlindCopy
'Vedhæfter filerne
N = 3
Do While Not (MailData(N)) = ""
oItem.Attachments.Add MailData(N)
N = N + 1
If N = 23 Then
Exit Do
End If
Loop
'Tester om der er valgt OK til at sende
If UFSendMail.SendStatus = "Send" Then
oItem.Send
ActiveWorkbook.Sheets("Mail").Cells(28, KolonneNr).Value = Now()
ActiveWorkbook.Sheets("Mail").Cells(32, KolonneNr).Value = ReturnUserName()
AntalSendte = AntalSendte + 1
'Hvis der ikke sendes alligevel
End If
Exit Sub[/VBA]
