afbeelding in een werkblad mailen met makro

Wallo · 28 mei 2010

Hallo iedereen, ik heb een makro (van Ron De Bruin) om een werkblad te mailen, maar in dit werkblad staat ook een afbeelding (logo), de makro werkt perfect alleen zend hij de afbeelding niet mee. Weet iemand hoe ik de makro moet aanpassen zodat de afbeelding wel wordt mee verzonden?
Hieronder de makro.

Code:

Sub Mail_Range2()
'Working in 2000-2010
    Dim Source As Range
    Dim Dest As Workbook
    Dim wb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim I As Long
    Dim MAddress As String
 
    Set Source = Nothing
    On Error Resume Next
    Set Source = Range("A1:I50").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
 
    If Source Is Nothing Then
        MsgBox "De bron is niet in berijk, " & _
               "verbeter en probeer opnieuw.", vbOKOnly
        Exit Sub
    End If
 
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
 
    Set wb = ActiveWorkbook
    On Error Resume Next
    MAddress = Application.WorksheetFunction.VLookup(Range("b10").Value, Sheets("klantelijst").Range("A:I"), 9, False)
    On Error GoTo 0
    Set Dest = Workbooks.Add(xlWBATWorksheet)
 
    Source.Copy
    With Dest.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial Paste:=xlPasteValues
        .Cells(1).PasteSpecial Paste:=xlPasteFormats
        .Cells(1).Select
        Application.CutCopyMode = False
    End With
 
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Range of " & wb.Name & " " _
                 & Format(Now, "dd-mmm-yy h-mm-ss")
 
    If Val(Application.Version) < 12 Then
        'You use Excel 2000-2003
 
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        'You use Excel 2007-2010
        FileExtStr = ".xlsx": FileFormatNum = 51
    End If
 

    With Dest
        .SaveAs TempFilePath & TempFileName & FileExtStr, _
                FileFormat:=FileFormatNum
        On Error Resume Next
        For I = 1 To 3
            .SendMail MAddress, _
                      "offerte-bestelling stad Antwerpen"
            If Err.Number = 0 Then Exit For
        Next I
        On Error GoTo 0
        .Close SaveChanges:=False
    End With
 
    'Delete the file you have send
    Kill TempFilePath & TempFileName & FileExtStr
 
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Alvast bedankt!

rostie-rostelli · 28 mei 2010

Hallo,

Uw code werkt inderdaad niet, probeer anders gewoon een Macro op te nemen die het bestand verzend naar uw e-mail programma, ik heb dit zo uitgetest en het werkt vergelijkend met dat van U maar dan wel MET foto !!

De code na opname Macro is eenvoudig:

Code:

Sub test2()
    Application.Dialogs(xlDialogSendMail).Show
End Sub

en plaats deze bij een sneltoets, bv. ctrl+m

Groetjes,
Danny

huijb · 28 mei 2010

Voor beide een stukje huisvlijt http://www.helpmij.nl/forum/showthr...-De-Helpers-In-Deze-Sectie-Van-Dienst-Te-Zijn

Wallo · 28 mei 2010

Dag Huijb, als ik het goed begrijp moet ik bij de vraagstelling bv in dit geval

Code:

 bijvoegen.
Dag Danny alvast bedankt, heb het geprobeert maar het werkt niet bij mij, zal wel iets verkeerd gedaan hebben ben niet zo'n as in vba (beginneling). De makro werkt bij mij tip top maar het logo(afbeelding) gaat niet mee in de mail, ik zou graag hebben als ik de makro activeer dat de selectie in dit geval A1:I50 samen met de afbeelding in het tijdelijke werkblad wordt gekopieërd en verzonden.
Dus er moet een code bijgevoegd worden in de makro maar wat en waar?

huijb · 28 mei 2010

Wallo zei:
Dag Huijb, als ik het goed begrijp moet ik bij de vraagstelling bv in dit geval

Code:

bijvoegen. [/QUOTE]Dat is correct. ;)

trucker10 · 28 mei 2010

eens de zoekfunctie gebruiken binnen " helpmij " en zeker op thst dit is denk ik daar tot de orde gekomen .

Wallo · 28 mei 2010

Hoe stel ik de vraag in help?
In thst is dit inderdaad aan bod gekomen maar niet opgelost.
Alvast bedankt

trucker10 · 28 mei 2010

Wallo zei:
Hoe stel ik de vraag in help?
In thst is dit inderdaad aan bod gekomen maar niet opgelost.
Alvast bedankt

Uit een topic van thst

Code:

