Option Compare Database
Option Explicit
Private Const RaporDosyasi As String = "Raporlar"
Private Const Yolbelirle As String = "*^*"
Sub P_Mailgövdesinde_gönder(MailSubject As String, _
TxtBody As String, _
MailAddress As String) 'değişkenler mail metni , mail adresi ve konu
On Error GoTo ErrTrap
' Posta göndermeden önce HTML dosyasını outlook gövdesine uyacak
Dim olk As Outlook.Application
Dim msg As Outlook.MailItem
' outlook açıksa kullan,açık değilse yeni sayfa aç
Err.Clear
On Error Resume Next
Set olk = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Set olk = New Outlook.Application
End If
Err.Clear
On Error GoTo ErrTrap
Set msg = olk.CreateItem(olMailItem)
With msg 'With yapısı kısaca, aynı koleksiyona ait komut yapılarını kullanarak hazırladığımız kodları kısaltmamızı sağlar..
.Display
.To = MailAddress
.Subject = MailSubject
.BodyFormat = olFormatHTML
.HTMLBody = TxtBody
.To = MailAddress
End With
' mesajı gönder
On Error Resume Next
msg.Send
' kullanıcı mesaj sonrası uyarı versin
ExitPoint:
On Error Resume Next
olk.Quit
Set msg = Nothing
Set olk = Nothing
On Error GoTo 0
Exit Sub
ErrTrap:
MsgBox Err.Number & " - " & Err.Description
Resume ExitPoint
End Sub
Function Fn_DosyaOlustur(ByVal FolderPath _
As String) As Integer
On Error GoTo ErrTrap
Dim fso As Scripting.FileSystemObject
Dim fdr As Scripting.Folder
Set fso = New Scripting.FileSystemObject
'Klasörün var olup olmadığını kontrol edin
If Not fso.FolderExists(FolderPath) Then
'Gerekirse bir klasör oluşturun
Set fdr = fso.CreateFolder(FolderPath)
End If
If fso.FolderExists(FolderPath) Then
Fn_DosyaOlustur = 1
Else
Fn_DosyaOlustur = 0
End If
ExitPoint:
On Error Resume Next
Set fdr = Nothing
Set fso = Nothing
On Error GoTo 0
Exit Function
ErrTrap:
MsgBox Err.Number & " - " & Err.Description
Resume ExitPoint
End Function
Sub P_RaporuGonder( _
RepName As String, MailAddress As String, MailSubject As String, Preface As String)
On Error GoTo ErrTrap
'
Dim FilePathWord As String
Dim FilePathHTML As String
Dim RepFolderPath As String
Dim TxtBody As String
Dim fso As FileSystemObject
Dim fe As TextStream
Dim wdp As Word.Application
Dim doc As Word.Document
'Klasör oluşturun (varsa kullan)
RepFolderPath = CurrentProject.path & _
"\" & RaporDosyasi
Call Fn_DosyaOlustur(RepFolderPath)
' Rapor çıktı dosyaları için yolunu ayarlayın.
FilePathWord = RepFolderPath & "\" & _
RepName & ".DOC"
FilePathHTML = RepFolderPath & "\" & _
RepName & ".HTML"
' varsa dosyaları silin
On Error Resume Next
Kill FilePathWord
Kill FilePathHTML
On Error GoTo ErrTrap
'
DoCmd.OutputTo acOutputReport, RepName, _
acFormatRTF, FilePathWord, False
Err.Clear
On Error Resume Next
Set wdp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set wdp = New Word.Application
End If
Err.Clear
On Error GoTo ErrTrap
' Varsa Word uygulamasını kullanın,yoksa yeni
Set doc = wdp.Documents.Open(FilePathWord)
P_metinekle wdp.Selection, Preface
doc.Save
' word dosyaını html kaydet
doc.SaveAs FileName:=FilePathHTML, _
FileFormat:=wdFormatHTML
doc.Close
wdp.Quit False
Set doc = Nothing
Set wdp = Nothing
Set fso = New FileSystemObject
Set fe = fso.OpenTextFile(FilePathHTML, ForReading)
TxtBody = Nz(fe.ReadAll, "")
TxtBody = Replace(TxtBody, Yolbelirle, "")
P_Mailgövdesinde_gönder MailSubject, TxtBody, MailAddress
ExitPoint:
On Error Resume Next
Set fe = Nothing
Set fso = Nothing
On Error GoTo 0
Exit Sub
ErrTrap:
MsgBox Err.Number & " - " & Err.Description
Resume ExitPoint
End Sub
Sub Lütfen_bekleyiniz(ByVal Tmr As Long)
On Error GoTo ErrTrap
Dim Cnt As Long
For Cnt = 1 To Tmr
DoEvents
Next
ExitPoint:
On Error GoTo 0
Exit Sub
ErrTrap:
MsgBox Err.Number & " - " & Err.Description
Resume ExitPoint
End Sub
Sub P_metinekle(sel As Word.Selection, _
Preface As String)
On Error Resume Next
' Burada mailin başına gelecek metin
' word document
With sel
.HomeKey Unit:=wdStory 'sayfa başı home
.TypeParagraph 'bunlar
.TypeParagraph 'üstten boşluk 2 enter yani
.MoveUp Unit:=wdLine, Count:=2 'MoveUp (Birimi, sayın uzatın)wdLine, wdParagraph, wdWindow veya wdScreen
.TypeText Text:=Preface
.TypeParagraph 'alttan 1 boşluk
.HomeKey Unit:=wdStory, Extend:=wdExtend
With .Font
.Name = "Arial Narrow" 'yazı tipi
.Size = 11 'yazı boyutu
.Bold = False 'kalın
.Italic = False 'yatık
.Underline = False 'altçizgi
.Color = False 'yazı rengi
End With
End With
Set sel = Nothing
On Error GoTo 0
End Sub
