• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Farklı sayfalardan belli aralığı resim olarak mail atmak

Y

yasartomurcuk

Katılım
12 Temmuz 2015
Mesajlar
16
Excel Vers. ve Dili
2013 türkçe
herkese merhaba

ben ekteki excel dosyasından tek bir sayfandan belli bir bölümü mail olarak aşağıdaki kod ile mail atabiliyorum
Sub kod()

Dim S1 As Worksheet: Set S1 = Sheets("grafik&web report farkları")
Dim rng As Range, cht As ChartObject, say As Double, obj As Object
Const strPath As String = "C:\resim\"

With Application
.EnableEvents = False
.ScreenUpdating = False
End With
S1.Select
isim = "mailek_" & Format(Now, "ddmmyyhhmmss")
Set obj = CreateObject("Scripting.FileSystemObject").GetFolder(strPath)
say = obj.Files.Count + 1
Set rng = S1.Range("A1:S38")

rng.CopyPicture xlScreen, xlPicture
Set cht = ActiveSheet.ChartObjects.Add(0, 0, rng.Width + 10, rng.Height + 10)
cht.Chart.Paste
cht.Chart.Export strPath & isim & ".jpg"
cht.Delete
ExitProc:
Set obj = Nothing: Set rng = Nothing: Set cht = Nothing

Dim xlOutlook As Object
Dim xlMail As Object
Set xlOutlook = CreateObject("Outlook.Application")
Set xlMail = xlOutlook.CreateItem(0)
htmlyaz = "<img src=" & strPath & isim & ".jpg" & " alt=''"

With xlMail
.To = Range("y3").Value
.CC = Range("y4").Value
.Subject = Range("e3").Value
.HTMLBody = htmlyaz
.Importance = 2
.Save
.Display
'.Send
End With

Set xlMail = Nothing
Set xlOutlook = Nothing
Kill strPath & isim & ".jpg"

With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub

ancak istiyorumki metin sayfasından mailin konusunu ve gövde metnine yazılacakları alsın BANKA - GRAFİK - MALİ HAFIZA sayfalarından belli bölümlerinden resmini çekerek atabilsin şuan yukarıdaki kodla grafik sayfasını mail olarak atabiliyorum

bu konuda yardımcı olacak arkadaşlara şimdiden teşekkür ederim
 

Ekli dosyalar

kod

Kod: 
htmlyaz = "<img src=" & strPath & isim & ".jpg" & " alt=''"

yukarıdaki bölümün hemen altına aşağıdaki kodu ekle

Kod: 
adres1 = ActiveWindow.RangeSelection.Address

deg1 = Split(Trim(adres1), ":")
If UBound(deg1) > 0 Then

sat1 = Range(deg1(0)).Row
sat2 = Range(deg1(1)).Row
sut1 = Range(deg1(0)).Column
sut2 = Range(deg1(1)).Column
Else

sat1 = Range(adres1).Row
sat2 = Range(adres1).Row
sut1 = Range(adres1).Column
sut2 = Range(adres1).Column
End If

son1 = 999


ReDim rngV(son1, son1): ReDim rngClr(son1, son1): ReDim rngFonClr(son1, son1)
ReDim rngSize(son1, son1): ReDim rngduz(son1, son1): ReDim rngwidth(son1, son1)
ReDim charf(son1): ReDim rnum(son1)
ReDim rngItalic(son1, son1): ReDim rngBold(son1, son1)

Dim oldRngRow, oldRngClm, x, y As Integer


deg1 = Array(-4105, -4142, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, _
11, 12, 13, 14, 15, 16, 17, 18, 19, 20, _
21, 22, 23, 24, 25, 26, 27, 28, 29, 30, _
31, 32, 33, 34, 35, 36, 37, 38, 39, 40, _
41, 42, 43, 44, 45, 46, 47, 48, 49, 50, _
51, 52, 53, 54, 55, 56)


deg2 = Array("#000000", "#FFFFFF", "#000000", "#FFFFFF", "#FF0000", _
"#00FF00", "#0000FF", "#FFFF00", "#FF00FF", "#00FFFF", "#800000", _
"#008000", "#000080", "#808000", "#800080", "#008080", "#C0C0C0", _
"#808080", "#9999FF", "#993366", "#FFFFCC", "#CCFFFF", "#660066", _
"#FF8080", "#0066CC", "#CCCCFF", "#000080", "#FF00FF", "#FFFF00", _
"#00FFFF", "#800080", "#800000", "#008080", "#0000FF", "#00CCFF", _
"#CCFFFF", "#CCFFCC", "#FFFF99", "#99CCFF", "#FF99CC", "#CC99FF", _
"#FFCC99", "#3366FF", "#33CCCC", "#99CC00", "#FFCC00", "#FF9900", _
"#FF6600", "#666699", "#969696", "#003366", "#339966", "#003300", _
"#333300", "#993300", "#993366", "#333399", "#333333")


