Seçili alan maili

A

adventurous26

Altın Üye
Katılım
20 Haziran 2013
Mesajlar
291
Excel Vers. ve Dili
EXCELL 365
Altın Üyelik Bitiş Tarihi
02-11-2028
Arkadaşlar forumdan aldığım aşağıdaki kodları ekte dosyamda sarı ile boyadığım alanı göndermek istiyorum ancak bir türlü ayarlayamadı sadece üstteki satırı maile ekliyor ben module1 e ekledim bu kodları acaba yanlışmı yapıyorum yada nereyi düzeltmem gerekiyor.

Sub Mail_Selection_Range_Outlook_Body()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2016
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object

Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
Set rng = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a fixed range if you want
Set rng = Sheets("YourSheet").Range("B6:F26").SpecialCells(xlCellTypeVisible)
On Error GoTo 0

If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If

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

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

On Error Resume Next
With OutMail
.To = "ron@debruin.nl"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.HTMLBody = RangetoHTML(rng)
.Display 'or use .Display
End With
On Error GoTo 0

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

Set OutMail = Nothing
Set OutApp = Nothing
End Sub


Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook

TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With

'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With

'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")

'Close TempWB
TempWB.Close savechanges:=False

'Delete the htm file we used in this function
Kill TempFile

Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
 

Ekli dosyalar

A

adventurous26

Altın Üye
Katılım
20 Haziran 2013
Mesajlar
291
Excel Vers. ve Dili
EXCELL 365
Altın Üyelik Bitiş Tarihi
02-11-2028
teşekkür ederim ancak o kodları da denedim sayfama uyarlayamadım fazla bilgim yok kendi çapımda sizlerin desteğiyle çözmeye çalışıyorum
 
N

Necdet

Moderatör
Yönetici
Katılım
4 Haziran 2005
Mesajlar
15,353
Excel Vers. ve Dili
Ofis 365 Türkçe
Aşağıdaki kodlar işinize yarar.
Önce alanı seçeceksiniz, sonra aşağıdaki kodları çalıştıracaksınız.
Kod: 
Sub Mail_Selection()
'Working in 2000-2007
    Dim Source As Range
    Dim Dest As Workbook
    Dim Dosya As FileDialogSelectedItems ' --- Ben denememe yaptım
    Dim wb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim FileFormatNum As Long
 
    Set Source = Nothing
    On Error Resume Next
    Set Source = Selection.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If Source Is Nothing Then
        MsgBox "The source is not a range or the sheet is protected, please correct and try again.", vbOKOnly
        Exit Sub
    End If
 
    If ActiveWindow.SelectedSheets.Count > 1 Or _
       Selection.Cells.Count = 1 Or _
       Selection.Areas.Count > 1 Then
        MsgBox "An Error occurred :" & vbNewLine & vbNewLine & _
               "You have more than one sheet selected." & vbNewLine & _
               "You only selected one cell." & vbNewLine & _
               "You selected more than one area." & vbNewLine & vbNewLine & _
               "Please correct and try again.", vbOKOnly
        Exit Sub
    End If
 
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
 
    Set wb = ActiveWorkbook
    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 = "Selection 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
        FileExtStr = ".xlsx": FileFormatNum = 51
    End If
 
    With Dest
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        .SendMail "", _
                  "This is the Subject line"
        On Error GoTo 0
        .Close SaveChanges:=False
    End With
 
    Kill TempFilePath & TempFileName & FileExtStr
 
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub
 
A

adventurous26

Altın Üye
Katılım
20 Haziran 2013
Mesajlar
291
Excel Vers. ve Dili
EXCELL 365
Altın Üyelik Bitiş Tarihi
02-11-2028
Necdet' Alıntı:
Aşağıdaki kodlar işinize yarar.
Önce alanı seçeceksiniz, sonra aşağıdaki kodları çalıştıracaksınız.
Kod: 
Sub Mail_Selection()
'Working in 2000-2007
    Dim Source As Range
    Dim Dest As Workbook
    Dim Dosya As FileDialogSelectedItems ' --- Ben denememe yaptım
    Dim wb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim FileFormatNum As Long

    Set Source = Nothing
    On Error Resume Next
    Set Source = Selection.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If Source Is Nothing Then
        MsgBox "The source is not a range or the sheet is protected, please correct and try again.", vbOKOnly
        Exit Sub
    End If

    If ActiveWindow.SelectedSheets.Count > 1 Or _
       Selection.Cells.Count = 1 Or _
       Selection.Areas.Count > 1 Then
        MsgBox "An Error occurred :" & vbNewLine & vbNewLine & _
               "You have more than one sheet selected." & vbNewLine & _
               "You only selected one cell." & vbNewLine & _
               "You selected more than one area." & vbNewLine & vbNewLine & _
               "Please correct and try again.", vbOKOnly
        Exit Sub
    End If

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

    Set wb = ActiveWorkbook
    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 = "Selection 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
        FileExtStr = ".xlsx": FileFormatNum = 51
    End If

    With Dest
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        .SendMail "", _
                  "This is the Subject line"
        On Error GoTo 0
        .Close SaveChanges:=False
    End With

    Kill TempFilePath & TempFileName & FileExtStr

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub
Genişletmek için tıkla ...
Ancak ben hücreleri seçmek istemiyorum sarı ile boyadığım hücreler zaten sabit kendisi seçip göndermesini istiyorum birde maile excell dosyası olarak değilde direk yapıştırmasını nasıl sağlayabilirim
 