Range("B13:F35").CurrentRegion.ClearContents
Dim ImgFileFormat As String, pic As Variant
On Error Resume Next
Application.DisplayAlerts = False
[B13:F35].Delete
Set rng = Range("B1333")
ImgFileFormat = "Image Files jpg (*.jpg),*.jpg,(*.bmp),others, tif (*.tif),*.tif"
Set pic = ActiveSheet.Pictures.Insert("E:\A2B4U\briefpapier.jpg")
If Not pic Is Nothing Then
With pic
.Height = rng.Height
.Width = rng.Width
.Left = rng.Left
.Top = rng.Top
.Placement = xlMoveAndSize
End With
Else: Exit Sub
End If
Application.DisplayAlerts = True
End Sub

Warme bakkertje · 29 mei 2010

Zoiets zal het ongeveer worden

Code:

With Dest.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial Paste:=xlPasteValues
        .Cells(1).PasteSpecial Paste:=xlPasteFormats
        .Cells(1).Select
        Application.CutCopyMode = False
Set rng = .Range("B1333") 'Wijzig hier naar de juiste cel
Set pic = .Pictures.Insert("E:\A2B4U\briefpapier.jpg") 'Pas hier het pad naar je afbeelding aan
If Not pic Is Nothing Then
With pic
      .Height = rng.Height
      .Width = rng.Width
      .Left = rng.Left
      .Top = rng.Top
      .Placement = xlMoveAndSize
End With
End With

Wallo · 29 mei 2010

Daniël en Rudy, hartelijk bedankt ga dit eens uitproberen en laat jullie weten of het lukt.

Wallo · 30 mei 2010

Ik heb de code aangepast maar krijg telkens de foutmelding dat hij de afbeelding niet kan vinden, wat doe ik hier verkeerd?
bij hoogte en breedtte etc... waar vul ik de waarden in? Is dit bij rng.heigt (heigt vervangen door waarde of erachter plaatsen, en zijn dit pixels?)
Kloppen de end if enz... nog? deze heb ik ook moeten wijzigen.

Code:

With Dest.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial Paste:=xlPasteValues
        .Cells(1).PasteSpecial Paste:=xlPasteFormats
        .Cells(1).Select
        Application.CutCopyMode = False
        Set rng = .Range("B1") 'Wijzig hier naar de juiste cel
Set pic = .Pictures.Insert("c:\gebruikers\kelly\afbeeldingen\logo") 'Pas hier het pad naar je afbeelding aan
If Not pic Is Nothing Then
With pic
      .Height = rng.Height
      .Width = rng.Width
      .Left = rng.Left
      .Top = rng.Top
      .Placement = xlMoveAndSize
End With
End If
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Range of " & wb.Name & " " _
                 & Format(Now, "dd-mmm-yy")
 
    If Val(Application.Version) < 12 Then
        'You use Excel 2000-2003
 
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        'You use Excel 2007-2010
        FileExtStr = ".xlsx": FileFormatNum = 51
    End If
 

    With Dest
        .SaveAs TempFilePath & TempFileName & FileExtStr, _
                FileFormat:=FileFormatNum
        On Error Resume Next
        For I = 1 To 3
            .SendMail MAddress, _
                      "offerte-bestelling stad Antwerpen"
            If Err.Number = 0 Then Exit For
        Next I
        On Error GoTo 0
        .Close SaveChanges:=False
    End With
 
    'Delete the file you have send
    Kill TempFilePath & TempFileName & FileExtStr
 
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End With
End Sub

trucker10 · 30 mei 2010

("c:\gebruikers\kelly\afbeeldingen\logo") wat doet het als je dit even wijzigd

Code:

("C:\Users\kelly\afbeeldingen\logo.file format bv jpg , bmp , gif enz . ")

zet de extentie van het file format achter logo.???

Wallo · 31 mei 2010

Bedankt, alles werkt maar nu duikt er een ander probleem op, rij 1 en 2 worden nu groter dan in het origineel gekopieërd naar het te versturen werkblad(in het origineel rijhoogte 12.75 en in het gekopieërde 45) Kan dit zijn door dat de afbeelding gerelateerd is aan cellen? Kan je bv de grootte van de afbeelding bepalen en waar die moet komen zonder dat dit wijzigingen brengt in de lay-out? Bijgevoegd de werkende code
code:

Sub Mail_Range2()

Code:

'Working in 2000-2010
    Dim Source As Range
    Dim Dest As Workbook
    Dim wb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim I As Long
    Dim MAddress As String
 
    Set Source = Nothing
    On Error Resume Next
    Set Source = Range("A1:I50").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
 
    If Source Is Nothing Then
        MsgBox "De bron is niet in berijk, " & _
               "verbeter en probeer opnieuw.", vbOKOnly
        Exit Sub
    End If
 
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
 
    Set wb = ActiveWorkbook
    On Error Resume Next
    MAddress = Application.WorksheetFunction.VLookup(Range("b10").Value, Sheets("klantelijst").Range("A:I"), 9, False)
    On Error GoTo 0
    Set Dest = Workbooks.Add(xlWBATWorksheet)
 
    Source.Copy
    With Dest.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial Paste:=xlPasteValues
        .Cells(1).PasteSpecial Paste:=xlPasteFormats
        .Cells(1).Select
        Application.CutCopyMode = False
        Set rng = .Range("A1:B2") 'Wijzig hier naar de juiste cel