Application.ScreenUpdating = False
Dim rng As Range


For Each rng In ActiveWindow.RangeSelection.Cells

If rng.Row > oldRngRow Then
oldRngRow = rng.Row
x = x + 1
y = 0
oldRngClm = 0
rnum(x) = rng.Row

End If

If rng.Column > oldRngClm Then
oldRngClm = rng.Column
y = y + 1
charf(y) = Split(rng.Address, "$")(1)

End If

rngduz(x, y) = Cells(rng.Row, rng.Column).HorizontalAlignment

rngBold(x, y) = rng.Font.Bold
rngItalic(x, y) = rng.Font.Italic

rngV(x, y) = rng.Value
rngwidth(x, y) = rng.Width + 5
aranan1 = Cells(rng.Row, rng.Column).Font.ColorIndex

rngClr(x, y) = "#000000"
For m = 0 To 57
If aranan1 = deg1(m) Then
rngClr(x, y) = deg2(m)
Exit For
End If
Next m

aranan2 = Cells(rng.Row, rng.Column).Interior.ColorIndex
rngFonClr(x, y) = "#FFFFFF"
For t = 0 To 57
If aranan2 = deg1(t) Then
rngFonClr(x, y) = deg2(t)
Exit For
End If
Next t

rngSize(x, y) = Round(rng.Font.Size / 4.5, 1)

Next

ustyazı1 = [COLOR="Red"]"Sayın Müklellef"[/COLOR]
ustyazı2 = [COLOR="red"]"Size ait tablo ekdeki gibidir."[/COLOR]
ustyazı3 = [COLOR="red"]"MUTABAKAT MEKTUBU ve CH EXTRESİ MAİL EKİNDEDİR"[/COLOR]
ustyazı4 = [COLOR="red"]"İYİ ÇALIŞMALAR DİLERİZ."[/COLOR]

veri1 = "</tr></tbody></table><font color=black size=1 face=verdana" & _
"><div align=left><font size=5 color=red face=verdana></font></div></font></font></td></tr></tbody></table><table><tbody><tr><th colspan=3><div align=left><font size=3 color=red face=verdana>" & _
ustyazı1 & "<br>" & ustyazı2 & "</font></div></th></tr></tbody></table><table><tbody><tr><th colspan=3><div align=left><font size=3 color=#000000 face=verdana>" & _
ustyazı3 & "<br>" & ustyazı4 & "</font></div></th></tr></tbody></table><table></table>"


veri1 = veri1 & "<table border=1><tbody><tr><td align=left valign=center><font size=5 color=red face=verdana></font>" & _
"<font size=1 face=verdana><table border=0 bgcolor=d4d0c8 cellspacing=1 cellpadding=1 align=center><tbody>" & _
"<tr align=center valign=center bgcolor=white>"
  
For i = 1 To x

veri1 = veri1 & "</tr><tr bgcolor=white height=20><td><font color=black size=1 face=verdana></font></td>"
 
For j = 1 To y

If rngduz(i, j) = -4131 Then
bir = "left"
ElseIf rngduz(i, j) = -4108 Then
bir = "center"
ElseIf rngduz(i, j) = -4152 Then
bir = "right"
Else
bir = "justify"
End If

If rngBold(i, j) = False Then
iki = rngV(i, j)
ElseIf rngBold(i, j) = True Then
iki = "<b>" & rngV(i, j) & "</b>"
Else
iki = rngV(i, j)
End If

veri1 = veri1 & "<td align= " & bir & " bgcolor= " & rngFonClr(i, j) & "  nowrap=true ><" & _
"font size=3 color=" & rngClr(i, j) & " face=verdana>" & iki & "</font></td>"
Next

Next


altyazı1 = [COLOR="red"]"Sayın Müklellef"[/COLOR]
altyazı2 = [COLOR="red"]"Size ait tablo ekdeki gibidir."[/COLOR]
altyazı3 = [COLOR="red"]"MUTABAKAT MEKTUBU ve CH EXTRESİ MAİL EKİNDEDİR"[/COLOR]
altyazı4 = [COLOR="red"]"İYİ ÇALIŞMALAR DİLERİZ."[/COLOR]

veri1 = veri1 & "</tr></tbody></table><font color=black size=1 face=verdana" & _
"><div align=left><font size=5 color=red face=verdana></font></div></font></font></td></tr></tbody></table><table><tbody><tr><th colspan=3><div align=left><font size=3 color=red face=verdana>" & _
altyazı1 & "<br>" & altyazı2 & "</font></div></th></tr></tbody></table><table><tbody><tr><th colspan=3><div align=left><font size=3 color=#000000 face=verdana>" & _
altyazı3 & "<br>" & altyazı4 & "</font></div></th></tr></tbody></table><table></table>"

