DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Sub SendEmail()
Dim OutApp As Outlook.Application
Dim NewMail As Outlook.MailItem
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 "C:\Test.xls"
.Save
.Send
End With
Set NewMail = Nothing
Set OutApp = Nothing
End Sub
'******************************************************
'* 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
Sub Test()
MsgBox lionamic = xxrt
End Sub
Yukarıdaki prosedur True mu yoksa, False sonucunu mu döndürüyor sizin bilgisayarda ?
Sanırım espiri derin di?
Sub Email()
Sheets("D.REPORT").Select
Dim source As Range
Dim dest As Workbook
Dim strdate As String
Set source = Nothing
On Error Resume Next
Set source = Range("G3:I8").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If source Is Nothing Then
MsgBox "The source is not a range or the sheet is protect, please correct and try again.", vbOKOnly
Exit Sub
End If
Application.ScreenUpdating = False
Set dest = Workbooks.Add(xlWBATWorksheet)
source.Copy
With dest.Sheets(1)
.Cells(1).PasteSpecial PASTE:=8
' Paste:=8 will copy the column width in Excel 2000 and higher
' If you use Excel 97 use the other example
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
End With
strdate = Format(Now, "dd-mm-yy")
With dest
.SaveAs "virmanlar" & ThisWorkbook.Name _
& " " & strdate & ".xls"
.SendMail "birisi@birisi.com"
"VDMK2"
.ChangeFileAccess xlReadOnly
Kill .FullName
.Close False
End With
Application.ScreenUpdating = True
End Sub