Option Compare Database
Option Explicit
Dim lngID As Long
Dim strMailRapport As String
Dim strMailLoc As String
Dim strMailTekst As String
Public Property Get MailRapport() As Variant
On Error GoTo Err_GetMailRapport
MailRapport = strMailRapport
Exit_GetMailRapport:
Exit Property
Err_GetMailRapport:
MailRapport = ""
Resume Exit_GetMailRapport
End Property
Public Property Let MailRapport(ByVal vNewValue As Variant)
On Error GoTo Err_LetMailRapport
strMailRapport = Nz(vNewValue, "")
Exit_LetMailRapport:
Exit Property
Err_LetMailRapport:
MailRapport = ""
Resume Exit_LetMailRapport
End Property
Public Property Let MailLoc(ByVal vNewValue As Variant)
On Error GoTo Err_LetMailLoc
strMailLoc = Nz(vNewValue, "")
Exit_LetMailLoc:
Exit Property
Err_LetMailLoc:
MailLoc = ""
Resume Exit_LetMailLoc
End Property
Public Property Get MailLoc() As Variant
On Error GoTo Err_GetMailLoc
MailLoc = strMailLoc
Exit_GetMailLoc:
Exit Property
Err_GetMailLoc:
MailLoc = ""
Resume Exit_GetMailLoc
End Property
Public Property Let MailTekst(ByVal vNewValue As Variant)
On Error GoTo Err_LetMailTekst
strMailTekst = Nz(vNewValue, "")
Exit_LetMailTekst:
Exit Property
Err_LetMailTekst:
MailTekst = ""
Resume Exit_LetMailTekst
End Property
Public Property Get MailTekst() As Variant
On Error GoTo Err_GetMailTekst
MailTekst = strMailTekst
Exit_GetMailTekst:
Exit Property
Err_GetMailTekst:
MailTekst = ""
Resume Exit_GetMailTekst
End Property
Public Property Get ID() As Variant
On Error GoTo Err_GetID
ID = lngID
Exit_GetID:
Exit Property
Err_GetID:
ID = 0
End Property
Public Property Let ID(ByVal vNewValue As Variant)
On Error GoTo Err_LetID
lngID = Nz(vNewValue, 0)
Exit_LetID:
Exit Property
Err_LetID:
lngID = 0
End Property
Public Sub LoadMailing(lngID As Long)
On Error GoTo Err_LoadMailing
Dim rst As New ADODB.Recordset
Dim cnn As New ADODB.Connection
Set cnn = CurrentProject.Connection
rst.Open "select * from tblMailings where mailID = " & lngID, cnn, adOpenKeyset, adLockReadOnly
With rst
If .BOF And .EOF Then
Me.ID = 0
Else
Me.ID = lngID
End If
.Close
End With
Exit_LoadMailing:
Set cnn = Nothing
Set rst = Nothing
Exit Sub
Err_LoadMailing:
Call gsgErrorHandling
Resume Exit_LoadMailing
End Sub
Public Sub LoadMailingPars(strRapport As String)
On Error GoTo Err_LoadMailingPars
Dim cnn As New ADODB.Connection
Dim rst As New ADODB.Recordset
Set cnn = CurrentProject.Connection
rst.Open "select * from tsysParameters where parType = 'Mailing' and parRapport = """ & strRapport & """", cnn, adOpenKeyset, adLockReadOnly
With rst
If Not (.BOF And .EOF) Then
.MoveFirst
Me.MailRapport = strRapport
Me.MailLoc = !parArgument
Me.MailTekst = !parOmschrijving
.Close
End If
End With
Exit_LoadMailingPars:
Set cnn = Nothing
Set rst = Nothing
Exit Sub
Err_LoadMailingPars:
Call gsgErrorHandling
Resume Exit_LoadMailingPars
End Sub
Public Function CreateMailMessage(strTo As String, strSubject As String, strBody As String, strFile As String) As Boolean
On Error GoTo Err_CreateMailMessage
Dim appOutlook As New Outlook.Application
Dim msg As Outlook.MailItem
Dim intpos As Integer
Set msg = appOutlook.CreateItem(olMailItem)
intpos = InStr(1, strTo, "#")
If intpos > 1 Then strTo = Left(strTo, intpos - 1)
msg.To = strTo
msg.Subject = strSubject
msg.Body = strBody
msg.Attachments.Add (strFile)
msg.Display
CreateMailMessage = True
Exit_CreateMailMessage:
Exit Function
Err_CreateMailMessage:
'MsgBox Err.Number & ": " & Err.Description
CreateMailMessage = False
Resume Exit_CreateMailMessage
End Function
Public Function CreateMailRecord(strMailType As String, lngNaar As Long, strTo As String, fSend As Boolean, strReport As String) As Long
On Error GoTo Err_CreateMailRecord
Dim rst As New ADODB.Recordset
Dim cnn As New ADODB.Connection
Set cnn = CurrentProject.Connection
rst.Open "tblMailings", cnn, adOpenKeyset, adLockPessimistic
With rst
.AddNew
!mailType = strMailType
!mailNaar = lngNaar
!mailAdres = strTo
!mailWanneer = Now
!mailVerstuurd = fSend
!MailRapport = strReport
.Update
lngID = !mailID
End With
CreateMailRecord = lngID
Exit_CreateMailRecord:
Exit Function
Err_CreateMailRecord:
CreateMailRecord = False
Resume Exit_CreateMailRecord
End Function
Public Function SendMailMessage(strTo As String, strSubject As String, strBody As String, strFile As String) As Boolean
On Error GoTo Err_SendMailMessage
Dim appOutlook As New Outlook.Application
Dim msg As Outlook.MailItem
Dim intpos As Integer
Set msg = appOutlook.CreateItem(olMailItem)
'strTo = "noella.gabriel@telenet.be"
msg.To = strTo
msg.Subject = strSubject
msg.Body = strBody
msg.Attachments.Add (strFile)
SendMessageNow:
msg.Send
SendMailMessage = True
Exit_SendMailMessage:
Exit Function
Err_SendMailMessage:
'MsgBox Err.Number & ": " & Err.Description
If Err.Number = -2147467259 Then 'Outlook doesn't recognize the adress
intpos = InStr(1, strTo, "#")
If intpos > 1 Then
strTo = Left(strTo, intpos - 1)
msg.To = strTo
Resume SendMessageNow
End If
End If
SendMailMessage = False
Resume Exit_SendMailMessage
End Function
Public Function DeleteStoredFile(strFilename) As Boolean
On Error GoTo Err_DeleteStoredFile
Dim fso As Scripting.FileSystemObject
Dim fsoFile As Scripting.File
Set fso = CreateObject("Scripting.FilesystemObject")
If fso.FileExists(strFilename) Then fso.DeleteFile strFilename
Exit_DeleteStoredFile:
Exit Function
Err_DeleteStoredFile:
DeleteStoredFile = False
MsgBox Err.Number & ": " & Err.Description
Resume Exit_DeleteStoredFile
End Function
. (Kun je overigens stoppen met het gebruik van de QUOTE knop? nergens voor nodig, in dit geval). Wat voor ons belangrijk is om te weten: is het een individueel rapport, of een algemeen rapport?