htmlyaz2 = "<br>" & veri1

ve

Kod: 
.HTMLBody = htmlyaz

yukarıdaki bölümün hemen altınada aşağıdaki kodu ekle
Kod: 
.HTMLBody = htmlya2


not:burada sayfada seçili alanı tablo halinde mail gövdesine ekleme yapıyor.
 
halit3' Alıntı:
kod

Kod: 
htmlyaz = "<img src=" & strPath & isim & ".jpg" & " alt=''"

yukarıdaki bölümün hemen altına aşağıdaki kodu ekle

Kod: 
adres1 = ActiveWindow.RangeSelection.Address

deg1 = Split(Trim(adres1), ":")
If UBound(deg1) > 0 Then

sat1 = Range(deg1(0)).Row
sat2 = Range(deg1(1)).Row
sut1 = Range(deg1(0)).Column
sut2 = Range(deg1(1)).Column
Else

sat1 = Range(adres1).Row
sat2 = Range(adres1).Row
sut1 = Range(adres1).Column
sut2 = Range(adres1).Column
End If

son1 = 999


ReDim rngV(son1, son1): ReDim rngClr(son1, son1): ReDim rngFonClr(son1, son1)
ReDim rngSize(son1, son1): ReDim rngduz(son1, son1): ReDim rngwidth(son1, son1)
ReDim charf(son1): ReDim rnum(son1)
ReDim rngItalic(son1, son1): ReDim rngBold(son1, son1)

Dim oldRngRow, oldRngClm, x, y As Integer


deg1 = Array(-4105, -4142, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, _
11, 12, 13, 14, 15, 16, 17, 18, 19, 20, _
21, 22, 23, 24, 25, 26, 27, 28, 29, 30, _
31, 32, 33, 34, 35, 36, 37, 38, 39, 40, _
41, 42, 43, 44, 45, 46, 47, 48, 49, 50, _
51, 52, 53, 54, 55, 56)


deg2 = Array("#000000", "#FFFFFF", "#000000", "#FFFFFF", "#FF0000", _
"#00FF00", "#0000FF", "#FFFF00", "#FF00FF", "#00FFFF", "#800000", _
"#008000", "#000080", "#808000", "#800080", "#008080", "#C0C0C0", _
"#808080", "#9999FF", "#993366", "#FFFFCC", "#CCFFFF", "#660066", _
"#FF8080", "#0066CC", "#CCCCFF", "#000080", "#FF00FF", "#FFFF00", _
"#00FFFF", "#800080", "#800000", "#008080", "#0000FF", "#00CCFF", _
"#CCFFFF", "#CCFFCC", "#FFFF99", "#99CCFF", "#FF99CC", "#CC99FF", _
"#FFCC99", "#3366FF", "#33CCCC", "#99CC00", "#FFCC00", "#FF9900", _
"#FF6600", "#666699", "#969696", "#003366", "#339966", "#003300", _
"#333300", "#993300", "#993366", "#333399", "#333333")


Application.ScreenUpdating = False
Dim rng As Range


For Each rng In ActiveWindow.RangeSelection.Cells

If rng.Row > oldRngRow Then
oldRngRow = rng.Row
x = x + 1
y = 0
oldRngClm = 0
rnum(x) = rng.Row

End If

If rng.Column > oldRngClm Then
oldRngClm = rng.Column
y = y + 1
charf(y) = Split(rng.Address, "$")(1)

End If

rngduz(x, y) = Cells(rng.Row, rng.Column).HorizontalAlignment

rngBold(x, y) = rng.Font.Bold
rngItalic(x, y) = rng.Font.Italic

rngV(x, y) = rng.Value
rngwidth(x, y) = rng.Width + 5
aranan1 = Cells(rng.Row, rng.Column).Font.ColorIndex

rngClr(x, y) = "#000000"
For m = 0 To 57
If aranan1 = deg1(m) Then
rngClr(x, y) = deg2(m)
Exit For
End If
Next m

aranan2 = Cells(rng.Row, rng.Column).Interior.ColorIndex
rngFonClr(x, y) = "#FFFFFF"
For t = 0 To 57
If aranan2 = deg1(t) Then
rngFonClr(x, y) = deg2(t)
Exit For
End If
Next t

rngSize(x, y) = Round(rng.Font.Size / 4.5, 1)

Next

ustyazı1 = [COLOR="Red"]"Sayın Müklellef"[/COLOR]
ustyazı2 = [COLOR="red"]"Size ait tablo ekdeki gibidir."[/COLOR]
ustyazı3 = [COLOR="red"]"MUTABAKAT MEKTUBU ve CH EXTRESİ MAİL EKİNDEDİR"[/COLOR]
ustyazı4 = [COLOR="red"]"İYİ ÇALIŞMALAR DİLERİZ."[/COLOR]