Set pic = .Pictures.Insert("f:\logo.gif") 'Pas hier het pad naar je afbeelding aan
If Not pic Is Nothing Then
With pic
      .Height = rng.Height
      .Width = rng.Width
      .Left = rng.Left
      .Top = rng.Top
      .Placement = xlMoveAndSize
End With
End If
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Range of " & wb.Name & " " _
                 & Format(Now, "dd-mmm-yy")
 
    If Val(Application.Version) < 12 Then
        'You use Excel 2000-2003
 
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        'You use Excel 2007-2010
        FileExtStr = ".xlsx": FileFormatNum = 51
    End If
 

    With Dest
        .SaveAs TempFilePath & TempFileName & FileExtStr, _
                FileFormat:=FileFormatNum
        On Error Resume Next
        For I = 1 To 3
            .SendMail MAddress, _
                      "offerte-bestelling stad Antwerpen"
            If Err.Number = 0 Then Exit For
        Next I
        On Error GoTo 0
        .Close SaveChanges:=False
    End With
 
    'Delete the file you have send
    Kill TempFilePath & TempFileName & FileExtStr
 
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End With
End Sub

trucker10 · 31 mei 2010

Dit is de regel waar je logo.gif komt te staan

Code:

Set rng = .Range("A1:B2") 'Wijzig hier naar de juiste cel

dit bepaald de rij en kolom hoogte / breedte

Code:

.Height = rng.Height
.Width = rng.Width
.Left = rng.Left
.Top = rng.Top

Je kan 2 dingen doen :
1 je logo aanpassen aan de range van A1:B2 ( 20 bij 120 pixels ?? )
2 of je gaat de hoogte breedte moeten kenbaarmaken in je macro > .Height = ???? ' vul hier het gewenste in ik vermoed in mm
. Width = ????

Wallo · 31 mei 2010

Bedankt Daniël, hier de wijziging ik heb de celaanduiding naar één cel gezet en de grootte van de afbeelding is alleen getallen zonder mm ofzo erachter. Ik heb ook nog dit gewijzigd A1 in A3 dan zijn de te grote rijen weg.
code:

Code:

Set Source = Range("A3:I50").SpecialCells(xlCellTypeVisible)
code:
Source.Copy
    With Dest.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial Paste:=xlPasteValues
        .Cells(1).PasteSpecial Paste:=xlPasteFormats
        .Cells(1).Select
        Application.CutCopyMode = False
        Set rng = .Range("A1") 'Wijzig hier naar de juiste cel
Set pic = .Pictures.Insert("f:\logo.gif") 'Pas hier het pad naar je afbeelding aan
If Not pic Is Nothing Then
With pic
      .Height = 60
      .Width = 120
      .Left = rng.Left
      .Top = rng.Top
      .Placement = xlMoveAndSize
End With

Dan denk ik dat mijn vraag volledig opgelost is, alleen heeft er iemand een verklaring voor waarom die eerste 2 rijen plots zo groot geworden zijn in het werkblad van de mail?

Verder zijn jullie allemaal verschrikkelijk bedankt voor jullie hulp,
de groeten en tot volgende.
Walter

trucker10 · 31 mei 2010

Ik haal deze avond je code eens binnen op mijn pc

eens kijken of hier de boosdoener niet zit

Code:

.Cells(1).PasteSpecial Paste:=xlPasteFormats

Ik zou zeggen nu al kijken voor uitbreiding

mailen van bepaalde range , meerdere tabbladen enz.

huijb · 31 mei 2010

Beste Wallo, ik heb nu, ik geloof al vier keer je vraag aangepast d.m.v. de codetags. Ik zou je nogmaals willen adviseren dit goed te lezen http://www.helpmij.nl/forum/showthr...-De-Helpers-In-Deze-Sectie-Van-Dienst-Te-Zijn

Wallo · 1 jun 2010

Mijn excuses Huijb ik dacht dat dit in de toekomst in de titel moest, nu heb ik het begrepen.

huijb · 1 jun 2010

:thumb: Goed zo.

afbeelding in een werkblad mailen met makro

Gebruiker

Gebruiker

Supermoderator

Gebruiker

Supermoderator

Terugkerende gebruiker

Gebruiker

Terugkerende gebruiker

Meubilair

Gebruiker

Gebruiker

Terugkerende gebruiker

Gebruiker

Terugkerende gebruiker

Gebruiker

Terugkerende gebruiker

Bijlagen

Supermoderator

Gebruiker

Supermoderator

Wij waarderen jouw privacy