autofilter ile filtre edilen sayfayı mail ile atmak

[hakan439]

Arkadaşlar, şirkette fatura ve raporlama için Excel ve access kullanıyorz. her fatura kesildiginde satış detaylarını Bir macro ile bir mdb dosyasına raporlama adı altında bir tablo ya yazdırıyoruz. sonrada bir excel dosyası ile burdan verileri açlırken indiriyoruz. sorun suki 1500 sütünluk veriyi autofilter ile müşteri ve ürün bazında seçebliyoruz. ben im istediğim ise:

Bir kaleme ait satış raporunu (bir müşterinin tüm satışları, bir ürününü tüm satışları vs...) müşteriye mail atabileceğim bir macro istiyorum ancak burda sorun su:

Sitede verilen outlook tan mail atma kodları işime yaramıyor çünkü o kodlar tüm sayfayı gönderiyor. halbuki benim sayfada başka müşterilerin de kayıtları oluyor ve fiyat bilgiside var. benim istediğim
Alanceç macrosuna eklenecek bir kod; bu kod
-Bana bir outlook mail penceresi acsın, dosyada filtre edilen kısımları alsın sadece ve bunu attachment olarak hazırlasın, ve ben orda gonderecegim kişiyi girebileyim adres kısmına. Dosya ektedir. yardımcı olabilecek arkadas varsa sevinirim.

 

[hsayar]

Sub Makro1()
    Cells.Select
    Selection.Copy
    Sheets.Add
    Cells.Select
    ActiveSheet.Paste
End Sub

yukarıdaki kodlar Autofilter ile elde edilen sayfa görüntüsünü yeni sayfa olarak kopyalar

http://www.excel.web.tr/showthread.php?t=43902

sn halukun aktifsayfayı elmek et kodlarında göndereceğiniz elmek adresini yazınca olay biter.

bu basitçe bir çözümdü.

 

[hakan439]

Sub Makro1()
    Cells.Select
    Selection.Copy
    Sheets.Add
    Cells.Select
    ActiveSheet.Paste
End Sub

yukarıdaki kodlar Autofilter ile elde edilen sayfa görüntüsünü yeni sayfa olarak kopyalar

http://www.excel.web.tr/showthread.php?t=43902

sn halukun aktifsayfayı elmek et kodlarında göndereceğiniz elmek adresini yazınca olay biter.

bu basitçe bir çözümdü.

İyi günler. bahsettiğiniz kod sanırım aşagıdaki kod. ancak bunun tam olarak neresine eklemem gerekiyor sizin gonderdiginiz kısmı? Birde bu kodu ben denedim. ancak bu kod direk e-mail gonderiyor kodda belirtilen e-mail adresine. her seferinde koda girip degistirmek gerekiyor ozaman e-mail adresini. Yada excel de bir cell de tutucam e-mail adresini ama genelde e-mail ları da ezbere bilmiyorum, outlooku acıp bakmam gerekiyor. bu sebeble bir outlook new mail penceresi acılsın istiyorum ki orada adres cubugunda kayıtlı adreslerime kolayca ulsabileyim

[vb:1:a87fbdb470]'************************************************* *****
'* Sadece Aktif sayfayı MS Outlook ile yollamak için *
'* yapılmış bir çalışmadır *
'* Micosoft Outlook X.0 referansı eklenmelidir ! *
'* Burası Excel vadisi ... *
'* Raider ® *
'* �ubat 2005 *
'************************************************* *****

Sub SendShByEmail()
Dim OutApp As Outlook.Application
Dim NewMail As Outlook.MailItem
Dim ShName As String, WbName As String
Dim i As Integer
Dim ModX As Object, VBComp As Object

ShName = ActiveSheet.Name
WbName = "C:\" & ShName & ".xls"

ThisWorkbook.SaveCopyAs WbName

Application.DisplayAlerts = False
Workbooks.Open WbName
For i = Sheets.Count To 1 Step -1
If ActiveWorkbook.Sheets(i).Name <> ShName Then Sheets(i).Delete
Next

On Error Resume Next
For Each ModX In ActiveWorkbook.VBProject.VBComponents
Set VBComp = ActiveWorkbook.VBProject.VBComponents(ModX.Name)
ActiveWorkbook.VBProject.VBComponents.Remove VBComp
Next
On Error GoTo 0
Application.DisplayAlerts = True