veri1 = "</tr></tbody></table><font color=black size=1 face=verdana" & _
"><div align=left><font size=5 color=red face=verdana></font></div></font></font></td></tr></tbody></table><table><tbody><tr><th colspan=3><div align=left><font size=3 color=red face=verdana>" & _
ustyazı1 & "<br>" & ustyazı2 & "</font></div></th></tr></tbody></table><table><tbody><tr><th colspan=3><div align=left><font size=3 color=#000000 face=verdana>" & _
ustyazı3 & "<br>" & ustyazı4 & "</font></div></th></tr></tbody></table><table></table>"


veri1 = veri1 & "<table border=1><tbody><tr><td align=left valign=center><font size=5 color=red face=verdana></font>" & _
"<font size=1 face=verdana><table border=0 bgcolor=d4d0c8 cellspacing=1 cellpadding=1 align=center><tbody>" & _
"<tr align=center valign=center bgcolor=white>"
  
For i = 1 To x

veri1 = veri1 & "</tr><tr bgcolor=white height=20><td><font color=black size=1 face=verdana></font></td>"
 
For j = 1 To y

If rngduz(i, j) = -4131 Then
bir = "left"
ElseIf rngduz(i, j) = -4108 Then
bir = "center"
ElseIf rngduz(i, j) = -4152 Then
bir = "right"
Else
bir = "justify"
End If

If rngBold(i, j) = False Then
iki = rngV(i, j)
ElseIf rngBold(i, j) = True Then
iki = "<b>" & rngV(i, j) & "</b>"
Else
iki = rngV(i, j)
End If

veri1 = veri1 & "<td align= " & bir & " bgcolor= " & rngFonClr(i, j) & "  nowrap=true ><" & _
"font size=3 color=" & rngClr(i, j) & " face=verdana>" & iki & "</font></td>"
Next

Next


altyazı1 = [COLOR="red"]"Sayın Müklellef"[/COLOR]
altyazı2 = [COLOR="red"]"Size ait tablo ekdeki gibidir."[/COLOR]
altyazı3 = [COLOR="red"]"MUTABAKAT MEKTUBU ve CH EXTRESİ MAİL EKİNDEDİR"[/COLOR]
altyazı4 = [COLOR="red"]"İYİ ÇALIŞMALAR DİLERİZ."[/COLOR]

veri1 = veri1 & "</tr></tbody></table><font color=black size=1 face=verdana" & _
"><div align=left><font size=5 color=red face=verdana></font></div></font></font></td></tr></tbody></table><table><tbody><tr><th colspan=3><div align=left><font size=3 color=red face=verdana>" & _
altyazı1 & "<br>" & altyazı2 & "</font></div></th></tr></tbody></table><table><tbody><tr><th colspan=3><div align=left><font size=3 color=#000000 face=verdana>" & _
altyazı3 & "<br>" & altyazı4 & "</font></div></th></tr></tbody></table><table></table>"

htmlyaz2 = "<br>" & veri1

ve

Kod: 
.HTMLBody = htmlyaz

yukarıdaki bölümün hemen altınada aşağıdaki kodu ekle
Kod: 
.HTMLBody = htmlya2


not:burada sayfada seçili alanı tablo halinde mail gövdesine ekleme yapıyor.
Genişletmek için tıkla ...

halit bey ilginiz için teşekkürler ancak ben bu yazdığınız ile belirlediğim sayfalardaki bölümleri nasıl tanımlıcam koda ve bu yazdıklarınızı açıklarsanız konuya bakan diğer arkadaşlarada yardımcı olabilirsiniz.
benim derdim diğer sayfalarıda ekteki makrom gibi aynı anda aynı mail gövdesine yapıştırmak :)
 
yasartomurcuk' Alıntı:
halit bey ilginiz için teşekkürler ancak ben bu yazdığınız ile belirlediğim sayfalardaki bölümleri nasıl tanımlıcam koda ve bu yazdıklarınızı açıklarsanız konuya bakan diğer arkadaşlarada yardımcı olabilirsiniz.
benim derdim diğer sayfalarıda ekteki makrom gibi aynı anda aynı mail gövdesine yapıştırmak :)
Genişletmek için tıkla ...

Ben alternatif olsun diye kod ekledim eklediğim kod sadece sayfada seçeli bölgeyi mail olarak gönderiyor.

Sayfada seçili bölge demek mause ile seçilen alan
 
Halit bey verdiğiniz kod yardım isteğimle bi alakası yok bende kodları uyarlamaya çalıştım 1 saat nese yinede teşekkürler
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst