Form MLM.Frm :
Option Explicit
Dim cMLMFile As String
Dim cMLMPath As String
Dim cCtlName() As String
Dim cCtlValue() As String
Dim MinutesToWakeUp As Integer
Dim MinutesCount As Integer
Dim bErr As Boolean
Dim sgUserAddrLine As String
Dim objMAPISession As Object
Dim objSessionInbox As Object
Dim objSessionOutBox As Object
Dim objFolderKhoThongDiep As Object
Dim sMLLFolderID As String
Private Sub Command1_Click(Index As Integer)
Select Case Index
Case 0
ControlsEdit
Case 1
SubEdit
Case 2
SkedEdit
Case 3
ArchEdit
Case 4
ReadInbox
Case 5
SendMail
Case 6
ReadInbox
SendMail
Case 7
MLMEnd
End Select
End Sub
Private Sub MLMEnd()
If Not (objMAPISession Is Nothing) Then
MAPIEnd
End If
Unload Me
End Sub
Public Sub ControlsEdit()
Dim rtn As Long
Dim cEditor
ControlsLoad
If bErr <> True Then
cEditor = ControlSetting("Editor")
Status ""
Status "Opening Control File [" _
& cMLMFile & "]..."
Status "cEditor : " & cEditor
rtn = Shell(cEditor & " " & cMLMFile, 1)
Status "Closing Control File..."
End If
End Sub
Public Sub ReadInbox()
Status ""
ControlsLoad
MAPIStart
ProcessInbox
Status "Inbox processing complete."
End Sub
Public Sub MAPIStart()
On Error GoTo MAPIStartErr
Dim cProfile As String
Dim cPassword As String
If MapiSess.SessionID = 0 Then
Status "Starting MAPI Session..."
cProfile = ControlSetting("MAPIUserName")
cPassword = ControlSetting("MAPIPassword")
MapiSess.Password = cPassword
MapiSess.UserName = cProfile
MapiSess.SignOn
Set objMAPISession = CreateObject("MAPI.Session")
objMAPISession.Logon profilename:=cProfile, _
profilePassword:=cPassword, _
NewSession:=False
If StrComp(ControlSetting( _
"MailingListFolderName"), "") = 0 Then
sMLLFolderID = FolderByNameToID( _
ControlSetting("SearchKey"))
Else
sMLLFolderID = FolderByNameToID( _
ControlSetting("MailingListFolderName"))
End If
If StrComp(sMLLFolderID, "") = 0 Then
sMLLFolderID = FolderByNameToID( _
ControlSetting("Searchkey"))
End If
If StrComp(sMLLFolderID, "") = 0 Then
Status "List Server program get Fatal Error !!!"
Status "You must create and configure " & _
"a Mailing List Folder store in Inbox"
MAPIEnd
MLMEnd
End If
If GetControlSet(ControlSetting("AbleToSleep")) Then
Status "Wait a minute for reading messages..."
Sleep (Val(ControlSetting("MilliSecondsToSleep")))
End If
End If
Exit Sub
MAPIStartErr:
Status "Unable to Start a MAPI Session"
bErr = True
End Sub
Public Sub MAPIStartEnd()
Dim cProfile As String
Dim cPassword As String
Set objMAPISession = CreateObject("MAPI.Session")
cProfile = ControlSetting("MAPIUserName")
cPassword = ControlSetting("MAPIPassword")
MapiSess.Password = cPassword
MapiSess.UserName = cProfile
MapiSess.SignOn
Set objMAPISession = CreateObject("MAPI.Session")
objMAPISession.Logon profilename:=cProfile, _
profilePassword:=cPassword, _
NewSession:=False
objMAPISession.Logoff
MapiSess.SignOff
End Sub
Public Sub MAPIEnd()
On Error Resume Next
If Not objMAPISession Is Nothing Then
Status "Closing MAPI Session..."
objMAPISession.Logoff
MapiSess.SignOff
If GetControlSet(ControlSetting("AbleToSleep")) Then
Status "Wait a minute for sending message..."
Sleep (Val(ControlSetting("MilliSecondsToSleep")))
End If
End If
End Sub
Public Function KhoThongDiep_Find() As Object
Dim objInfoStoresColl As Object
Dim objInfoStore As Object
Dim objFoldersColl As Object
Dim objParentFolder As Object
Dim objFolder As Object
Dim objFolderRtn As Object
Dim cInfoStoreName As String
Dim nCount As Integer
Set objInfoStoresColl = objMAPISession.InfoStores
nCount = objInfoStoresColl.Count
Do While (nCount > 0)
Set objInfoStore = objInfoStoresColl.Item(nCount)
cInfoStoreName = UCase(objInfoStore.Name)
If (cInfoStoreName = _
UCase(ControlSetting("ListServerStoreName"))) Then
Set objParentFolder = objInfoStore.RootFolder
Set objFoldersColl = objParentFolder.Folders
If Not objFoldersColl Is Nothing Then
Set objFolder = objFoldersColl.GetFirst
Do While (Not objFolder Is Nothing)
If (UCase(objFolder.Name) = _
UCase(ControlSetting( _
"ListServerFolderName"))) Then
Set objFolderRtn = objFolder
Exit Do
End If
Set objFolder = objFoldersColl.GetNext
Loop
End If
Exit Do
End If
nCount = nCount - 1
Loop
Set KhoThongDiep_Find = objFolderRtn
End Function
Public Sub ProcessInbox()
Dim cErr As String
If bErr <> 0 Then
Exit Sub
Else
bErr = False
End If
Dim objFolder As Object
Dim objOutboxFolder As Object
Dim objMsgColl As Object
Dim objMessage As Object
Dim cSubject As String
Dim cSearchKeyValue As String
Status "Opening Inbox..."
Set objFolder = objMAPISession.Inbox
If objFolder Is Nothing Then
Status ""
Status "Unable to Open Inbox"
bErr = True
Exit Sub
End If
Status "Collecting Messages..."
Set objMsgColl = objFolder.Messages
If objMsgColl Is Nothing Then
Status "Unable to access Folder's Messages"
Status "ProcessInbox Error"
bErr = True
Exit Sub
End If
cSearchKeyValue = UCase(ControlSetting("SearchKey"))
Status "Scanning Messages for [" _
& cSearchKeyValue & "]..."
Set objMessage = objMsgColl.GetFirst
Do Until objMessage Is Nothing
cSubject = UCase(objMessage.subject)
If TokenInString(cSubject, _
cSearchKeyValue, sSpace) Then
ProcessInboxMsg objMessage
End If
Set objMessage = objMsgColl.GetNext
Loop
Set objOutboxFolder = objMAPISession.Outbox
objOutboxFolder.Update
End Sub
Public Sub ControlsLoad()
On Error GoTo ControlsLoadErr
Status ""
Status "Loading Control Values..."
Dim nFile As Integer
Dim nCount As Integer
Dim cLine As String
Dim nPos As Integer
bErr = False
nCount = 0
nFile = FreeFile
Open cMLMFile For Input As nFile
While Not EOF(nFile)
Line Input #nFile, cLine
If Not laDongGhichu(cLine) Then
nPos = InStr(cLine, DauBang)
If nPos <> 0 Then
nCount = nCount + 1
ReDim Preserve cCtlName(nCount)
ReDim Preserve cCtlValue(nCount)
cCtlName(nCount) = UCase(Left(cLine, nPos - 1))
cCtlValue(nCount) = UCase(Mid(cLine, nPos + 1, 255))
cCtlName(nCount) = LTrimBlankTab( _
cCtlName(nCount))
cCtlValue(nCount) = LTrimBlankTab( _
cCtlValue(nCount))
Else
End If
End If
Wend
Close #nFile
Exit Sub
ControlsLoadErr:
Status "ControlsLoad Error [" & CStr(Err) & "]"
bErr = True
End Sub
Private Sub Form_Load()
EOL = (Chr$(13) & Chr$(10))
cSpace = Chr$(32)
cTAB = Chr$(9)
sSpace = cSpace & cTAB
Text1 = ""
If StrComp(sArgMLLPathForm, "none") = 0 _
Or StrComp(sArgMLLPathForm, "") = 0 Then
cMLMPath = ""
cMLMFile = sArgMLLNameForm
Else
cMLMPath = sArgMLLPathForm & "\"
cMLMFile = cMLMPath & sArgMLLNameForm
End If
Me.Caption = "Mailing List Manager [" & cMLMFile & "]"
Status ""
ControlsLoad
MinutesToWakeUp = Val(ControlSetting("MinutesToWakeUp"))
Status "MinutesToWakeUp = " & Str(MinutesToWakeUp)
MinutesCount = 0
End Sub
Public Sub Status(cInfo As String)
If cInfo = "" Then
Text1 = ""
Else
Text1 = Text1 & cInfo & Chr(13) & Chr(10)
End If
End Sub
Private Sub Form_Resize()
End Sub
Private Sub mnuCascade_Click()
MDIFormMLMs.Arrange vbCascade
End Sub
Private Sub mnuEditArchive_Click()
ArchEdit
End Sub
Private Sub mnuEditControls_Click()
ControlsEdit
End Sub
Private Sub mnuEditSked_Click()
SkedEdit
End Sub
Private Sub mnuEditSubs_Click()
SubEdit
End Sub
Private Sub mnuFileClose_Click()
MLMEnd
End Sub
Private Sub mnuTestFind_Click()
End Sub
Private Sub mnuIniLoad_Click()
End Sub
Private Sub mnuSessionLogOff_Click()
MAPIEnd
End Sub
Private Sub mnuSessionLogOn_Click()
MAPIStart
End Sub
Private Sub mnuTestFindKhoThongDiep_Click()
Dim fFound As Boolean
Dim sKey As String
ControlsLoad
sKey = ControlSetting("MailingListFolderName")
If StrComp(sKey, "") = 0 Then
sKey = ControlSetting("SearchKey")
End If
Status ""
Status "Test Get Folder by Name ..."
fFound = GetFolderByName(sKey)
If fFound Then
Status "Folder " & sKey & " found"
Else
Status "Folder " & sKey & " not found"
End If
End Sub
Private Function FolderByNameToID( _
strFolderSearchName As String) As String
Dim objOneFolder As Object
Dim objFolder As Object
Dim objFoldersColl As Object
Dim sobjFolderName As String
On Error GoTo error_olemsg
FolderByNameToID = ""
If objMAPISession Is Nothing Then
Status ""
ControlsLoad
MAPIStart
End If
Set objFolder = objMAPISession.Inbox
Set objFoldersColl = objFolder.Folders
If objFoldersColl Is Nothing Then
Status "Inbox has none subfolders !"
End If
Set objOneFolder = objFoldersColl.GetFirst
Do While Not objOneFolder Is Nothing
sobjFolderName = UCase(objOneFolder.Name)
strFolderSearchName = UCase(strFolderSearchName)
If StrComp(sobjFolderName, _
strFolderSearchName, 1) = 0 Then
Exit Do
Else
Set objOneFolder = objFoldersColl.GetNext
End If
Loop
If Not objOneFolder Is Nothing Then
FolderByNameToID = objOneFolder.ID
End If
Exit Function
error_olemsg:
Status "Error " & Str(Err) & ": " & Error$(Err)
Resume Next
End Function
Private Function GetFolderByName( _
strFolderSearchName As String) As Boolean
Dim objOneFolder As Object
Dim objFolder As Object
Dim objFoldersColl As Object
Dim sobjFolderName As String
On Error GoTo error_olemsg
GetFolderByName = False
If objMAPISession Is Nothing Then
Status ""
ControlsLoad
MAPIStart
End If
Set objFolder = objMAPISession.Inbox
Set objFoldersColl = objFolder.Folders
If objFoldersColl Is Nothing Then
Status "Inbox has none subfolders !"
End If
Set objOneFolder = objFoldersColl.GetFirst
Do While Not objOneFolder Is Nothing
sobjFolderName = UCase(objOneFolder.Name)
strFolderSearchName = UCase(strFolderSearchName)
If StrComp(sobjFolderName, _
strFolderSearchName, 1) = 0 Then
Exit Do
Else
Set objOneFolder = objFoldersColl.GetNext
End If
Loop
If Not objOneFolder Is Nothing Then
GetFolderByName = True
End If
Exit Function
error_olemsg:
Status "Error " & Str(Err) & ": " & Error$(Err)
Resume Next
End Function
Private Sub mnuTestIniLoad_Click()
Dim MyIniFile As String
Dim sAppName As String
Dim sKeyWord As String
Dim sDefault As String
Dim sBuf As String
Dim l As Integer
Dim sKetqua As String
MyIniFile = App.Path & "\MLM.ini"
sAppName = "LogOnOff"
sKeyWord = "MAPIUserName"
sDefault = "None"
sBuf = String$(255, 0)
l = GetPrivateProfileString(sAppName, sKeyWord, sDefault, _
sBuf, Len(sBuf), MyIniFile)
sKetqua = Left$(sBuf, l)
Status ""
Status "[LogOnOff].MAPIUserName = " & sKetqua
sAppName = ""
sKeyWord = "SearchKey"
sDefault = "None"
sBuf = String$(255, 0)
l = GetPrivateProfileString(sAppName, sKeyWord, sDefault, _
sBuf, Len(sBuf), MyIniFile)
sKetqua = Left$(sBuf, l)
Status "SearchKey = " & sKetqua
End Sub
Private Sub mnuTestTokenInString_Click()
Dim srcString As String
Dim tokenString As String
Dim nkq As Integer
srcString = " unsub mll"
tokenString = "sub"
nkq = TokenInString(srcString, tokenString, sSpace)
Status ""
Status "test Token in String ..."
Status Str(nkq)
Status "Ket qua dung la : 0"
srcString = " sub mll"
tokenString = "sub"
nkq = TokenInString(srcString, tokenString, sSpace)
Status "test Token in String ..."
Status Str(nkq)
Status "Ket qua dung la : 2"
srcString = " sub mll unsub"
tokenString = "unsub"
nkq = TokenInString(srcString, tokenString, sSpace)
Status "test Token in String ..."
Status Str(nkq)
Status "Ket qua dung la : 10"
End Sub
Private Sub mnuTile_Click()
MDIFormMLMs.Arrange vbTileVertical
End Sub
Private Sub Text1_KeyPress(KeyAscii As Integer)
KeyAscii = 0
End Sub
Public Function ControlSetting(cName As String) As String
Dim cReturn As String
Dim nCount As Integer
Dim x As Integer
nCount = UBound(cCtlName)
cName = UCase(cName)
For x = 1 To nCount
If cName = UCase(cCtlName(x)) Then
cReturn = cCtlValue(x)
Exit For
End If
Next x
ControlSetting = cReturn
End Function
Public Sub ProcessInboxMsgHelp(objMsg As Object)
End Sub
Public Sub ProcessInboxMsg(objMsg As Object)
Dim objAddrEntry As Object
Dim bSetCmd As Boolean
Dim bSetAckCmd As Boolean
Dim bSetNoAckCmd As Boolean
Dim bSetMailCmd As Boolean
Dim bSetNoMailCmd As Boolean
Dim bSetReproCmd As Boolean
Dim bSetNoReproCmd As Boolean
Dim bDeleteMsg
Dim cSubject As String
bDeleteMsg = True
cSubject = UCase(objMsg.subject)
Set objAddrEntry = objMsg.Sender
If TokenInString(cSubject, _
UCase(ControlSetting("NewSub")), sSpace) Then
ProcessInboxMsgNewSub objMsg
End If
If TokenInString(cSubject, "HELP", sSpace) Then
ProcessInboxMsgHelp objMsg
End If
If SubFind(objAddrEntry) = True Then
If TokenInString(cSubject, _
UCase(ControlSetting("UnSub")), sSpace) Then
ProcessInboxMsgUnSub objMsg
End If
bSetCmd = (TokenInString(cSubject, _
UCase(ControlSetting("ListSet")), sSpace))
bSetAckCmd = (TokenInString(cSubject, _
UCase(ControlSetting("ACK")), sSpace))
If bSetAckCmd Then
ProcessInboxMsgSetNoACK objMsg, "1"
End If
bSetNoAckCmd = (TokenInString(cSubject, _
UCase(ControlSetting("NoACK")), sSpace))
If bSetNoAckCmd Then
ProcessInboxMsgSetNoACK objMsg, "0"
End If
bSetMailCmd = (TokenInString(cSubject, _
UCase(ControlSetting("Mail")), sSpace))
If bSetMailCmd Then
ProcessInboxMsgSetMail objMsg, "1"
End If
bSetNoMailCmd = (TokenInString(cSubject, _
UCase(ControlSetting("NoMail")), sSpace))
If bSetNoMailCmd Then
ProcessInboxMsgSetMail objMsg, "0"
End If
bSetReproCmd = (TokenInString(cSubject, _
UCase(ControlSetting("Repro")), sSpace))
If bSetReproCmd Then
ProcessInboxMsgSetRepro objMsg, "1"
End If
bSetNoReproCmd = (TokenInString(cSubject, _
UCase(ControlSetting("NoRepro")), sSpace))
If bSetNoReproCmd Then
ProcessInboxMsgSetRepro objMsg, "0"
End If
If bSetCmd Or bSetNoAckCmd Or bSetAckCmd _
Or bSetMailCmd Or bSetNoMailCmd Or _
bSetReproCmd Or bSetNoReproCmd Then
SubReplyUserSET objAddrEntry
End If
If (TokenInString(cSubject, _
UCase(ControlSetting("ListSend")), _
sSpace)) Then
ProcessInboxMsgSend objMsg
End If
If TokenInString(cSubject, _
UCase(ControlSetting("GetArchive")), sSpace) Then
ProcessInboxMsgArcGet objMsg
End If
If TokenInString(cSubject, _
UCase(ControlSetting("ListArchive")), sSpace) Then
ProcessInboxMsgArcList objMsg
End If
If (TokenInString(cSubject, _
UCase(ControlSetting("ListSend")), sSpace)) _
And (GetControlSet(ControlSetting("AbleToSend"))) Then
ProcessInboxMsgSend objMsg
bDeleteMsg = False
End If
End If ' Xu ly cac Subscriber trong MLL
If bDeleteMsg Then
DeleteMsg objMsg
End If
End Sub
Public Sub ProcessInboxMsgNewSub(objMsg As Object)
Dim objAddrEntry As Object
Dim cName As String
Dim cAddress As String
Dim cType As String
On Error Resume Next
Set objAddrEntry = objMsg.Sender
If SubFind(objAddrEntry) = False Then
SubWrite objAddrEntry
SubGreet objAddrEntry
End If
End Sub
Public Sub DeleteMsg(objMsg As Object)
objMsg.Delete
End Sub
Public Sub SubWrite(objAddr As Object)
Dim cSublist As String
Dim nFile As Integer
Dim sPrint As String
cSublist = cMLMPath & ControlSetting("ListSubs")
Status "Adding New Sub..." & objAddr.Name
sPrint = objAddr.Name & DauCachDongDiachi & _
objAddr.address & DauCachDongDiachi & _
objAddr.Type & DauCachDongDiachi & _
ControlSetting("UserSetDefault")
nFile = FreeFile
Open cSublist For Append As nFile
Print #nFile, UCase(sPrint)
Close nFile
End Sub
Public Function SubFind(objAddr As Object) As Boolean
Dim cSublist As String
Dim bReturn As Boolean
Dim nFile As Integer
Dim cRdLine As String
Dim cSrchLine As String
cSublist = ControlSetting("ListSubs")
cSublist = cMLMPath & cSublist _
& DauCachDongDiachi & objAddr.Type
cSrchLine = UCase(objAddr.Name & DauCachDongDiachi & _
objAddr.address & DauCachDongDiachi & _
objAddr.Type)
nFile = FreeFile
bReturn = False
Open cSublist For Input As nFile
Do While (Not EOF(nFile))
Line Input #nFile, cRdLine
If Not laDongGhichu(cRdLine) Then
If (InStr(UCase(cRdLine), cSrchLine)) Then
sgUserAddrLine = UCase(cRdLine)
bReturn = True
Exit Do
End If
End If
Loop
Close #nFile
SubFind = bReturn
End Function
Public Sub SubEdit()
Dim lReturn As Long
Dim cEditor As String
Dim cFile As String
ControlsLoad
If bErr <> True Then
cFile = ControlSetting("ListSubs")
cFile = cMLMPath & cFile
cEditor = ControlSetting("Editor")
Status ""
Status "Loading Subscriber List [" & cFile & "]..."
lReturn = Shell(cEditor & " " & cFile, 1)
Status "Closing Subscriber List..."
End If
End Sub
Public Sub SubGreet(objAddr As Object)
Dim cSubGreet As String
Dim nFile As Integer
Dim cLine As String
Dim cMsgBody As String
Dim objMsg As Object
Dim objRecip As Object
Status "Sending Greet Msg to " & objAddr.Name & "..."
cSubGreet = ControlSetting("NewSubMsg")
nFile = FreeFile
Open cSubGreet For Input As nFile
While Not EOF(nFile)
Line Input #nFile, cLine
cMsgBody = cMsgBody & EOL & cLine
Wend
Close #nFile
Set objMsg = objMAPISession.Outbox.Messages.Add
objMsg.subject = ControlSetting("ListName") & " " _
& ControlSetting("NewSubMsgSubj")
objMsg.Text = cMsgBody
Set objRecip = objMsg.Recipients.Add
If objAddr.Type = "MS" Then
objRecip.Name = objAddr.Name
objRecip.Type = mapiTo
objRecip.Resolve
Else
objRecip.Name = objAddr.Type & ":" _
& objAddr.address
objRecip.address = objAddr.Type & ":" _
& objAddr.address
objRecip.Type = mapiTo
End If
objMsg.Update
objMsg.Send showDialog:=False
End Sub
Public Sub ProcessInboxMsgUnSub(objMsg As Object)
Dim objAddrEntry As Object
On Error Resume Next
Set objAddrEntry = objMsg.Sender
If SubFind(objAddrEntry) = True Then
SubDelete objAddrEntry
SubBye objAddrEntry
End If
End Sub
Public Sub SubDelete(objAddr As Object)
Dim cSublist As String
Dim cSubTemp As String
Dim nList As Integer
Dim nTemp As Integer
Dim cRdLine As String
Dim cSrchLine As String
Status "Dropping a Sub..." & objAddr.Name
cSrchLine = UCase(objAddr.Name & DauCachDongDiachi & _
objAddr.address & DauCachDongDiachi & _
objAddr.Type)
cSublist = cMLMPath & ControlSetting("ListSubs")
cSubTemp = cMLMPath & "tmp001.txt"
nList = FreeFile
Open cSublist For Input As nList
nTemp = FreeFile
Open cSubTemp For Output As nTemp
While Not EOF(nList)
Line Input #nList, cRdLine
cRdLine = UCase(cRdLine)
If (laDongGhichu(cRdLine)) _
Or _
(InStr(cRdLine, cSrchLine) = 0) Then
"SR: " & cSrchLine
If (Trim(cRdLine) <> "") Then
Print #nTemp, cRdLine
End If
End If
Wend
Close #nList
Close #nTemp
Kill cSublist
Name cSubTemp As cSublist
End Sub
Public Sub SubReplyUserSET(objAddr As Object)
Dim cSubjUserSET As String
Dim nFile As Integer
Dim cLine As String
Dim cMsgBody As String
Dim objMsg As Object
Dim objRecip As Object
Status "Reply UserSET flags to " & objAddr.Name & "..."
cSubjUserSET = ControlSetting("UserSETSubjMsg")
cMsgBody = ControlSetting("FirstLineUserSET") _
& EOL
If isACK(UserSET(sgUserAddrLine)) Then
cMsgBody = cMsgBody & " ACK = 1" & EOL
Else
cMsgBody = cMsgBody & " ACK = 0" & EOL
End If
If isMail(UserSET(sgUserAddrLine)) Then
cMsgBody = cMsgBody & " Mail = 1" & EOL
Else
cMsgBody = cMsgBody & " Mail = 0" & EOL
End If
If isRepro(UserSET(sgUserAddrLine)) Then
cMsgBody = cMsgBody & " Repro = 1" & EOL
Else
cMsgBody = cMsgBody & " Repro = 0" & EOL
End If
cMsgBody = cMsgBody & ControlSetting("LastLineUserSET")
Set objMsg = objMAPISession.Outbox.Messages.Add
objMsg.subject = ControlSetting("ListName") & " " _
& cSubjUserSET
objMsg.Text = cMsgBody
Set objRecip = objMsg.Recipients.Add
If objAddr.Type = "MS" Then
objRecip.Name = objAddr.Name
objRecip.Type = mapiTo
objRecip.Resolve
Else
objRecip.Name = objAddr.Type & ":" _
& objAddr.address
objRecip.address = objAddr.Type & ":" _
& objAddr.address
objRecip.Type = mapiTo
End If
objMsg.Update
objMsg.Send showDialog:=False
End Sub
Public Sub SubBye(objAddr As Object)
Dim cSubBye As String
Dim nFile As Integer
Dim cLine As String
Dim cMsgBody As String
Dim objMsg As Object
Dim objRecip As Object
Status "Sending Bye Msg to " & objAddr.Name & "..."
cSubBye = ControlSetting("UnSubMsg")
nFile = FreeFile
Open cSubBye For Input As nFile
While Not EOF(nFile)
Line Input #nFile, cLine
cMsgBody = cMsgBody & EOL & cLine
Wend
Close #nFile
Set objMsg = objMAPISession.Outbox.Messages.Add
objMsg.subject = ControlSetting("ListName") & " " _
& ControlSetting("UnSubMsgSubj")
objMsg.Text = cMsgBody
Set objRecip = objMsg.Recipients.Add
If objAddr.Type = "MS" Then
objRecip.Name = objAddr.Name
objRecip.Type = mapiTo
objRecip.Resolve
Else
objRecip.Name = objAddr.Type & ":" & _
objAddr.address
objRecip.address = objAddr.Type & ":" & _
objAddr.address
objRecip.Type = mapiTo
End If
objMsg.Update
objMsg.Send showDialog:=False
End Sub
Public Sub SendMail()
Status ""
ControlsLoad
MAPIStart
ProcessSubList
Status "Outbound processing complete."
vbInformation , "SendMail"
End Sub
Public Sub ProcessSubList()
Dim cErr As String
If bErr <> 0 Then
Exit Sub
Else
bErr = False
End If
Dim cSublist As String
Dim nSubList As Integer
Dim cListSked As String
Dim nListSked As Integer
Dim cSkedFile As String
Dim cFileDate As String
Dim cFileName As String
Dim cFileTitle As String
Dim cLine As String
Dim nPos1 As Integer
Dim nPos2 As Integer
cSublist = ControlSetting("ListSubs")
cListSked = ControlSetting("ListSchedule")
cSkedFile = Format(Now, "YYMMDD")
Status "Opening Schedule File [" & cListSked & "]..."
nListSked = FreeFile
Open cListSked For Input As nListSked
On Error Resume Next
Do While Not EOF(nListSked)
Line Input #nListSked, cLine
If Not laDongGhichu(cLine) Then
nPos1 = InStr(cLine, ",")
If nPos1 <> 0 Then
cFileDate = Left(cLine, nPos1 - 1)
End If
nPos2 = InStr(nPos1 + 1, cLine, ",")
If nPos2 <> 0 Then
cFileName = Mid(cLine, nPos1 + 1, nPos2 - (nPos1 + 1))
End If
If nPos2 + 1 < Len(cLine) Then
cFileTitle = Mid(cLine, nPos2 + 1, 255)
Else
cFileTitle = cFileName
End If
If cFileDate = cSkedFile Then
Exit Do
End If
End If
Loop
Close nListSked
Status "Opening Subscriber List [" & cSublist & "]..."
nSubList = FreeFile
Open cSublist For Input As nSubList
Do While Not EOF(nSubList)
Line Input #nSubList, cLine
If Not laDongGhichu(cLine) Then
ProcessSubListMsg cLine, cFileName, cFileTitle
End If
Loop
End Sub
Public Sub ProcessInboxMsgSetRepro(objMsg As Object, _
bitRepro As String)
Dim objAddr As Object
Dim cSublist As String
Dim cSubTemp As String
Dim nList As Integer
Dim nTemp As Integer
Dim cRdLine As String
Dim cSrchLine As String
On Error Resume Next
Set objAddr = objMsg.Sender
If bitRepro = "1" Then
Status "Subscriber set RePro ..." & _
objAddr.Name
Else
Status "Subscriber set NoRepro ..." & _
objAddr.Name
End If
cSublist = cMLMPath & ControlSetting("ListSubs")
nList = FreeFile
Open cSublist For Input As nList
nTemp = FreeFile
cSubTemp = cMLMPath & _
"tmp" & Trim(Str(nTemp)) & ".txt"
Open cSubTemp For Output As nTemp
cSrchLine = UCase(objAddr.Name & DauCachDongDiachi & _
objAddr.address & DauCachDongDiachi & _
objAddr.Type)
While Not EOF(nList)
Line Input #nList, cRdLine
cRdLine = UCase(Trim(cRdLine))
If (laDongGhichu(cRdLine)) _
Or _
(InStr(cRdLine, cSrchLine) = 0) Then
"SR: " & cSrchLine
If (cRdLine <> "") Then
Print #nTemp, cRdLine
End If
Else
If (cRdLine <> "") Then
cRdLine = AddrSetRepro(cRdLine, _
bitRepro)
Print #nTemp, cRdLine
End If
End If
Wend
Close #nList
Close #nTemp
Kill cSublist
Name cSubTemp As cSublist
End Sub
Public Sub ProcessInboxMsgSetMail(objMsg As Object, _
bitMail As String)
Dim objAddr As Object
Dim cSublist As String
Dim cSubTemp As String
Dim nList As Integer
Dim nTemp As Integer
Dim cRdLine As String
Dim cSrchLine As String
On Error Resume Next
Set objAddr = objMsg.Sender
If bitMail = "1" Then
Status "Subscriber set Mail ..." & _
objAddr.Name
Else
Status "Subscriber set NoMail ..." & _
objAddr.Name
End If
cSublist = cMLMPath & ControlSetting("ListSubs")
nList = FreeFile
Open cSublist For Input As nList
nTemp = FreeFile
cSubTemp = cMLMPath & _
"tmp" & Trim(Str(nTemp)) & ".txt"
Open cSubTemp For Output As nTemp
cSrchLine = UCase(objAddr.Name & DauCachDongDiachi & _
objAddr.address & DauCachDongDiachi & _
objAddr.Type)
While Not EOF(nList)
Line Input #nList, cRdLine
cRdLine = UCase(Trim(cRdLine))
If (laDongGhichu(cRdLine)) _
Or _
(InStr(cRdLine, cSrchLine) = 0) Then
"SR: " & cSrchLine
If (cRdLine <> "") Then
Print #nTemp, cRdLine
End If
Else
If (cRdLine <> "") Then
cRdLine = AddrSetMail(cRdLine, _
bitMail)
Print #nTemp, cRdLine
End If
End If
Wend
Close #nList
Close #nTemp
Kill cSublist
Name cSubTemp As cSublist
End Sub
Public Sub ProcessInboxMsgSetNoACK(objMsg As Object, _
bitNoACK As String)
Dim objAddr As Object
Dim cSublist As String
Dim cSubTemp As String
Dim nList As Integer
Dim nTemp As Integer
Dim cRdLine As String
Dim cSrchLine As String
On Error Resume Next
Set objAddr = objMsg.Sender
If bitNoACK = "0" Then
Status "Subscriber set NoACK ..." & _
objAddr.Name
Else
Status "Subscriber set ACK ..." & _
objAddr.Name
End If
cSublist = cMLMPath & ControlSetting("ListSubs")
nList = FreeFile
Open cSublist For Input As nList
nTemp = FreeFile
cSubTemp = cMLMPath & _
"tmp" & Trim(Str(nTemp)) & ".txt"
Open cSubTemp For Output As nTemp
cSrchLine = UCase(objAddr.Name & DauCachDongDiachi & _
objAddr.address & DauCachDongDiachi & _
objAddr.Type)
While Not EOF(nList)
Line Input #nList, cRdLine
cRdLine = UCase(Trim(cRdLine))
If (laDongGhichu(cRdLine)) _
Or _
(InStr(cRdLine, cSrchLine) = 0) Then
"SR: " & cSrchLine
If (cRdLine <> "") Then
Print #nTemp, cRdLine
End If
Else
If (cRdLine <> "") Then
cRdLine = AddrSetNoACK(cRdLine, bitNoACK)
Print #nTemp, cRdLine
End If
End If
Wend
Close #nList
Close #nTemp
Kill cSublist
Name cSubTemp As cSublist
End Sub
Public Function SubjectGetinCmd(sSubject) _
As String
Dim nPos1 As Integer
Dim nPos2 As Integer
nPos1 = InStr(sSubject, DauMoMocVuong)
nPos2 = InStr(sSubject, DauDongMocVuong)
If nPos1 > 0 Then
If nPos2 > nPos1 Then
SubjectGetinCmd = Mid(sSubject, _
nPos1 + 1, nPos2 - nPos1 - 1)
Else
SubjectGetinCmd = Mid(sSubject, nPos1 + 1, 255)
End If
Else
SubjectGetinCmd = "No subject"
End If
End Function
Public Sub ProcessInboxMsgSend(objMsg As Object)
Dim sMsgID As String
Dim sPrint As String
Dim cSublist As String
Dim nFile As Integer
Dim sSrchLine As String
Dim sRdLine As String
Dim bAppendToList As Boolean
Dim sSubject As String
Dim objMsgSend As Object
Dim objRecipList As Object
Dim nRecipListCount As Long
Dim I As Long
Dim objOneRecip As Object
Dim sOneRecipName As String
Dim sOneRecipType As String
Dim sOneRecipAddr As String
Dim sUserSET As String
Dim nPos1 As Integer
Dim nPos2 As Integer
Dim nPos3 As Integer
Dim bAddNewRecip As Boolean
Dim objOneRecipAddr As Object
Dim objSenderAddr As Object
On Error Resume Next
Set objSenderAddr = objMsg.Sender
sSrchLine = objSenderAddr.Name & DauCachDongDiachi _
& objSenderAddr.address & DauCachDongDiachi _
& objSenderAddr.Type
sSrchLine = UCase(sSrchLine)
sSubject = objMsg.subject
sSubject = SubjectGetinCmd(sSubject)
(subject:=sSubject, Text:=objMsg.Text, _
Type:=objMsg.Type, _
importance:=objMsg.importance)
Set objMsgSend = objMAPISession.Outbox.Messages.Add
If objMsgSend Is Nothing Then
Status "Unable to create new message in Outbox"
MsgBox "Unable to create new message in Outbox"
Exit Sub
Else
With objMsgSend
.subject = sSubject
.Text = objMsg.Text
.Type = objMsg.Type
.importance = objMsg.importance
End With
End If
Set objRecipList = objMsgSend.Recipients
Status "Sendind out a message of ..." _
& objSenderAddr.Name
cSublist = cMLMPath & ControlSetting("ListSubs")
nFile = FreeFile
Open cSublist For Input As nFile
If GetControlSet(ControlSetting("AbleToSend")) Then
bAddNewRecip = True
Do While (Not EOF(nFile))
bAppendToList = True
Line Input #nFile, sRdLine
sRdLine = UCase(sRdLine)
If (Not laDongGhichu(sRdLine)) Then
If (InStr(sRdLine, sSrchLine)) Then
bAppendToList = False
End If
If bAppendToList Then
If bAddNewRecip Then
Set objOneRecip = _
objMsgSend.Recipients.Add
If objOneRecip Is Nothing Then
Status "Unable to create recipient in SendMsg"
End If
Else
bAddNewRecip = True
End If
nPos1 = InStr(sRdLine, DauCachDongDiachi)
If nPos1 <> 0 Then
sOneRecipName = Left(sRdLine, _
nPos1 - 1)
Else
bAddNewRecip = False
GoTo loopbaddnewrecip
End If
nPos2 = InStr(nPos1 + 1, sRdLine, _
DauCachDongDiachi)
If nPos2 <> 0 Then
sOneRecipAddr = Mid(sRdLine, _
nPos1 + 1, _
nPos2 - (nPos1 + 1))
Else
bAddNewRecip = False
GoTo loopbaddnewrecip
End If
nPos3 = InStr(nPos2 + 1, _
sRdLine, DauCachDongDiachi)
If nPos3 <> 0 Then
sOneRecipType = Mid(sRdLine, _
nPos2 + 1, _
nPos3 - (nPos2 + 1))
Else
bAddNewRecip = False
GoTo loopbaddnewrecip
End If
sUserSET = Mid(sRdLine, nPos3 + 1, 255)
If (Not isMail(sUserSET)) Then
bAddNewRecip = False
GoTo loopbaddnewrecip
Else
Status " Adding " & sOneRecipName & _
" to Recipients collection"
If sOneRecipType = "MS" Then
objOneRecip.Name = sOneRecipName
objOneRecip.address = sOneRecipAddr
objOneRecip.Type = mapiTo
objOneRecip.Resolve
Else
objOneRecip.Name = sOneRecipType & _
":" & sOneRecipAddr
objOneRecip.address = sOneRecipType & _
":" & sOneRecipAddr
objOneRecip.Type = mapiTo
End If ' xu ly Mail khong phai MS
End If
End If
End If
loopbaddnewrecip:
Loop
objMsgSend.Sent = objMsg.Sent
objMsgSend.Text = objMsg.Text
objMsgSend.Unread = objMsg.Unread
objMsgSend.Update
objMsgSend.Send showDialog:=False
Else
End If
Close nFile
End Sub
Public Sub ProcessSubListMsg(cListAddr As String, _
cFile As String, cTitle As String)
Dim nFile As Integer
Dim cLine As String
Dim cMsgBody As String
Dim cType As String
Dim cAddr As String
Dim cName As String
Dim cUserSET As String
Dim objMsg As Object
Dim objRecip As Object
Dim nPos1 As Integer
Dim nPos2 As Integer
Dim nPos3 As Integer
nPos1 = InStr(cListAddr, DauCachDongDiachi)
If nPos1 <> 0 Then
cName = Left(cListAddr, nPos1 - 1)
Else
Exit Sub
End If
nPos2 = InStr(nPos1 + 1, cListAddr, DauCachDongDiachi)
If nPos2 <> 0 Then
cAddr = Mid(cListAddr, nPos1 + 1, nPos2 - (nPos1 + 1))
Else
Exit Sub
End If
nPos3 = InStr(nPos2 + 1, cListAddr, DauCachDongDiachi)
If nPos3 <> 0 Then
cType = Mid(cListAddr, nPos2 + 1, nPos3 - (nPos2 + 1))
Else
Exit Sub
End If
cUserSET = Mid(cListAddr, nPos3 + 1, 255)
Status "Sending Msg to " & cName & "..." & _
" [" & cTitle & "]"
nFile = FreeFile
Open cFile For Input As nFile
While Not EOF(nFile)
Line Input #nFile, cLine
cMsgBody = cMsgBody & EOL & cLine
Wend
Close #nFile
Set objMsg = objMAPISession.Outbox.Messages.Add
objMsg.subject = ControlSetting("ListName") & _
" [" & cTitle & "]"
objMsg.Text = cMsgBody
Set objRecip = objMsg.Recipients.Add
If cType = "MS" Then
objRecip.Name = cName
objRecip.Type = mapiTo
objRecip.Resolve
Else
objRecip.Name = cType & ":" & cAddr
objRecip.address = cType & ":" & cAddr
objRecip.Type = mapiTo
End If
objMsg.Update
objMsg.Send showDialog:=False
End Sub
Public Sub SkedEdit()
Dim rtn As Long
Dim cFile As String
Dim cEditor As String
ControlsLoad
If bErr <> True Then
cFile = ControlSetting("ListSchedule")
cFile = cMLMPath & cFile
cEditor = ControlSetting("Editor")
Status "Opening Schedule [" & cFile & "]..."
rtn = Shell(cEditor & " " & cFile, 1)
Status "Closing Schdule..."
End If
End Sub
Public Sub ProcessInboxMsgArcList(objMsg As Object)
On Error Resume Next
Dim objAddrEntry As Object
Set objAddrEntry = objMsg.Sender
If SubFind(objAddrEntry) = True Then
WriteArcList objAddrEntry
End If
End Sub
Public Sub WriteArcList(objAddr As Object)
Dim objMsg As Object
Dim objRecip As Object
Dim cArcFile As String
Dim nArcFile As Integer
Dim cLine As String
Dim cFileDate As String
Dim cFileName As String
Dim cFileTitle As String
Dim cMsgBody As String
Dim nPos1 As Integer
Dim nPos2 As Integer
Status "Sending Archive List to " & objAddr.Name & "..."
cMsgBody = "Danh sa'ch chu? dde^` cua? " _
& ControlSetting("ListName") & EOL & EOL
cMsgBody = cMsgBody _
& "Ca'c do`ng sau dda^y co' da.ng : " & EOL
cMsgBody = cMsgBody _
& "Nga`y(YYMMDD),Te^nFile,Chu?dde^`" & EOL & EOL
cArcFile = ControlSetting("ArchiveFile")
nArcFile = FreeFile
Open cArcFile For Input As nArcFile
Do While Not EOF(nArcFile)
Line Input #1, cLine
If Not laDongGhichu(cLine) Then
cMsgBody = cMsgBody & cLine & EOL
End If
Loop
Close #nArcFile
Set objMsg = objMAPISession.Outbox.Messages.Add
objMsg.subject = ControlSetting("ListArchiveSubj") _
& " " & ControlSetting("ListName")
objMsg.Text = cMsgBody
Set objRecip = objMsg.Recipients.Add
If objAddr.Type = "MS" Then
objRecip.Name = objAddr.Name
objRecip.Type = mapiTo
objRecip.Resolve
Else
objRecip.Name = objAddr.Type & ":" & _
objAddr.address
objRecip.address = objAddr.Type & ":" & _
objAddr.address
objRecip.Type = mapiTo
End If
objMsg.Update
objMsg.Send showDialog:=False
End Sub
Public Sub ArchEdit()
Dim rtn As Long
Dim cEditor As String
Dim cArchFile As String
ControlsLoad
If bErr <> True Then
cEditor = ControlSetting("Editor")
cArchFile = ControlSetting("ArchiveFile")
cArchFile = cMLMPath & cArchFile
Status "Opening Archive File [" & cArchFile & "]..."
rtn = Shell(cEditor & " " & cArchFile, 1)
Status "Closing Archive File..."
End If
End Sub
Public Sub ProcessInboxMsgArcGet(objMsg As Object)
On Error Resume Next
Dim objAddrEntry As Object
Set objAddrEntry = objMsg.Sender
If SubFind(objAddrEntry) = True Then
WriteArcGet objMsg.subject, objAddrEntry
End If
End Sub
Public Sub WriteArcGet(cSubject As String, objAddr As Object)
Dim objMsg As Object
Dim objRecip As Object
Dim cArcFile As String
Dim nArcFile As Integer
Dim cLine As String
Dim cFileDate As String
Dim cFileName As String
Dim cFileTitle As String
Dim cMsgBody As String
Dim nPos1 As Integer
Dim nPos2 As Integer
Dim cArchive As String
nPos1 = TokenInString(UCase(cSubject), "GET", cSpace)
If nPos1 <> 0 Then
nPos2 = InStr(nPos1 + 1, cSubject, " ")
If nPos2 <> 0 Then
cArchive = Mid(cSubject, nPos2 + 1, 255)
Else
cArchive = ""
End If
End If
cArcFile = FindArc(cArchive)
If Len(cArcFile) <> 0 Then
cMsgBody = "Archive File [" & cArchive & "]" & EOL & EOL
nArcFile = FreeFile
Open cArcFile For Input As nArcFile
Do While Not EOF(nArcFile)
Line Input #1, cLine
If Left(cLine, 1) <> ";" Then
cMsgBody = cMsgBody & cLine & EOL
End If
Loop
Close #nArcFile
Else
cMsgBody = "MLM Archive Error" & EOL & EOL
cMsgBody = cMsgBody & _
"*** Unable to locate Archive [" & cArchive & "]." & EOL
End If
Status "Sending Archive " & cArchive _
& "to " & objAddr.Name & "..."
Set objMsg = objMAPISession.Outbox.Messages.Add
objMsg.subject = "Archive " & cArchive _
& "from " & ControlSetting("ListName")
objMsg.Text = cMsgBody
Set objRecip = objMsg.Recipients.Add
If objAddr.Type = "MS" Then
objRecip.Name = objAddr.Name
objRecip.Type = mapiTo
objRecip.Resolve
Else
objRecip.Name = objAddr.Type & ":" & _
objAddr.address
objRecip.address = objAddr.Type & ":" & _
objAddr.address
objRecip.Type = mapiTo
End If
objMsg.Update
objMsg.Send showDialog:=False
End Sub
Public Function FindArc(cFile As String) As String
Dim cFileDate As String
Dim cFileName As String
Dim cFileTitle As String
Dim cArchFile As String
Dim nArchFile As Integer
Dim cLine As String
Dim nPos1 As Integer
Dim nPos2 As Integer
Dim cReturn As String
cReturn = ""
cArchFile = ControlSetting("ArchiveFile")
nArchFile = FreeFile
Open cArchFile For Input As nArchFile
Do Until EOF(nArchFile)
Line Input #nArchFile, cLine
If Left(cLine, 1) <> ";" Then
nPos1 = InStr(cLine, ",")
If nPos1 <> 0 Then
cFileDate = Left(cLine, nPos1 - 1)
End If
nPos2 = InStr(nPos1 + 1, cLine, ",")
If nPos2 <> 0 Then
cFileName = Mid(cLine, nPos1 + 1, nPos2 - (nPos1 + 1))
End If
If nPos2 < Len(cLine) Then
cFileTitle = Mid(cLine, nPos2 + 1, 255)
Else
cFileTitle = cFileName
End If
End If
If UCase(cFileDate) = UCase(cFile) Then
cReturn = cFileName
Exit Do
End If
Loop
Close #nArchFile
FindArc = cReturn
End Function
Private Sub Timer1_Timer()
MinutesCount = MinutesCount + 1
Status "MinutesCount = " & Str(MinutesCount)
If MinutesCount >= MinutesToWakeUp Then
MinutesCount = 0
ReadInbox
End If
End Sub