ActiveWorkbook.Close SaveChanges:=True

Set OutApp = New Outlook.Application
Set NewMail = CreateItem(olMailItem)
With NewMail
.To = "falan@filan.com"
.Subject = "Deneme"
.Body = "Bu e-mail deneme amacıyla gönderilmiştir."
.Attachments.Add WbName
.Save
.Send
End With
Set NewMail = Nothing
Set OutApp = Nothing
Set VBComp = Nothing
Kill WbName
End Sub
[/vb:1:a87fbdb470]

 

[hsayar]

Sub SendShByEmail()
'buraya benim gönderdiklerimi ekleyip deneyiniz
Dim OutApp As Outlook.Application
...................

elmek adreisnide textboxdan aldırabilirsiniz, ama butonla elmek veritabnından seçim nasıl olur şimdilik fikrim yok

 

[hsayar]

sn hakan439 bu bilgi işinize yaradımı?

 

[ünal karadavut]

sayın arkadaşlar.
çok güzel bilgiler gönderiyorsunuz,
ama gönderilen bilgiler beni ve benimgibileri aşıyor.
gönderilen bilgileri (işi bilen, uzman arkadaşlar) DERLEYİP gönderirlerse bizde faydalanma imkanı buluruz.
yoksa sadece bakmakla yetiniyoruz.
herkese kolay gelsin.

 

[hakan439]

sn hakan439 bu bilgi işinize yaradımı?

maalesef tam olarak değil. gönderdiğiniz kodun son satırı (activesheet.paste) hata veriyor. gecerli kopyalama metodu diil gibi bir hata. ben soyle bir kod buldum onu değiştirmeye çalışıyorum 2 gündür. bu tam olarak istediğim şeyi yapıyor ancak filtre edilen kısımları değil de tüm sayfayı alıyor. size de bir göndereyim bakın isterseniz:

Option Explicit

Sub Mail_ActiveSheet()
'Working in 2000-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 OutApp As Object
    Dim OutMail As Object

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

    Set Sourcewb = ActiveWorkbook

    'Copy the sheet to a new workbook
    ActiveSheet.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

    '    'Change all cells in the worksheet to values if you want
    '    With Destwb.Sheets(1).UsedRange
    '        .Cells.Copy
    '        .Cells.PasteSpecial xlPasteValues
    '        .Cells(1).Select
    '    End With
    '    Application.CutCopyMode = False

    'Save the new workbook/Mail it/Delete it
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

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

    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        With OutMail
            .To = "ron@debruin.nl"
            .CC = ""
            .BCC = ""
            .Subject = "This is the Subject line"
            .Body = "Hi there"
            .Attachments.Add Destwb.FullName
            'You can add other files also like this
            '.Attachments.Add ("C:\test.txt")
            .Display   'or use .Send
        End With
        On Error GoTo 0
        .Close SaveChanges:=False
    End With

    'Delete the file you have send
    Kill TempFilePath & TempFileName & FileExtStr

    Set OutMail = Nothing
    Set OutApp = Nothing

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

 

[hsayar]

sn hakan439 eğer excel2007 sayfası göndermekten bahsediyorsanız hiç bir fikrim yok

siz göndereceğinişz sayfanın bilgileri önemsiz hala getirerek bir örnek gönderin bakalım

siz sayfayı direk göndermek yerine outlok ekranına otomatik olarak eklenti haline gelmesinden bahsediyorsunuz galiba.....

kodları inceleyip bir bakayım belki olur

 

[hakan439]

dosyalar ekte. şu anda sadece calışılan worksheet i gonderiyor. ancak filtre edilen kısımları değik sayfanın tamamını gonderiyor. bunu bir müşteriye gonderdiğim zaman müşteri tüm firmaların bilgilerini gorebilir. bu yüzden sadece filre edilenkısmı gondermesini istiyorum. mail atma ile ilgili bir kac kod daha buldum. onlarıda da gonderiyorum size. rar dosyasının içinde çeşitli mail atma kodları mevcut.

 

[hsayar]

Option Explicit

Sub Mail_ActiveSheet()
'Filtre edilen alanı yeni sayfaya alır

    Cells.Select:    Selection.Copy
    Sheets.Add:      Cells.Select
    Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False   'sütun genişlikleirni kopyalar
    Cells.Select
    ActiveSheet.Paste   'herşeyi kopyalar
    'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False  'sadece değerleri kopyalar
    'Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False   'biçimleri kopyalar