Son düzenleme:
E

excelokyanus500

Katılım
20 Şubat 2012
Mesajlar
242
Excel Vers. ve Dili
office2007 Türkçe
Deneyin..
Kod: 
Sub SelectByColor()
Dim cell As Range
Dim rng As Range
Dim FoundRange As Range

Set rng = Range("A2:OK500")

For Each cell In rng.Cells
If cell.Interior.ColorIndex = 6 Then   'Or cell.Interior.ColorIndex = 40
If FoundRange Is Nothing Then
Set FoundRange = cell
Else
Set FoundRange = Union(FoundRange, cell)
End If
End If
Next cell

If Not FoundRange Is Nothing Then FoundRange.Select
Call Mail_Selection_Range_Outlook_Body
End Sub


Sub Mail_Selection_Range_Outlook_Body()

  'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
  'Don't forget to copy the function RangetoHTML in the module.
  'Working in Excel 2000-2016
  '(ZVI-2018-01-05: modified a bit)
  Dim rng As Range
  Dim OutApp As Object
  Dim IsCreated As Boolean
 
  'Only the visible cells in the selection will be send
  Set rng = Selection
  'You can also use a fixed range if you want
  'Set rng = Sheets("YourSheet").Range("D4:D12")
 
  If TypeName(rng) <> "Range" Then
    MsgBox "The selection is not a range" & vbLf & "please correct and try again."
    Exit Sub
  End If
 
  On Error Resume Next
  Set OutApp = GetObject(, "Outlook.Application")
  If Err Then
    Set OutApp = CreateObject("Outlook.Application")
    IsCreated = True
  End If
  Err.Clear
 
  With OutApp.CreateItem(0)
    .BodyFormat = 2
    .Display  ' reqired for the signature
    .To = ""  ' "email.is.here"
    .CC = ""
    .BCC = ""
    .Subject = "This is the Subject line"
    .HtmlBody = RangetoHTML(rng) & .HtmlBody
    .Send
  End With
 
  ' Catch errors
  If Err Then
    Application.Visible = True
    MsgBox "E-mail has not been sent" & vbLf & Err.Description, vbExclamation, "Error"
  End If
 
  ' Try to quit Outlook if it was created via this code
  If IsCreated Then OutApp.Quit
 
  ' Release the memory of the object variable
  Set OutApp = Nothing
 
End Sub
 
 
Function RangetoHTML(rng As Range)
  ' Code of Ron de Bruin - https://www.rondebruin.nl/win/s1/outlook/bmail2.htm
  ' Working in Excel 2000-2016
  ' (ZVI-2018-01-05: modified for CF supporting)
 
  Dim TempFile As String, ddo As Long
  TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
 
  ' Temporary publish the rng range to a htm file
  ddo = ActiveWorkbook.DisplayDrawingObjects
  ActiveWorkbook.DisplayDrawingObjects = xlHide
  With ActiveWorkbook.PublishObjects.Add( _
       SourceType:=xlSourceRange, _
       Filename:=TempFile, _
       Sheet:=ActiveSheet.Name, _
       Source:=Union(rng, rng).Address, _
       HtmlType:=xlHtmlStatic)
    .Publish True
    .Delete
  End With
  ActiveWorkbook.DisplayDrawingObjects = ddo
 
  'Read all data from the htm file into RangetoHTML
  With CreateObject("Scripting.FileSystemObject").GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = Replace(.ReadAll, "align=center x:publishsource=", "align=left x:publishsource=")
    .Close
  End With
 
  'Delete the htm file we used in this function
  Kill TempFile
 
