Bestand versturen met het mailadres uit A!

[vrouw]

Hallo,

Ik gebruik onderstaande code om snel een excel betand te mailen.
Nu is het zo dat veel collega`s dit bestand gaan gebruiken en ik niet wil dat men in de VBA gaat zitten rommelen, dus lijkt het mij beter dat men hun mail adres in cel A1 plaatst.
Dit om de afzender juist in de mail te krijgen en voor de eventuele reply.

Deze code werkt perfect zolang ik het mail adres "hard" in de VBA zet maar ik krijg het dus niet voor elkaar om naar de cel te laten kijken waar het adres in staat.
Is dit met een simpele aanpassing haabaar of moet dan de hele code verbouwd worden (wat mij niet gaat lukken)

 Sub Mail_Sheet()

 Application.DisplayAlerts = False

'Working in 97-2007
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim iMsg As Object
    Dim iConf As Object
    Dim Flds As Variant

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

    Set Sourcewb = ActiveWorkbook

    'Copy the ActiveSheet to a new workbook
    'ActiveSheet.Copy
    Sheets(Array("Trans-D", "Trans-C", "Trans-O", "Trans-P")).Copy
    
    Set Destwb = ActiveWorkbook

    'Determine the Excel version and file extension/format
    With Destwb
        If Val(Application.Version) < 12 Then
            'You use Excel 97-2003
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            'You use Excel 2007
            'We exit the sub when your answer is NO in the security dialog that you only
            'see  when you copy a sheet from a xlsm file with macro's disabled.
            If Sourcewb.Name = .Name Then
                With Application
                    .ScreenUpdating = True
                    .EnableEvents = True
                End With
                MsgBox "Your answer is NO in the security dialog"
                Exit Sub
            Else
                Select Case Sourcewb.FileFormat
                Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
                Case 52:
                    If .HasVBProject Then
                        FileExtStr = ".xlsm": FileFormatNum = 52
                    Else
                        FileExtStr = ".xlsx": FileFormatNum = 51
                    End If
                Case 56: FileExtStr = ".xls": FileFormatNum = 56
                Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
                End Select
            End If
        End If
    End With

   
    'Save the new workbook/Mail it/Delete it
    TempFilePath = Environ$("temp") & "\"
    'TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
     TempFileName = " " & " " & Format(Now, "dd-mmm-yy h.mm uur")
     
    With Destwb
     For k = 1 To 4
     sh = WorksheetFunction.Choose(k, "Trans-D", "Trans-C", "Trans-O", "Trans-P")
     Sheets(sh).Shapes("CommandButton1").Delete
     Sheets(sh).Shapes("CommandButton2").Delete
     Next k
        
        
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        .Close savechanges:=False
    End With

    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")

        iConf.Load -1    ' CDO Source Defaults
        Set Flds = iConf.Fields
        With Flds
            .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "mail.me.nl"
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
            .Update
        End With
                                     
    With iMsg
        Set .Configuration = iConf
        '.To = "test@test.com"
        [COLOR="#FF0000"][COLOR="#FF0000"][B].To = kijken naar cel A1[/B][/COLOR][/COLOR]
        .CC = ""
        .BCC = ""
        .FROM = """ik@ik.nl"
        .Subject = Chr(187) & Chr(187) & " transp voor " & ActiveSheet.Range("B9").Text & " week " & ActiveSheet.Range("B11").Text & ""
        .TextBody = "Beste Collega`s, " & vbCrLf & vbCrLf & _
       "Hierbij een aanvraag voor een trans voor " & ActiveSheet.Range("B9").Text & " week " & ActiveSheet.Range("B11").Text & ""
        .AddAttachment TempFilePath & TempFileName & FileExtStr
        .Send
    End With
 
 'Delete the file you have send
    Kill TempFilePath & TempFileName & FileExtStr

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    
       
     CreateObject("WScript.Shell").Popup "  Aanvraag trans is verstuurt  !!", 1, " Ik sluit vanzelf na 2 Seconden"
End Sub

 

[ExcelAmateur]

Vrouw,
Misschien zo?

 .To = range("A1").Value

of

.To = Blad1.range("A1").Value

 

[vrouw]

Hé, top dat werkt goed.

Nu wilde ik in A2 de gewoon de naam in zetten van de afzender(dus geen mail adres) en pas dus de code aan naar:
.FROM = Range("A2").Value
maar dan komt er een foutmelding iets als; server rejected 553. Domain name required for sender adres

 

[ExcelAmateur]

Misschien dat dit zo wel werkt.

.FROM = ""Range("A2").value

 

[pasan]

.From moet ook een mail adres zijn
Je zegt dat je dit bestand gebruikt op je werk samen met andere andere gebruikers elk op hun eigen pc
Mooiste zou in dit geval zijn als de inlognaam van elke gebruiker op de pc het zelfde zou zijn als hun werk mail adres.
Als dit het geval is heb ik wel een stukje code voor je welke kijkt wie er ingelogd is om dit dan voor het ...@werk.nl te zetten
zodat .From = ...@werk.nl

 

[vrouw]

Hmm, is dat nou jammer.
We loggen inderdaad met een andere naam in op de pc als onze naam.

 

[pasan]

dat is idd jammer
je kunt nog wel in de code de mail adressen verwerken van alle gebruikers om dan elk mail adres te koppelen aan de op dat moment ingelogde gebruiker.
Maar dan moet je dus wel van een ieder de inlog naam weten (niet het wachtwoord)

 

[pasan]

Of de netwerkbeheerder vragen om alle inlognamen en mail namen hetzelfde te maken

 

[vrouw]

dat is idd jammer
je kunt nog wel in de code de mail adressen verwerken van alle gebruikers om dan elk mail adres te koppelen aan de op dat moment ingelogde gebruiker.
Maar dan moet je dus wel van een ieder de inlog naam weten (niet het wachtwoord)

Dat is wel een mogelijkheid.
Maar is dat een ingewikkelde code?

 

[vrouw]

Of de netwerkbeheerder vragen om alle inlognamen en mail namen hetzelfde te maken

Hmm, van 20.000 man. Maak ik weinig (geen) kans op.

 

[pasan]

20.000 man :d
Namen is dus de inlognaam van de pc
Fnaam moet dan de tekst van de bijbehorende mail adres van de gebruiker zijn

  Dim Fnaam As String
    Namen = VBA.Environ("USERNAME")
    If Namen = "kees" Then Fnaam = "kees"
    If Namen = "jan" Then Fnaam = "jan"

     .From = "<" & Fnaam & "@werk.nl>"

 

[vrouw]

Totaal van de firma is inderdaad wel 20.000 man.
Gelukkig gebruiken die niet allemaal dit document maar " slechts" 40 man/vrouw.
Echter... Dan moet ik dus die hele lijst met gebruikers eerst in de VBA zetten?Kan die niet kijken naar een bepaald tabblad waar de namen staan?

 

[pasan]

ik neem aan dat ieder het zelfde werkmail adres gebruikt (achter de @).
Daarvan uitgaande vul je in kolom A alle gebruikersnamen in (Pc) en in kolom B het gedeelte van het mailadres (voor de @).

Dim Fnaam As String
Unaam = VBA.Environ("USERNAME")

With Worksheets("Blad1").Range("A1:A50")
    Set c = .Find(Unaam, LookIn:=xlValues)
    If Not c Is Nothing Then
        firstAddress = c.Address
        Do
        a = c.Row
        Fnaam = Cells(a, 2).Text
            Set c = .FindNext(c)
        Loop While Not c Is Nothing And c.Address <> firstAddress
 End If
End With

     .From = "<" & Fnaam & "@werk.nl>"