Vba ingeven wachtwoord outlook

[AD1957]

Beste Forumleden,

Met onderstaande code wordt de factuur vanuit Excel als PDF gemaild. (gehaald uit voorbeeld van Edmoor)
Probleem is dat ik steeds het wachtwoord voor outlook moet ingeven.
Is er een mogelijkheid om met VBA dit wachtwoord in te geven of te omzeilen?

(ps; wachtwoord wil ik niet in wachtwoordenlijst zetten)

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

    With Sheets("Factuur")
         FileNamePDF = Environ("temp") & "\" & "fact.nr " & .Range("F20") & "  " & .Range("B20") & ".pdf"
        .Range("B8:F80").ExportAsFixedFormat _
            Type:=xlTypePDF, _
            Filename:=FileNamePDF
            
        StrTo = .Range("F23")
        StrSubject = "FACTUURNR:" & "  " & .Range("F20") & "  " & .Range("B20")
        StrBody = "Beste Klant," & vbCrLf & vbCrLf & _
               "Bijgevoegd de factuur voor uitgevoerde werkzaamheden." & vbCrLf & vbCrLf & _
               "Met dank voor uw opdracht en  vriendelijke groet," & vbCrLf & vbCrLf & _
               "Bjorn "
    End With
    
    With OutMail
        .To = StrTo
        .Subject = StrSubject
        .Body = StrBody
        .Attachments.Add FileNamePDF
        .Display    'niet direct verzenden
        '.Send      'direct verzenden
    End With

Set OutMail = Nothing
Set OutApp = Nothing

 

[HSV]

Een wachtwoord op Outlook?

Helaas heb ik er nog nooit van gehoord.
Waar loopt het vast op je code?

 

[edmoor]

Het onthouden van je account wachtwoord stel je in Outlook zelf in.

 

[HSV]

Jij hebt het beter door dan ik @edmoor.

 

[AD1957]

Ik heb op OUTLOOK een wachtwoord staan. Voor openen van outlook moet ik dit invoeren.
Wat is hier zo vreemd aan,???
De code loopt niet vast, maar ik moet gewoon mijn wachtwoord invoeren.
Kan natuurlijk het wachtwoord in de "wachtwoordenlijst" zetten dan hoef ik het niet steeds in te voeren bij het verzenden van de factuur.
Maar omdat soms ook anderen onder mijn account op de pc werken wil ik dat niet.

 

[edmoor]

Maak een account in Outlook waarmee de anderen ook email mogen versturen en gebruik dan SendUsingAccount:
https://www.rondebruin.nl/win/s1/outlook/account.htm


@HSV:

Jij hebt het beter door dan ik @edmoor.

Stuivertje wisselen heet dat

 

[AD1957]

Bedankt, hier kan ik iets mee:thumb:

 

[edmoor]

Ik heb daar een tijdje geleden dit voor iemand voor gemaakt. Wellicht dat je er iets aan hebt:

Dim oAcc As Outlook.Account

Sub MailIt(ByVal mAdres As String, mSubject As String, ByVal mBijlage As String)

    Dim oApp As Object
    Dim oMail As Object
    Dim Attach As Object
    Dim Recipient As Object
    
    If Not CheckAccount("edmoor@helpmij.nl") Then Exit Sub
    
    Set oApp = CreateObject("Outlook.Application")
    Set oMail = oApp.CreateItem(0)
    With oMail
        .Recipients.Add mAdres
        If Not .Recipients.ResolveAll Then
            For Each Recipient In .Recipients
                If Not .Recipient.Resolved Then
                    MsgBox .Recipient.Name & " could not be resolved.", vbCritical, "Unable to resolve"
                    Exit Sub
                End If
            Next Recipient
        End If
        .Subject = mSubject
        .Attachments.Add mBijlage
        
        .HTMLBody = RangetoHTML(Range(Range("Mailtekst").Address))
         Set Attach = .Attachments.Add(ThisWorkbook.Path & "\img001.gif", 1, 0)
        .HTMLBody = .HTMLBody & "<img src='cid:img001.gif' width='481' height='100'>" [COLOR="#008000"]'height minimaal 10 pixels groter dan het plaatje zelf[/COLOR]
        .HTMLBody = .HTMLBody & RangetoHTML(Range(Range("Handtekening").Address))
        
        Set .SendUsingAccount = oAcc
        .Display [COLOR="#008000"]'Eerst tonen, anders gaat het plaatje mis (Outlook bug)[/COLOR]
        .Close olSave
    End With
    
    Set oMail = Nothing
    Set oApp = Nothing
End Sub

Public Function CheckAccount(SendAs As String) As Boolean
    Dim oApp As Object
    
    Set oApp = CreateObject("Outlook.Application")
    For Each oAcc In oApp.Session.Accounts
        If oAcc.DisplayName = SendAs Then
            CheckAccount = True
            Exit For
        End If
    Next
End Function

 

[AD1957]

Goede morgen Edmoor,

Ik ga eerst aan de slag met jouw suggestie onder #6
Daarna ga ik me eens bezighouden met de bestudering van deze laatste code.
Eerlijkheidshalve kan ik er vooralsnog geen touw aan vastknopen

 

[edmoor]

Het is een gedeelte uit een veel groter geheel, maar het laat wel zien hoe SendUsingAccount gebruikt moet worden.
Daar ging het me even om.