'Working in 2000-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 OutApp As Object
    Dim OutMail As Object

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

    Set Sourcewb = ActiveWorkbook

    'Copy the sheet to a new workbook
    ActiveSheet.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

    '    'Change all cells in the worksheet to values if you want
    '    With Destwb.Sheets(1).UsedRange
    '        .Cells.Copy
    '        .Cells.PasteSpecial xlPasteValues
    '        .Cells(1).Select
    '    End With
    '    Application.CutCopyMode = False

    'Save the new workbook/Mail it/Delete it
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

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

    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        With OutMail
            .To = "ron@debruin.nl"
            .CC = ""
            .BCC = ""
            .Subject = "This is the Subject line"
            .Body = "Hi there"
            .Attachments.Add Destwb.FullName
            'You can add other files also like this
            '.Attachments.Add ("C:\test.txt")
            .Display   'or use .Send
        End With
        On Error GoTo 0
        .Close SaveChanges:=False
    End With

    'Delete the file you have send
    Kill TempFilePath & TempFileName & FileExtStr
    Application.ScreenUpdating = False
       Sheets(1).Delete
    'Application.ScreenUpdating = False
 
    Set OutMail = Nothing
    Set OutApp = Nothing

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

deneyiniz

 

[hakan439]

    ActiveSheet.Paste   'herşeyi kopyalar

bu satırda hata verdi. Ayrıca yeni bir sheet açıyor. ancak daha önce de soyledim, bu komut ta bir sorun variyor benim excel. Ayrıca mail attıktan sonra bu sayfanında silinmesini istiyorum cunku arka arkaya 2,3 müşteriye bunu gönderdiğimde her seferinde sayfa ekleniyor programa.
BU arada ben kodu biraz değiştirdim. şimdi sadece tabloyu alıyor kalanları almıyor.

    Sub mail()
Dim say As Integer
say = WorksheetFunction.CountA(Range("H1:H65000"))
Range("A1:k1").Select '(Bu bölüm sayfadaki başlık kısmı)
say = say + 10
ActiveSheet.PageSetup.PrintArea = "$A$1:$k$" & say
Range("B2").Select
'ActiveWindow.SelectedSheets.PrintPreview
'----------------------------------------------------------------------

'esas kod burdan başlıyor. forumda gönderdim zaten size de.
'Üst taraf sadece print area yı son girilen satırı kapsayacak
'şekilde ayarlıyor.

'----------------------------------------------------------------------
'----------------------------------------------------------------------
'burayı biraz değiştirdim. artık sadece taloyu alıyor tüm sayfa yerine
'----------------------------------------------------------------------
'----------------------------------------------------------------------

'Filtre edilen alanı yeni sayfaya alır;


    Range("$A$1:$k$" & say).Select:    Selection.Copy
    Sheets.Add:      Cells.Select
    Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False   'sütun genişlikleirni kopyalar
    Range("$A$1:$k$" & say).Select
    
    
    ActiveSheet.Paste   'herşeyi kopyalar
    'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False  'sadece değerleri kopyalar
    'Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False   'biçimleri kopyalar


'Working in 2000-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 OutApp As Object
    Dim OutMail As Object

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

    Set Sourcewb = ActiveWorkbook

    'Copy the sheet to a new workbook
    ActiveSheet.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

    '    'Change all cells in the worksheet to values if you want
    '    With Destwb.Sheets(1).UsedRange
    '        .Cells.Copy
    '        .Cells.PasteSpecial xlPasteValues
    '        .Cells(1).Select
    '    End With
    '    Application.CutCopyMode = False

    'Save the new workbook/Mail it/Delete it
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

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

    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        With OutMail
            .To = "ron@debruin.nl"
            .CC = ""
            .BCC = ""
            .Subject = "This is the Subject line"
            .Body = "Hi there"
            .Attachments.Add Destwb.FullName
            'You can add other files also like this
            '.Attachments.Add ("C:\test.txt")
            .Display   'or use .Send
        End With
        On Error GoTo 0
        .Close SaveChanges:=False
    End With

    'Delete the file you have send
    Kill TempFilePath & TempFileName & FileExtStr
    Application.ScreenUpdating = False
       Sheets(1).Delete
    'Application.ScreenUpdating = False
 
    Set OutMail = Nothing
    Set OutApp = Nothing

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