End Function
 
R

relaxim

Altın Üye
Katılım
30 Ağustos 2009
Mesajlar
520
Excel Vers. ve Dili
Ofis 2016 Tr 64 bit
Altın Üyelik Bitiş Tarihi
15.06.2027
Necdet' Alıntı:
Aşağıdaki kodlar işinize yarar.
Önce alanı seçeceksiniz, sonra aşağıdaki kodları çalıştıracaksınız.
Kod: 
Sub Mail_Selection()
'Working in 2000-2007
    Dim Source As Range
    Dim Dest As Workbook
    Dim Dosya As FileDialogSelectedItems ' --- Ben denememe yaptım
    Dim wb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim FileFormatNum As Long

    Set Source = Nothing
    On Error Resume Next
    Set Source = Selection.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If Source Is Nothing Then
        MsgBox "The source is not a range or the sheet is protected, please correct and try again.", vbOKOnly
        Exit Sub
    End If

    If ActiveWindow.SelectedSheets.Count > 1 Or _
       Selection.Cells.Count = 1 Or _
       Selection.Areas.Count > 1 Then
        MsgBox "An Error occurred :" & vbNewLine & vbNewLine & _
               "You have more than one sheet selected." & vbNewLine & _
               "You only selected one cell." & vbNewLine & _
               "You selected more than one area." & vbNewLine & vbNewLine & _
               "Please correct and try again.", vbOKOnly
        Exit Sub
    End If

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

    Set wb = ActiveWorkbook
    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 = "Selection 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
        FileExtStr = ".xlsx": FileFormatNum = 51
    End If

    With Dest
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        .SendMail "", _
                  "This is the Subject line"
        On Error GoTo 0
        .Close SaveChanges:=False
    End With

    Kill TempFilePath & TempFileName & FileExtStr

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub
Genişletmek için tıkla ...
Necdet Hocam 2016 türkçe ile çalıştırmak ne yapmalıyız? Dosya yolu doğru değil hatası verdi.
 
A

adventurous26

Altın Üye
Katılım
20 Haziran 2013
Mesajlar
291
Excel Vers. ve Dili
EXCELL 365
Altın Üyelik Bitiş Tarihi
02-11-2028
excelokyanus500' Alıntı:
Deneyin..
Kod: 
Sub SelectByColor()
Dim cell As Range
Dim rng As Range
Dim FoundRange As Range

Set rng = Range("A2:OK500")

For Each cell In rng.Cells
If cell.Interior.ColorIndex = 6 Then   'Or cell.Interior.ColorIndex = 40
If FoundRange Is Nothing Then
Set FoundRange = cell
Else
Set FoundRange = Union(FoundRange, cell)
End If
End If
Next cell

If Not FoundRange Is Nothing Then FoundRange.Select
Call Mail_Selection_Range_Outlook_Body
End Sub


Sub Mail_Selection_Range_Outlook_Body()

  'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
  'Don't forget to copy the function RangetoHTML in the module.
  'Working in Excel 2000-2016
  '(ZVI-2018-01-05: modified a bit)
  Dim rng As Range
  Dim OutApp As Object
  Dim IsCreated As Boolean

  'Only the visible cells in the selection will be send
  Set rng = Selection
  'You can also use a fixed range if you want
  'Set rng = Sheets("YourSheet").Range("D4:D12")

  If TypeName(rng) <> "Range" Then
    MsgBox "The selection is not a range" & vbLf & "please correct and try again."
    Exit Sub
  End If

  On Error Resume Next
  Set OutApp = GetObject(, "Outlook.Application")
  If Err Then
    Set OutApp = CreateObject("Outlook.Application")
    IsCreated = True
  End If
  Err.Clear

  With OutApp.CreateItem(0)
    .BodyFormat = 2
    .Display  ' reqired for the signature
    .To = ""  ' "email.is.here"
    .CC = ""
    .BCC = ""
    .Subject = "This is the Subject line"
    .HtmlBody = RangetoHTML(rng) & .HtmlBody
    .Send
  End With

  ' Catch errors
  If Err Then
    Application.Visible = True
    MsgBox "E-mail has not been sent" & vbLf & Err.Description, vbExclamation, "Error"
  End If

  ' Try to quit Outlook if it was created via this code
  If IsCreated Then OutApp.Quit

  ' Release the memory of the object variable
  Set OutApp = Nothing

End Sub


Function RangetoHTML(rng As Range)
  ' Code of Ron de Bruin - https://www.rondebruin.nl/win/s1/outlook/bmail2.htm
  ' Working in Excel 2000-2016
  ' (ZVI-2018-01-05: modified for CF supporting)

  Dim TempFile As String, ddo As Long
  TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

  ' Temporary publish the rng range to a htm file
  ddo = ActiveWorkbook.DisplayDrawingObjects
  ActiveWorkbook.DisplayDrawingObjects = xlHide
  With ActiveWorkbook.PublishObjects.Add( _
       SourceType:=xlSourceRange, _
       Filename:=TempFile, _
       Sheet:=ActiveSheet.Name, _
       Source:=Union(rng, rng).Address, _
       HtmlType:=xlHtmlStatic)
    .Publish True
    .Delete
  End With
  ActiveWorkbook.DisplayDrawingObjects = ddo

  'Read all data from the htm file into RangetoHTML
  With CreateObject("Scripting.FileSystemObject").GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = Replace(.ReadAll, "align=center x:publishsource=", "align=left x:publishsource=")
    .Close
  End With

  'Delete the htm file we used in this function
  Kill TempFile

End Function
Genişletmek için tıkla ...
kodları denedim ama maile sadece resimdeki gibi bir alanı atıyor rica etsem eklediğim dosyadan kontrol edebilirmisiniz benim için sarıya boyadığım hücreleri yapıştırsa yeterli

247871
 

Ekli dosyalar

E

excelokyanus500

Katılım
20 Şubat 2012
Mesajlar
242
Excel Vers. ve Dili
office2007 Türkçe
adventurous26' Alıntı:
kodları denedim ama maile sadece resimdeki gibi bir alanı atıyor rica etsem eklediğim dosyadan kontrol edebilirmisiniz benim için sarıya boyadığım hücreleri yapıştırsa yeterli

Ekli dosyayı görüntüle 247871
Genişletmek için tıkla ...
adventurous26' Alıntı:
kodları denedim ama maile sadece resimdeki gibi bir alanı atıyor rica etsem eklediğim dosyadan kontrol edebilirmisiniz benim için sarıya boyadığım hücreleri yapıştırsa yeterli

Ekli dosyayı görüntüle 247871
Genişletmek için tıkla ...

Dosyanızı görme imkanım malesef yok. Ancak şunu yapın.
Sarı hücre alanı hep aynı hücrelerse;

SADECE bu makroyu çalıştırırsanız işinizi görecektir.

Sub Mail_Selection_Range_Outlook_Body()


'Only the visible cells in the selection will be send
'Set rng = Selection
'You can also use a fixed range if you want
Set rng = Sheets("Sayfa1").Range("A4:E12") ' Burayı sayfanızı ve sarı alanı gösterir sekilde düzenleyin.
 
A

adventurous26

Altın Üye
Katılım
20 Haziran 2013
Mesajlar
291
Excel Vers. ve Dili
EXCELL 365
Altın Üyelik Bitiş Tarihi
02-11-2028
excelokyanus500' Alıntı:
Dosyanızı görme imkanım malesef yok. Ancak şunu yapın.
Sarı hücre alanı hep aynı hücrelerse;

SADECE bu makroyu çalıştırırsanız işinizi görecektir.

Sub Mail_Selection_Range_Outlook_Body()


'Only the visible cells in the selection will be send
'Set rng = Selection
'You can also use a fixed range if you want
Set rng = Sheets("Sayfa1").Range("A4:E12") ' Burayı sayfanızı ve sarı alanı gösterir sekilde düzenleyin.
Genişletmek için tıkla ...
Teşekkür ederim akşam deneyeceğim
 
A

adventurous26

Altın Üye
Katılım
20 Haziran 2013
Mesajlar
291
Excel Vers. ve Dili
EXCELL 365
Altın Üyelik Bitiş Tarihi
02-11-2028
Bunu ben malesef tariflerinizle çözemiyorum uzman arkadaşlardan rica ediyorum eklediğim dosyada düzenleyebilirmisiniz?
 
E

Erkan Akayay

Altın Üye
Katılım
8 Aralık 2006
Mesajlar
405
Excel Vers. ve Dili
Ofis 365 TR 64 Bit
Altın Üyelik Bitiş Tarihi
21-11-2028
Kodunuzda ufak bir değişiklik yaptım.
Sabit alan dediniz, bende kodda sabitledim.
 

Ekli dosyalar

Cevap yazmak için giriş yap yada kayıt ol.
Üst