End Sub

 

[hsayar]

hocam birdr bunu deneyin

Sub Mail_ActiveSheet()
Application.ScreenUpdating = False
'süzülen kriterlerin başlıklarını ve değerlerini bulur
Dim suz As Variant
ReDim suz(ActiveSheet.AutoFilter.Filters.Count)
sonfiltsut = ActiveSheet.AutoFilter.Filters.Count
For a = sonfiltsut To 1 Step -1
    If ActiveSheet.AutoFilter.Filters.Item(a).On Then
        c = c + 1
        stnno = ActiveSheet.AutoFilter.Range.Cells(a).Column
        strno = ActiveSheet.AutoFilter.Range.Cells(a).Row
        SuzBas = ActiveSheet.AutoFilter.Range.Cells(a).Value
        SuzKrt = Kriterler(Cells(strno + 1, stnno))
        suz(c) = SuzBas & ": " & SuzKrt
        snc = suz(c) & ", " & snc
    End If
Next

'Filtrelenmiş başlıkları yeni sayfaya kopyalar
    Cells.Select:    Selection.Copy
    Sheets.Add:      Cells.Select
    Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False   'sütun genişlikleirni kopyalar
    Cells.Select
    ActiveSheet.Paste   'herşeyi kopyalar
    Application.CutCopyMode = False
    Cells(1, 1).Select
    'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False  'sadece değerleri kopyalar
    'Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False   'biçimleri kopyalar
   'MsgBox snc



'oluşturulan yeni sayfanının kenarlık ve yazdırma alanlarını düzenler
sonsut = Cells(strno, 1).End(xlToRight).Column
sonsat = Cells(65536, 1).End(xlUp).Row
'MsgBox strno & " / " & stnno & " / " & sonsut & " / " & sonsat
'Exit Sub
    
   Range(Cells(strno - 5, 1), Cells(strno - 5, sonsut)).Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    With Selection.Font
        .Name = "Arial Tur"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
    Rows(strno - 5).RowHeight = 19.5
    Selection.Font.Bold = True
    Cells(strno - 5, 1).Value = snc & " Raporudur"
    ' ThisWorkbook.Sheets(1).Delete
'mevcut kenarlıkları sil
    Cells.Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
'yeni kenarlık çiz
    'Range("A11:K55").Select
    Range(Cells(strno, 1), Cells(sonsat, sonsut)).Select

    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
'************************************************
'yazdırma alanını belirle

ActiveSheet.PageSetup.PrintArea = "$A$1:$K$" & sonsat
    With ActiveSheet.PageSetup
        .LeftMargin = Application.InchesToPoints(0.393700787401575)
        .RightMargin = Application.InchesToPoints(0.393700787401575)
        .TopMargin = Application.InchesToPoints(0.984251968503937)
        .BottomMargin = Application.InchesToPoints(0.984251968503937)
        .HeaderMargin = Application.InchesToPoints(0.511811023622047)
        .FooterMargin = Application.InchesToPoints(0.511811023622047)
        .Orientation = xlLandscape
    End With
Cells(1, 1).Select
  
  
'buradan itibaren aktif sayfayı otutlook 2003 e eklenti olarak ekler.
    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 OutApp As Object
    Dim OutMail As Object

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

    Set Sourcewb = ActiveWorkbook

    'Copy the sheet to a new workbook
    ActiveSheet.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")

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

    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        With OutMail
            .To = ""
            .CC = ""
            .BCC = ""
            .Subject = snc & " Raporudur" '"This is the Subject line"
            .Body = "Hi there"
            .Attachments.Add Destwb.FullName
            'You can add other files also like this
            '.Attachments.Add ("C:\test.txt")
            .Display   'or use .Send
        End With
        On Error GoTo 0
        .Close SaveChanges:=False
    End With

    'Delete the file you have send
    Kill TempFilePath & TempFileName & FileExtStr
    Application.DisplayAlerts = False   'ekrana mesaj vermeyi kapat
        Sheets(1).Delete
    Application.DisplayAlerts = True   'ekrana mesaj vermeyi a&#231;

    Set OutMail = Nothing
    Set OutApp = Nothing

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    
MsgBox "tamamland&#305;"
End Sub

süzülen kriterleri konu başlığı olarak eklemek için gereklidir.

Function Kriterler(BaslikAlti As Range) As String
Dim Filter As String
Filter = ""
On Error GoTo son
With BaslikAlti.Parent.AutoFilter
If Intersect(BaslikAlti, .Range) Is Nothing Then GoTo son
With .Filters(BaslikAlti.Column - .Range.Column + 1)
If Not .On Then GoTo son
Filter = Replace(.Criteria1, "=", """", 2)
Filter2 = Replace(.Criteria2, "=", """", 2)

Select Case .Operator
Case xlAnd
Filter = Filter & " ve " & Filter2
Case xlOr
Filter = Filter & " veya " & Filter2
End Select

End With
End With
son:
Kriterler = Filter
End Function

 

[hsayar]

buda çalışmazsa nedenini bilemem hiç bir değişklik yapmadan gözleyin önce
sizin istediğiniz gibi
1) filtre sonucu elde edilen hücreleri yeni sayfaya alıyor.
2) yeni sayfada kenarlıkları ve yazdırma alanını tekrar yapılandırıyor.
3) sayfayı yataya çeviriyor
4) elde edilen sayfayı outloka eklenti olarak keliyor.

activesheet.paste neden hata verir bilmiyorum.

ayrı bir başlıkta activesheet.paste Hata sorunu diye konu açın isterseniz.

 

[hsayar]

aşağıdaki kodlar ile veriler süzülmüşse süzülen alanı
süzülmemiş ise sayfanın tamamın gönderir.

Sub Mail_ActiveSheet()
Application.ScreenUpdating = False
'süzülen kriterlerin başlıklarını ve değerlerini bulur
If ActiveSheet.FilterMode = False Then GoTo TAMAMINIGONDER
Dim suz As Variant
ReDim suz(ActiveSheet.AutoFilter.Filters.Count)
sonfiltsut = ActiveSheet.AutoFilter.Filters.Count
For a = sonfiltsut To 1 Step -1
    If ActiveSheet.AutoFilter.Filters.Item(a).On Then
        c = c + 1
        stnno = ActiveSheet.AutoFilter.Range.Cells(a).Column
        strno = ActiveSheet.AutoFilter.Range.Cells(a).Row
        SuzBas = ActiveSheet.AutoFilter.Range.Cells(a).Value
        SuzKrt = Kriterler(Cells(strno + 1, stnno))
        suz(c) = SuzBas & ": " & SuzKrt
        snc = suz(c) & ", " & snc
    End If
Next

'Filtrelenmiş başlıkları yeni sayfaya kopyalar
    Cells.Select:    Selection.Copy
    Sheets.Add:      Cells.Select
    Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False   'sütun genişlikleirni kopyalar
    Cells.Select
    ActiveSheet.Paste   'herşeyi kopyalar
    Application.CutCopyMode = False
    Cells(1, 1).Select
    'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False  'sadece değerleri kopyalar
    'Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False   'biçimleri kopyalar
   'MsgBox snc
'oluşturulan yeni sayfanının kenarlık ve yazdırma alanlarını düzenler
sonsut = Cells(strno, 1).End(xlToRight).Column
sonsat = Cells(65536, 1).End(xlUp).Row
'MsgBox strno & " / " & stnno & " / " & sonsut & " / " & sonsat
'Exit Sub
    
   Range(Cells(strno - 5, 1), Cells(strno - 5, sonsut)).Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    With Selection.Font
        .Name = "Arial Tur"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
    Rows(strno - 5).RowHeight = 19.5
    Selection.Font.Bold = True
    Cells(strno - 5, 1).Value = snc & " Raporudur"
    ' ThisWorkbook.Sheets(1).Delete
'mevcut kenarlıkları sil
    Cells.Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
'yeni kenarlık çiz
    'Range("A11:K55").Select
    Range(Cells(strno, 1), Cells(sonsat, sonsut)).Select

    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
'************************************************
'yazdırma alanını belirle

ActiveSheet.PageSetup.PrintArea = "$A$1:$K$" & sonsat
    With ActiveSheet.PageSetup
        .LeftMargin = Application.InchesToPoints(0.393700787401575)
        .RightMargin = Application.InchesToPoints(0.393700787401575)
        .TopMargin = Application.InchesToPoints(0.984251968503937)
        .BottomMargin = Application.InchesToPoints(0.984251968503937)
        .HeaderMargin = Application.InchesToPoints(0.511811023622047)
        .FooterMargin = Application.InchesToPoints(0.511811023622047)
        .Orientation = xlLandscape
    End With
Cells(1, 1).Select
  
TAMAMINIGONDER:
'buradan itibaren aktif sayfayı otutlook 2003 e eklenti olarak ekler.
    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 OutApp As Object
    Dim OutMail As Object

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

    Set Sourcewb = ActiveWorkbook

    'Copy the sheet to a new workbook
    ActiveSheet.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

    ek = snc
    If ek = "" Then ek = "T&#252;m dosya"
   'Save the new workbook/Mail it/Delete it
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

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

    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        With OutMail
            .To = ""
            .CC = ""
            .BCC = ""
            .Subject = ek & " Raporudur" '"This is the Subject line"
            .Body = "Hi there"
            .Attachments.Add Destwb.FullName
            'You can add other files also like this
            '.Attachments.Add ("C:\test.txt")
            .Display   'or use .Send
        End With
        On Error GoTo 0
        .Close SaveChanges:=False
    End With

    'Delete the file you have send
    Kill TempFilePath & TempFileName & FileExtStr
    If snc <> "" Then
    Application.DisplayAlerts = False   'ekrana mesaj vermeyi kapat
        Sheets(1).Delete
    Application.DisplayAlerts = True   'ekrana mesaj vermeyi a&#231;
    End If
    Set OutMail = Nothing
    Set OutApp = Nothing

    Application.ScreenUpdating = True
        
MsgBox "tamamland&#305;"
End Sub

 

[hsayar]

eğer veriler süzülmemişse göndermek istemiyorsanız
If ActiveSheet.FilterMode = False Then GoTo TAMAMINIGONDER
satırını
If ActiveSheet.FilterMode = False Then MsgBox "veriler süzülmemiş": Exit Sub
satırı ile değiştiriniz

 

[ünal karadavut]

bende "

Hotmail'le %s olarak bağlantı kurulamadı.

Hotmail artık ücretsiz e-posta hesapları için Outlook Express aracılığıyla e-posta erişimine izin vermiyor.

Hesap: 'MSN', Sunucu: 'http://oe.msn.msnmail.hotmail.com/cgi-bin/hmdata', İletişim Kuralları: HTTPMail, Sunucu Yanıtı: 'Access to Hotmail via Outlook and Outlook Express now requires a subscription. Please sign up at http://join.msn.com/general/Email', Bağlantı Noktası: 0, Güvenli(SSL): Hayır, Sunucu Hatası: 998, Hata numarası: 0x800CCCF6

"

bu mesaj çıkıyor.

lütfen ya nasıl bir yol izleyeceğimizi aşama aşama anlatsın, yada en son halini bir örnek dosya yapıp göndersin.

 

[hsayar]

bende "

Hotmail'le %s olarak bağlantı kurulamadı.

Hotmail artık ücretsiz e-posta hesapları için Outlook Express aracılığıyla e-posta erişimine izin vermiyor.

Hesap: 'MSN', Sunucu: 'http://oe.msn.msnmail.hotmail.com/cgi-bin/hmdata', İletişim Kuralları: HTTPMail, Sunucu Yanıtı: 'Access to Hotmail via Outlook and Outlook Express now requires a subscription. Please sign up at http://join.msn.com/general/Email', Bağlantı Noktası: 0, Güvenli(SSL): Hayır, Sunucu Hatası: 998, Hata numarası: 0x800CCCF6

"

bu mesaj çıkıyor.

lütfen ya nasıl bir yol izleyeceğimizi aşama aşama anlatsın, yada en son halini bir örnek dosya yapıp göndersin.

verdiğim kodlar outlok 2003 için için geçerlidir

Set OutApp = CreateObject("Outlook.Application")

gmail kullanın
http://mail.google.com/support/bin/answer.py?hl=tr&answer=77661

 

[hsayar]

sn hakan 439 deneme şansınız oldumu acaba

 

[hakan439]

Sn. hsayar,

12. mesajda yazdıgınız kodlar, 13. mesajınızda eklediğiniz dosyada var mı? eğer aynı kodlar sa, eklediğiniz dosyayı indirdim denedim ancak aynı satırda yine hata verdi. benim excel de mi bir sorun var anlayamadım. siz denediğinizde sorun var mıy dı

 

[hsayar]

hayır bende yoktu......