VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END Attribute VB_Name = "FileSender" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = True Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Option Explicit 'Standard class declarations Private Declare Function GetPrivateProfileInt Lib "kernel32" Alias "GetPrivateProfileIntA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal nDefault As Long, ByVal lpFileName As String) As Long Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long Private ErStr As String 'holds text for last error encountered Private IAmADll As Boolean 'TRUE if module is running as a DLL Private IniRead As Boolean 'TRUE if .ini file has been read Private MyIniFileName As String 'location of my .ini file Private MyPath As String 'path where this code resides 'Class specific declarations Private Const ModuleName = "FileSender" Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long Private Enum MAPIConst 'MAPI Attachment types MAPI_File = 0 'Attachment Type: data File MAPI_EOLE = 1 'Attachment Type: embedded OLE Object MAPI_SOLE = 2 'Attachment Type: static OLE Object 'MAPI Recipient types MAPIORIG = 0 'Recipient is message originator mapito = 1 'Recipient is a primary recipient mapiCc = 2 'Recipient is a copy recipient mapiBcc = 3 'Recipient is blind copy recipient mapRecipientDelete = 1 'delete current recipient End Enum Private Type OSVERSIONINFO dwOSVersionInfoSize As Long dwMajorVersion As Long dwMinorVersion As Long dwBuildNumber As Long dwPlatformId As Long szCSDVersion As String * 128 'Maintenance string for PSS usage End Type Const MaxRECFMCount = 50 Private CmdTS As TextStream 'Text Stream object Private CSV As CSVStrings 'CSV object Private DCAProgram As String 'fully qualified name of FTTSO Private ErrorPOC As String 'eMail address of person to notify in case of problems Private ExportProgram As String 'name of program to read messages Private FileFilter As String 'type/s of files to receive Private FilePth As String 'local copy of Pth Private FSO As FileSystemObject 'file system object Private HostDirectoryName As String 'name of directory on IBM host Private HostName As String 'name of file on IBM host Private ImportProgram As String 'name of program to send messages Private LoggedOn As Boolean 'TRUE if logged on Private MailDirectory As String 'location of post office directory Private MailOptions As String 'Mail options Private PCDirectory As String 'directory to put attached files Private PKUnZip As String 'fully qualified name of PKUnzip Private PKZip As String 'fully qualified name of PKZip Private PostOffice As String 'name of post office from which to read messages Private ProfileName As String 'profile to use for sending/receiving mail Private RECFM As String 'record format name Private RECFMCount As Integer 'number of RECFMs Private RECFMs(MaxRECFMCount) As String 'list of available record formats Private ServerFilePath As String 'PCDirectory path name on foreign server Private ServerName As String 'name of foreign server Private SetDrive As String 'full name of SETDRIVE utility Private Shell As Sheller 'Sheller object Private SrvrNme As String 'name of server Private SystemVersionInfo As OSVERSIONINFO Private UserName As String 'name of user Private UserPassword As String 'password for user Private MAPISess As Object Private MAPImsg As Object Private Const REG_SZ As Long = 1 Private Const REG_DWORD As Long = 4 Private Const HKEY_CURRENT_USER = &H80000001 Private Const ERROR_NONE = 0 Private Const ERROR_BADDB = 1 Private Const ERROR_BADKEY = 2 Private Const ERROR_CANTOPEN = 3 Private Const ERROR_CANTREAD = 4 Private Const ERROR_CANTWRITE = 5 Private Const ERROR_OUTOFMEMORY = 6 Private Const ERROR_INVALID_PARAMETER = 7 Private Const ERROR_ACCESS_DENIED = 8 Private Const ERROR_INVALID_PARAMETERS = 87 Private Const ERROR_NO_MORE_ITEMS = 259 Private Const KEY_ALL_ACCESS = &H3F Private Const REG_OPTION_NON_VOLATILE = 0 Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" _ (ByVal hKey As Long, _ ByVal lpSubKey As String, _ ByVal ulOptions As Long, _ ByVal samDesired As Long, _ phkResult As Long) As Long Private Declare Function RegQueryValueExString Lib "advapi32.dll" Alias "RegQueryValueExA" _ (ByVal hKey As Long, _ ByVal lpValueName As String, _ ByVal lpReserved As Long, _ lpType As Long, _ ByVal lpData As String, _ lpcbData As Long) As Long Private Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias "RegQueryValueExA" _ (ByVal hKey As Long, _ ByVal lpValueName As String, _ ByVal lpReserved As Long, _ lpType As Long, lpData As Long, _ lpcbData As Long) As Long Private Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias "RegQueryValueExA" _ (ByVal hKey As Long, _ ByVal lpValueName As String, _ ByVal lpReserved As Long, _ lpType As Long, _ ByVal lpData As Long, _ lpcbData As Long) As Long Private Function AddPath(s As String) As String 'Add path value to file name if not already specified If InStr(s, ":") = 0 And InStr(s, "\\") = 0 Then AddPath = MyPath + s 'no path given; add it Else AddPath = s 'path already provided End If End Function Public Function BanyanDelete(FileList As String, Srvr, Pth As String) As Long 'Delete a set of files in path Pth on server Srvr ' FileList is a CSV string of file names ' Srvr is the name of the server. Use "" to select the .ini file value, ServerName ' Use Null to use no server name; implies local drop ' Pth is the path on the server. Use "" to select the .ini file value, ServerFilePath ' Do not use a drive letter if Srvr <> Null Dim s As String 'local copy of FileList Dim T As String 'current file name Const SubName = "BanyanDelete" On Error GoTo HandleTheError If Not Exists(SetDrive) Then BanyanDelete = 2 Call FormatError(SubName, 2, SetDrive + " not found; requested file/s = " + FileList + " not deleted.") Exit Function End If Call GetProfile_Banyan 'get .ini parameters SrvrNme = GetStringArg(Srvr, ServerName) FilePth = GetStringArg(Pth, ServerFilePath) Call Shell.Init(AutoClose) Call Shell.AddCmd("Z:") 'set logged drive to z: If SrvrNme <> "" Then 'map foreign server to a drive letter Call Shell.AddCmd(SetDrive + " p /x") 'unassign drive so file doesnt end up in wrong place by accident Call Shell.AddCmd(SetDrive + " p " + SrvrNme) 'SETDRIVE to proper PCDirectory FilePth = "P:" + ConditionPath(FilePth) End If s = FileList While s <> "" T = CSV.StringFrom(s) 'get file name Call Shell.AddCmd("Delete " + ConditionPath(FilePth) + T) 'build delete command Wend BanyanDelete = Shell.Run If Not Exists(ConditionPath(FilePth) + T) Then BanyanDelete = 2 Call FormatError(SubName, 2, ConditionPath(FilePth) + T + " not found on " + SrvrNme) End If If SrvrNme <> "" Then 'de-map foreign server Call Shell.Init(AutoClose) Call Shell.AddCmd("Z:") 'set logged drive to z: Call Shell.AddCmd(SetDrive + " p /x") 'unassign drive so file doesnt end up in wrong place by accident Shell.Run End If Exit Function HandleTheError: BanyanDelete = Err.Number Call FormatError(SubName, Err.Number, Err.Description, Erl) End Function Private Sub BanyanMapDrive(Srvr, DriveLetter, Map) 'Map DriveLetter to the location Map on Srvr SrvrNme = GetStringArg(Srvr, ServerName) Call Shell.Init(AutoClose) Call Shell.AddCmd("Z:") 'set logged drive to z: Call Shell.AddCmd(SetDrive + " " + DriveLetter + " /x") 'unassign drive so file doesnt end up in wrong place by accident If SrvrNme <> "" Then Call Shell.AddCmd(SetDrive + " " + DriveLetter + " " + SrvrNme) 'SETDRIVE to proper PCDirectory End If Call Shell.Run End Sub Public Function BanyanReceive(SrcePath As String, FileList As String, Srvr, Pth As String) As Long 'Receive a set of files from Pth on server Srvr ' SourcePath is the local storage path for the files in FileList ' FileList is a CSV string of file names ' Srvr is the name of the server. Use "" to select the .ini file value, ServerName ' Use Null to use no server name; implies local drop ' Pth is the path on the server. Use "" to select the .ini file value, ServerFilePath ' Do not use a drive letter if Srvr <> Null Dim s As String 'local copy of FileList Dim T As String 'current file name Dim SourcePath As String Dim cmd As String Const SubName = "BanyanReceive" On Error GoTo HandleTheError If Not Exists(SetDrive) Then BanyanReceive = 2 'SetDrive not found Call FormatError(SubName, Err.Number, SetDrive + " not found; requested file/s = " + FileList + " not sent/copied.") Exit Function End If Call GetProfile_Banyan 'get .ini parameters SrvrNme = GetStringArg(Srvr, ServerName) FilePth = GetStringArg(Pth, ServerFilePath) SourcePath = GetStringArg(SrcePath, PCDirectory) Call Shell.Init(AutoClose) Call Shell.AddCmd("Z:") 'set logged drive to z: If SrvrNme <> "" Then 'map foreign server to a drive letter Call Shell.AddCmd(SetDrive + " p /x") 'unassign drive so file doesnt end up in wrong place by accident Call Shell.AddCmd(SetDrive + " p " + SrvrNme) 'SETDRIVE to proper PCDirectory FilePth = "P:" + ConditionPath(FilePth) End If s = FileList While s <> "" T = CSV.StringFrom(s) 'get file name cmd = "Copy " + ConditionPath(FilePth) + T + " " + ConditionPath(SourcePath) + T + " /v" 'build copy command If SystemVersionInfo.dwPlatformId <> 2 Then cmd = cmd + " /y" 'add /y for non-NT machine Call Shell.AddCmd(cmd) 'add copy command to batch Wend BanyanReceive = Shell.Run If Not Exists(ConditionPath(SourcePath) + T) Then BanyanReceive = 2 Call FormatError(SubName, 2, ConditionPath(SourcePath) + T + " not found on " + SrvrNme) End If If SrvrNme <> "" Then 'de-map foreign server Call Shell.Init(AutoClose) Call Shell.AddCmd("Z:") 'set logged drive to z: Call Shell.AddCmd(SetDrive + " p /x") 'unassign drive so file doesnt end up in wrong place by accident Shell.Run End If Exit Function HandleTheError: BanyanReceive = Err.Number Call FormatError(SubName, Err.Number, Err.Description, Erl) End Function Public Function BanyanSend(SrcePath As String, FileList As String, Srvr, Pth As String) As Long 'Send a set of files to Pth on server Srvr ' SourcePath is the local source path for the files in FileList ' FileList is a CSV string of file names ' Srvr is the name of the server. Use "" to select the .ini file value, ServerName ' Use Null to use no server name; implies local drop ' Pth is the path on the server. Use "" to select the .ini file value, ServerFilePath ' Do not use a drive letter if Srvr <> Null Dim s As String 'local copy of FileList Dim T As String 'current file name Dim cmd As String Dim SourcePath As String Const SubName = "BanyanSend" On Error GoTo HandleTheError If Not Exists(SetDrive) Then BanyanSend = 2 'SetDrive not found Call FormatError(SubName, Err.Number, SetDrive + " not found; requested file/s = " + FileList + " not sent/copied.") Exit Function End If Call GetProfile_Banyan 'get .ini parameters SrvrNme = GetStringArg(Srvr, ServerName) FilePth = GetStringArg(Pth, ServerFilePath) SourcePath = GetStringArg(SrcePath, PCDirectory) Call Shell.Init(AutoClose) Call Shell.AddCmd("Z:") 'set logged drive to z: If SrvrNme <> "" Then 'map foreign server to a drive letter Call Shell.AddCmd(SetDrive + " p /x") 'unassign drive so file doesnt end up in wrong place by accident Call Shell.AddCmd(SetDrive + " p " + SrvrNme) 'SETDRIVE to proper PCDirectory FilePth = "P:" + ConditionPath(FilePth) End If s = FileList While s <> "" T = CSV.StringFrom(s) 'get file name cmd = "Copy " + ConditionPath(SourcePath) + T + " " + ConditionPath(FilePth) + T + " /v" 'build copy command If SystemVersionInfo.dwPlatformId <> 2 Then cmd = cmd + " /y" 'add /y for non-NT machine Call Shell.AddCmd(cmd) 'add copy command to batch Wend BanyanSend = Shell.Run If Not Exists(ConditionPath(FilePth) + T) Then BanyanSend = 2 Call FormatError(SubName, 2, ConditionPath(FilePth) + T + " not found on " + SrvrNme) End If If SrvrNme <> "" Then 'de-map foreign server Call Shell.Init(AutoClose) Call Shell.AddCmd("Z:") 'set logged drive to z: Call Shell.AddCmd(SetDrive + " p /x") 'unassign drive so file doesnt end up in wrong place by accident Shell.Run End If Exit Function HandleTheError: BanyanSend = Err.Number Call FormatError(SubName, Err.Number, Err.Description, Erl) End Function Public Function ccMailReceive(MessageFile As String) As Long 'Receive available cc:Mail messages and place them where indicated by MessageFile Dim filterpath As String 'path part of filter Dim filtername As String 'name part of filter Dim filterext As String 'extent part of filter Dim MsgFile As String Const SubName = "ccMailReceive" On Error GoTo HandleTheError If Not Exists(ExportProgram) Then ccMailReceive = 2 Call FormatError(SubName, Err.Number, ExportProgram + " not found") Exit Function End If If MessageFile <> "" Then Call FSplit(MessageFile, filterpath, filtername, filterext) PCDirectory = filterpath FileFilter = filterpath + filtername + filterext End If Call GetProfile_ccMail 'get .ini parameters MsgFile = PCDirectory + FileFilter Call Shell.Init(AutoClose) Call Shell.AddCmd(ExportProgram + " " + UserName + " " + UserPassword + " " + MailDirectory + " @" + MsgFile + " " + MailOptions) Call Shell.AddCmd("pause") ccMailReceive = Shell.Run(vbNormalFocus) Exit Function HandleTheError: ccMailReceive = Err.Number Call FormatError(SubName, Err.Number, Err.Description, Erl) End Function Public Function ccMailSend(AddrList As String, FileList As String, Subj As String, BodyOrFName As String) As Long 'Send a cc:Mail message, with possible attachments, to a list of people ' AddrList is a CSV list of valid cc:Mail names. ' FileList is a CSV list of file names to attach; use "" for no attachments ' Subj is the subject of the message ' BodyOrFName is the name of file containing message body or the message itself Dim s As String 'temporary Dim Addr As String Dim ccNam As String 'name of cc:Mail message file Dim TSMessage As TextStream Dim TSBody As TextStream 'text stream for file supplied message body Const INetExt = ".COM,.EDU,.ORG,.NET,.GOV" Const SubName = "ccMailSend" ccNam = "C:\" + "$" + Trim(str(Int(Rnd * 1000000#))) + "$" + ".txt" On Error GoTo ccMailSendError If Not Exists(ImportProgram) Then ccMailSend = 2 'ImportProgram not found Call FormatError(SubName, Err.Number, ImportProgram + " not found; requested file/s = " + FileList + " not sent/copied.") GoTo ccMailExit End If Call GetProfile_ccMail 'get .ini parameters Set TSMessage = FSO.CreateTextFile(ccNam, True) 'open file TSMessage.WriteLine "Message: " 'create message header TSMessage.WriteLine "From: " + UserName s = Trim(AddrList) If Left$(AddrList, 2) = "'" + Chr$(34) Then s = CSV.StringFrom(s) While s <> "" Addr = CSV.StringFrom(s) 'set up addressees If Addr <> "" Then 'Check for Internet addressing} Addr = ChangeChar(Addr, "''", "'") 'fixup apostrophes If InStr(INetExt, Right$(UCase$(Addr), 4)) <> 0 Then Addr = Addr + " at INTERNET-MAIL" TSMessage.WriteLine "To: " + Addr 'set up addressees End If Wend TSMessage.WriteLine "Subject: " + Subj TSMessage.WriteLine "Contents: " 'create message body If Trim(BodyOrFName) <> "" And Exists(BodyOrFName) Then Set TSBody = FSO.OpenTextFile(AddPath(BodyOrFName), ForReading) 'open message body file While Not TSBody.AtEndOfStream 'copy to message file s = TSBody.ReadLine TSMessage.WriteLine s Wend TSBody.Close ElseIf Trim(BodyOrFName) <> "" Then TSMessage.WriteLine BodyOrFName End If s = Trim(FileList) While s <> "" 'attach files TSMessage.WriteLine "File item: " + CSV.StringFrom(s) Wend TSMessage.Close 'close message file Call Shell.Init(AutoClose) s = ImportProgram + " " + MailOptions + " " + UserName + " " + UserPassword + " " + MailDirectory + " @" + ccNam Call Shell.AddCmd(s) ccMailSend = Shell.Run Exit Function ccMailSendError: ccMailSend = Err.Number Call FormatError(SubName, Err.Number, Err.Description, Erl) ccMailExit: If ErrorPOC <> "" Then 'report problem to whomever is designated Set TSMessage = FSO.CreateTextFile("c:\ccmail.txt", True) 'open file TSMessage.WriteLine "Message: " 'create message header TSMessage.WriteLine "From: " + UserName s = Trim(ErrorPOC) If Left$(ErrorPOC, 2) = "'" + Chr$(34) Or Left$(s, 2) = Chr$(34) + "'" Then s = CSV.StringFrom(s) While s <> "" Addr = CSV.StringFrom(s) 'set up addressees TSMessage.WriteLine "To: " + Addr 'set up addressees Wend TSMessage.WriteLine "Subject: Error Sending Message--" + Subj TSMessage.WriteLine "Contents: " + ErStr 'create message body TSMessage.WriteLine "File item: " + ccNam TSMessage.Close 'close message file Call Shell.Init(AutoClose) s = ImportProgram + " " + MailOptions + " " + UserName + " " + UserPassword + " " + MailDirectory + " @" + "c:\ccmail\text" Call Shell.AddCmd(s) Shell.Run End If End Function Private Function ChangeChar(s As String, C1 As String, C2 As String) As String 'Change all occurances of C1 with C2 in the string S. Dim ans As String 'result string Dim l As Long 'position of C1 in Lcl Dim Lcl As String 'internal copy of S Lcl = s If Lcl <> "" Then l = InStr(Lcl, C1) Else l = 0 End If While l <> 0 ans = ans + Left$(Lcl, l - 1) + C2 Lcl = Right$(Lcl, Len(Lcl) - (l - 1 + Len(C1))) l = InStr(Lcl, C1) Wend ChangeChar = ans + Lcl End Function Private Function ConditionPath(s) 'Guarantees trailing \ on path value S Dim ans As String ans = Trim(s) If ans = "\" Then ans = "" 'eliminate \ only If ans <> "" Then 'prevent \ only If Right$(ans, 1) <> "\" Then ans = ans & "\" End If ConditionPath = ans End Function Public Function DOSDelete(FileList As String, Srvr, Pth As String) As Long 'Delete a set of files in Pth via a DOS copy command ' FileList is a CSV string of file names ' Srvr is either driveletter:\ or \\servername\ as desired ' Pth is the path on the server. Use "" to select the .ini file value, ServerFilePath ' Srvr+Pth constitutes the full path to the PCDirectory directory Dim FL As String 'local copy of FileList Dim s As String 'error message Dim T As String 'current file name Dim SrceFile As String 'fully qualified source file name Dim DestFile As String 'fully qualified PCDirectory file name Const SubName = "DOSDelete" On Error GoTo badDOSDelete 'set up to catch errors Call GetProfile_DOS 'get .ini parameters FilePth = GetStringArg(Pth, ServerFilePath) 'get PCDirectory path SrvrNme = GetStringArg(Srvr, ServerName) 'get PCDirectory server name FL = FileList 'get local copy of FileList While FL <> "" 'loop through the list T = CSV.StringFrom(FL) 'get file name DestFile = ConditionPath(SrvrNme + FilePth) + T 'create PCDirectory reference Kill DestFile 'delete the file Wend Exit Function badDOSDelete: 'catch any error DOSDelete = Err.Number Call FormatError(SubName, Err.Number, Err.Description, Erl) End Function Public Function DOSReceive(SrcePath As String, FileList As String, Srvr, Pth As String) As Long 'Receive a set of files from Pth on server Srvr ' SourcePath is the local storage path for the files in FileList ' FileList is a CSV string of file names ' Srvr is the name of the server. Use "" to select the .ini file value, ServerName ' Use Null to use no server name; implies local drop ' Pth is the path on the server. Use "" to select the .ini file value, ServerFilePath ' Do not use a drive letter if Srvr <> Null Dim s As String 'local copy of FileList Dim T As String 'current file name Dim SourcePath As String Dim cmd As String Dim FL As String Dim SrceFile As String Dim DestFile As String Const SubName = "DOSReceive" On Error GoTo HandleTheError Call GetProfile_DOS 'get .ini parameters SrvrNme = GetStringArg(Srvr, ServerName) FilePth = GetStringArg(Pth, ServerFilePath) SourcePath = GetStringArg(SrcePath, PCDirectory) FL = FileList While FL <> "" T = CSV.StringFrom(FL) 'get file name SrceFile = ConditionPath(SourcePath) + T 'create source reference DestFile = ConditionPath(ConditionPath(SrvrNme) + FilePth) + T 'create PCDirectory reference FileCopy DestFile, SrceFile 'copy the file If Not Exists(SrceFile) Then DOSReceive = 2 s = "File Copy " + DestFile + " " + SrceFile + " Failed. File not found." If FL <> "" Then s = s + vbCrLf + FL + " not copied either." Call FormatError(SubName, 2, s) Exit Function End If Wend Exit Function HandleTheError: DOSReceive = Err.Number Call FormatError(SubName, Err.Number, Err.Description, Erl) End Function Public Function DOSSend(SrcePath As String, FileList As String, Srvr, Pth As String) As Long 'Send a set of files to Pth via a DOS copy command ' SourcePath is the local source path for the files in FileList ' FileList is a CSV string of file names ' Srvr is either driveletter:\ or \\servername\ as desired ' Pth is the path on the server. Use "" to select the .ini file value, ServerFilePath ' Srvr+Pth constitutes the full path to the destination directory Dim FL As String 'local copy of FileList Dim s As String 'error message Dim T As String 'current file name Dim SrceFile As String 'fully qualified source file name Dim DestFile As String 'fully qualified destination file name Dim SourcePath As String Dim FPath As String Dim FName As String Dim FExt As String Const SubName = "DOSSend" On Error GoTo badDOSCopy 'set up to catch errors Call GetProfile_DOS 'get .ini parameters FilePth = GetStringArg(Pth, ServerFilePath) 'get PCDirectory path SrvrNme = GetStringArg(Srvr, ServerName) 'get PCDirectory server name SourcePath = ConditionPath(GetStringArg(SrcePath, PCDirectory)) FL = FileList 'get local copy of FileList While FL <> "" 'loop through the list T = CSV.StringFrom(FL) 'get file name Call FSplit(T, FPath, FName, FExt) If FPath <> "" Then 'use caller supplied path if given SrceFile = FPath + FName + FExt Else 'use path from .ini SrceFile = SourcePath + FName + FExt End If 'SrceFile = SourcePath + T 'create source reference DestFile = ConditionPath(ConditionPath(SrvrNme) + FilePth) + FName + FExt 'create PCDirectory reference Debug.Print "Copy " + SrceFile + " to " + DestFile FileCopy SrceFile, DestFile 'copy the file If Not Exists(DestFile) Then DOSSend = 2 s = "File Copy " + SrceFile + " " + DestFile + " Failed. File not found at Destination." If FL <> "" Then s = s + vbCrLf + FL + " not copied either." Call FormatError(SubName, 2, s) Exit Function End If Wend Exit Function badDOSCopy: 'catch any error DOSSend = Err.Number Call FormatError(SubName, Err.Number, Err.Description + ". Copy " + SrceFile + " to " + DestFile + " Failed.", Erl) End Function Public Function EMailReceive(MessageFile As String, Optional MethodOrder As String = "") As Long 'Receive available eMail messages and place them where indicated by MessageFile. MethodOrder determines the order of methods to use. Dim RtnCode As Long 'error return code Dim O As String RtnCode = -1 'initialize O = MethodOrder 'get user's desired order or attempts to send If O = "" Then O = FS_ccMail 'use ccMail if nothing specified While O <> "" And RtnCode <> 0 'loop through the choices until success is achieved Select Case CSV.SingleFrom(O) 'pick what to try Case "ccMail" RtnCode = ccMailReceive(MessageFile) 'try via ccMail Case "MAPI" RtnCode = MAPIReceive(MessageFile) 'try via MAPI Case "Exchange" RtnCode = ExchangeReceive(MessageFile) 'try via exchange End Select Wend EMailReceive = RtnCode 'return result End Function Public Function EMailSend(AddrList As String, FileList As String, Subj As String, BodyOrFName As String, Optional MethodOrder As String = "") As Long 'Send an EMail message, with possible attachments, to a list of people ' AddrList is a CSV list of valid recipient names. ' FileList is a CSV list of file names to attach; use "" for no attachments ' Subj is the subject of the message ' BodyOrFName is the name of a file containing the body of the message or the message itself ' Order is the optional order of sending methods to use Dim RtnCode As Long 'error return code Dim O As String RtnCode = -1 'initialize O = MethodOrder 'get user's desired order or attempts to send If O = "" Then O = FS_ccMail 'use ccMail if nothing specified While O <> "" And RtnCode <> 0 'loop through the choices until success is achieved Select Case CSV.StringFrom(O) 'pick what to try Case "ccMail" RtnCode = ccMailSend(AddrList, FileList, Subj, BodyOrFName) 'try via ccMail Case "MAPI" RtnCode = MAPISend(AddrList, Subj, BodyOrFName, FileList) 'try via MAPI Case "Exchange" RtnCode = ExchangeSend(AddrList, FileList, Subj, BodyOrFName) 'try via exchange End Select Wend EMailSend = RtnCode 'return result End Function Public Property Get Error() As String 'Returns text describing last error occurrance. Use clears the stored text. Error = ErStr ErStr = "" End Property Public Function ExchangeReceive(MessageFile) As Long 'Receive available Exchange Mail messages and place them where indicated by MessageFile. MethodOrder determines the order of methods to use. Const SubName = "ExchangeReceive" On Error GoTo HandleTheError Exit Function HandleTheError: ExchangeReceive = Err.Number Call FormatError(SubName, Err.Number, Err.Description, Erl) End Function Public Function ExchangeSend(AddrList As String, FileList As String, Subj As String, BodyOrFName As String) As Long 'Send an Exchange Mail message, with possible attachments, to a list of people ' AddrList is a CSV list of valid recipient names. ' FileList is a CSV list of file names to attach; use "" for no attachments ' Subj is the subject of the message ' BodyOrFName is the name of file containing message body or the message itself 5 Dim olapp As Object 6 Dim oitem As Object 7 Dim s As String 'temporary 8 Dim T As String 'temporary 9 Dim Addr As String 'Addressee/Recipient name 10 Dim TNum As Integer 'file number of message body file 11 Const SubName = "ExchangeSend" 12 On Error GoTo ExchangeSendError 'set up error handling 13 Set olapp = CreateObject("Outlook.Application") 'link up with Outlook 14 Set oitem = olapp.CreateItem(0) 'start a message 15 oitem.Subject = Subj 'establish its subject 16 s = Trim(AddrList) 'process the address list 17 If Left$(AddrList, 2) = "'" + Chr$(34) Then s = CSV.StringFrom(s) 18 While s <> "" 'loop through the input list 19 Addr = CSV.StringFrom(s) 'get a recipient name 20 If Addr <> "" Then 21 Addr = ChangeChar(Addr, "''", "'") 'fixup apostrophes 22 oitem.Recipients.Add Addr 'add name to recipient list 23 End If 24 Wend 'process message body 26 If Trim(BodyOrFName) <> "" And Exists(BodyOrFName) Then 'body comes from a file 27 TNum = FreeFile 'assign file number 28 s = "" 29 Open AddPath(BodyOrFName) For Input As #TNum 'open message body file 30 While Not EOF(TNum) 'accumulate string containing text 31 Line Input #TNum, T 32 s = s + vbCrLf + T 33 Wend 34 Close #TNum 35 ElseIf Trim(BodyOrFName) <> "" Then 'BodyOrFName contains the text 36 s = Trim(BodyOrFName) 37 End If 38 oitem.Body = s 'set body from accumulated text 39 s = Trim(FileList) 'process attachments 40 While s <> "" 'loop through file names 41 T = CSV.StringFrom(s) 'pick off a name 42 oitem.Attachments.Add T, , , T 'attach it to the message 43 Wend 44 oitem.Send 'all done; send the message 45 Exit Function ExchangeSendError: 46 ExchangeSend = Err.Number 47 Call FormatError(SubName, Err.Number, Err.Description, Erl) End Function Private Function Exists(FileName As String) As Boolean 'Returns TRUE if FileName exists. On Error Resume Next Exists = Len(Dir$(FileName)) <> 0 And FileName <> "" If Err <> 0 Then Exists = False On Error GoTo 0 End Function Private Sub FormatError(SubName, ErrorNumber, Description, Optional ErrorLine As Integer = 0) 'Formats an error message as "ModuleName.SubName: ErrorNumber ErrorLine: Description" ErStr = ModuleName + "." + SubName + ": Error " + Trim(str(ErrorNumber)) If ErrorLine <> 0 Then ErStr = ErStr + " at line " + Trim(str(ErrorLine)) ErStr = ErStr + ": " + Description End Sub Private Sub FSplit(str As String, FilePath As String, FileName As String, Ext As String) 'Splits FileName into its parts Dim LName As String 'local copy of FileName Dim I As Integer FileName = "" FilePath = "" Ext = "" LName = UCase$(str) I = InStr(LName, ".") If I <> 0 Then Ext = Right$(LName, Len(LName) - I + 1) LName = Left$(LName, I - 1) End If If InStr(LName, "\") = 0 Then FileName = LName Exit Sub 'no path End If I = Len(LName) While I > 0 And Mid$(LName, I, 1) <> "\" I = I - 1 Wend If I = 0 Then FileName = LName ElseIf I = Len(LName) Then FilePath = LName Else FilePath = Left$(LName, I) FileName = Right$(LName, Len(LName) - I) End If End Sub Public Function FTPDelete(SrvUsr As String, SrvPWD As String, FileList As String, Srvr, Pth As String) As Long 'Delete a set of files to Pth on FTP server Srvr ' FileList is a CSV string of file names ' Srvr is the name of the server. Use "" to select the .ini file value, ServerName ' Use Null to use no server name; implies local drop ' Pth is the path on the server. Use "" to select the .ini file value, ServerFilePath ' Do not use a drive letter if Srvr <> Null Dim SrvrNme As String 'URL of FTP server Dim FilePth As String 'local copy of Pth Dim USR As String 'local copy of user name Dim PWD As String 'local copy of user password Dim s As String 'error message Dim T As String 'current file name Dim SrceFile As String 'fully qualified source file name Dim DestFile As String 'fully qualified PCDirectory file name Dim cmd As String 'debug Const SubName = "FTPDelete" On Error GoTo badFTPDelete Dim FTPNet As Object Set FTPNet = CreateObject("InetCtls.Inet.1") Call GetProfile_FTP 'get .ini parameters SrvrNme = GetStringArg(Srvr, ServerName) FilePth = GetStringArg(Pth, ServerFilePath) USR = GetStringArg(SrvUsr, UserName) PWD = GetStringArg(SrvPWD, UserPassword) FTPNet.URL = "FTP://" + SrvrNme If USR = "" Then FTPNet.UserName = "anonymous" Else FTPNet.UserName = USR If PWD = "" Then FTPNet.Password = "bkandler" Else FTPNet.Password = PWD s = FileList While s <> "" T = CSV.StringFrom(s) 'get file name to send If FilePth = "" Then DestFile = Right$(SrceFile, Len(SrceFile) - 2) 'remove drive spec. Else DestFile = ConditionPath(FilePth) + T 'build PCDirectory file name End If DestFile = ChangeChar(DestFile, "\", "/") 'change \ to / FTPNet.Execute , "DELETE " + DestFile Do ' Wait until response completed: DoEvents Loop While FTPNet.StillExecuting Wend Exit Function badFTPDelete: FTPDelete = Err.Number Call FormatError(SubName, Err.Number, Err.Description, Erl) End Function Public Function FTPReceive(Srvr, SrvUsr As String, SrvPWD As String, HostFile As String, FileName As String) As Long 'Receive a set of files to Pth on FTP server Srvr ' FileList is a CSV string of file names ' Srvr is the name of the server. Use "" to select the .ini file value, ServerName ' Use Null to use no server name; implies local drop ' Pth is the path on the server. Use "" to select the .ini file value, ServerFilePath ' Do not use a drive letter if Srvr <> Null Dim SrvrNme As String 'URL of FTP server Dim USR As String 'local copy of user name Dim PWD As String 'local copy of user password Dim cmd As String 'debug Dim RPath As String Dim RFile As String Dim PCFile As String Dim LocalPath As String Dim LocalName As String Dim LocalExt As String Dim s As String Const SubName = "FTPReceive" On Error GoTo badFTPReceive Dim FTPNet As Object Set FTPNet = CreateObject("InetCtls.Inet") Call GetProfile_FTP 'get .ini parameters SrvrNme = GetStringArg(Srvr, ServerName) USR = GetStringArg(SrvUsr, UserName) PWD = GetStringArg(SrvPWD, UserPassword) FTPNet.URL = "FTP://" + SrvrNme If USR = "" Then FTPNet.UserName = "anonymous" Else FTPNet.UserName = USR If PWD = "" Then FTPNet.Password = "bkandler" Else FTPNet.Password = PWD Call FSplit(FileName, LocalPath, LocalName, LocalExt) PCFile = LocalName + LocalExt LocalPath = GetStringArg(LocalPath, PCDirectory) Call FTPSplit(HostFile, RPath, RFile) If RPath <> "" Then FTPNet.Execute , "CD " + RPath Do ' Wait until response completed: DoEvents Loop While FTPNet.StillExecuting End If FTPNet.Execute , "GET " + RFile + " " + LocalPath + PCFile Do ' Wait until response completed: DoEvents Loop While FTPNet.StillExecuting 'Set FTPNet = Nothing Exit Function badFTPReceive: FTPReceive = Err.Number Call FormatError(SubName, Err.Number, Err.Description, Erl) End Function Public Function FTPSend(Srvr, SrvUsr As String, SrvPWD As String, HostFile As String, FileName As String) As Long 'Send a set of files to Pth on FTP server Srvr ' SrvPath is the local source path for the files in FileList ' FileList is a CSV string of file names ' Srvr is the name of the server. Use "" to select the .ini file value, ServerName ' Use Null to use no server name; implies local drop ' Pth is the path on the server. Use "" to select the .ini file value, ServerFilePath ' Do not use a drive letter if Srvr <> Null Dim SrvrNme As String 'URL of FTP server Dim USR As String 'local copy of user name Dim PWD As String 'local copy of user password Dim cmd As String 'debug Dim RPath As String Dim RFile As String Dim PCFile As String Dim LocalPath As String Dim LocalName As String Dim LocalExt As String Dim s As String Const SubName = "FTPSend" On Error GoTo badFTP Dim FTPNet As Object Set FTPNet = CreateObject("InetCtls.Inet.1") Call GetProfile_FTP 'get .ini parameters SrvrNme = GetStringArg(Srvr, ServerName) USR = GetStringArg(SrvUsr, UserName) PWD = GetStringArg(SrvPWD, UserPassword) FTPNet.URL = "FTP://" + SrvrNme If USR = "" Then FTPNet.UserName = "anonymous" Else FTPNet.UserName = USR If PWD = "" Then FTPNet.Password = "bkandler" Else FTPNet.Password = PWD Call FSplit(FileName, LocalPath, LocalName, LocalExt) PCFile = LocalName + LocalExt LocalPath = GetStringArg(LocalPath, PCDirectory) Call FTPSplit(HostFile, RPath, RFile) If RPath <> "" Then FTPNet.Execute , "CD " + RPath Do ' Wait until response completed: DoEvents Loop While FTPNet.StillExecuting End If FTPNet.Execute , "PUT " + LocalPath + PCFile + " " + RFile Do ' Wait until response completed: DoEvents Loop While FTPNet.StillExecuting Exit Function badFTP: FTPSend = Err.Number Call FormatError(SubName, Err.Number, Err.Description, Erl) End Function Private Sub FTPSplit(HostFile, RPath, RFile) 'Splits HostFile into its parts Dim s As String Dim c As String c = "" s = ChangeChar(CStr(HostFile), "\", "/") If InStr(s, "/") <> 0 Then c = "/" ElseIf InStr(s, ".") <> Len(s) - 3 Then c = "." End If RFile = "" RPath = "" If c = "" Then RFile = HostFile Exit Sub End If While s <> "" If Right$(s, 1) = c Then RPath = Left$(s, Len(s) - 1) If c = "." Then RPath = "'" + RPath + "'" Exit Sub Else RFile = Right$(s, 1) + RFile s = Left$(s, Len(s) - 1) End If Wend End Sub Public Function FTTSOReceive(SrcePath As String, PCFile As String, HPth As String, HFile As String, RF As String) As Long 'Receive a file from an IBM host ' SourcePath+PCFile is the local source path and file name to send ' HPth+HFile is the host directory and file name ' HPth, HFile, and RF have .ini file default values. ' Use "" to select the .ini file value; Use Null to use no value ' The corresponding .ini file names are HostDirectoryName, HostName, and RECFM, respectively Dim s As String 'local copy of FileList Dim T As String 'current file name Dim SourcePath As String Const SubName = "FTTSOReceive" Dim SrceFile As String 'fully qualified source file name Dim DestFile As String 'fully qualified PCDirectory file name Dim RFM As String 'name of record format Dim cmd As String 'debug On Error GoTo HandleTheError If Not Exists(DCAProgram) Then FTTSOReceive = 2 Call FormatError(SubName, 2, DCAProgram + " not found; requested file = " + DestFile + " not received.") Exit Function End If Call GetProfile_FTTSO 'get .ini parameters SrceFile = ConditionPath(SourcePath) + PCFile DestFile = GetStringArg(HPth, HostDirectoryName) + GetStringArg(HFile, HostName) SourcePath = GetStringArg(SrcePath, PCDirectory) RFM = GetStringArg(RF, RFM) Call Shell.Init(AutoClose) cmd = " /R/N " + SrceFile + " '" + DestFile + "' " + RFM Call Shell.AddCmd(DCAProgram + cmd) 'build copy command FTTSOReceive = Shell.Run(vbNormalFocus) Exit Function HandleTheError: Call FormatError(SubName, Err.Number, Err.Description, Erl) FTTSOReceive = Err.Number End Function Public Function FTTSOSend(SrcePath As String, PCFile As String, HPth As String, HFile As String, RF As String) As Long 'Send a file to an IBM host ' SourcePath+PCFile is the local source path and file name to send ' HPth+HFile is the PCDirectory directory and file name ' HPth, HFile, and RF have .ini file default values. ' Use "" to select the .ini file value; Use Null to use no value ' The corresponding .ini file names are HostDirectoryName, HostName, and RECFM, respectively Dim s As String 'local copy of FileList Dim T As String 'current file name Dim SrceFile As String 'fully qualified source file name Dim DestFile As String 'fully qualified PCDirectory file name Dim RFM As String 'name of record format Dim cmd As String 'debug Dim SourcePath As String Const SubName = "FTTSOSend" On Error GoTo HandleTheError If Not Exists(DCAProgram) Then FTTSOSend = 2 Call FormatError(SubName, Err.Number, DCAProgram + " not found; requested file = " + SrceFile + " not sent.") Exit Function End If Call GetProfile_FTTSO 'get .ini parameters SourcePath = GetStringArg(SrcePath, PCDirectory) SrceFile = ConditionPath(SourcePath) + PCFile DestFile = GetStringArg(HPth, HostDirectoryName) + GetStringArg(HFile, HostName) RFM = GetStringArg(RF, RFM) Call Shell.Init(AutoClose) cmd = " /S/D/N " + SrceFile + " '" + DestFile + "' " + RFM Call Shell.AddCmd(DCAProgram + cmd) 'build copy command FTTSOSend = Shell.Run(vbNormalFocus) Exit Function HandleTheError: Call FormatError(SubName, Err.Number, Err.Description, Erl) FTTSOSend = Err.Number End Function Function GetProfileInt(PName As String, ItemName As String, Default As Long) As Long GetProfileInt = GetPrivateProfileInt(ByVal PName, ByVal ItemName, Default, MyIniFileName) End Function Private Function GetProfileText(PName As String, ItemName As String, Optional Default As String = "") As String 'Returns MyIniFileName contents from section [Pname] for item [ItemName]. Default provides a default value if nothing is found. Dim ans As String * 255 Dim Result As Integer ans = "" Result = GetPrivateProfileString(ByVal PName, ByVal ItemName, ByVal Default, ans, Len(ans), MyIniFileName) ans = (Left$(ans, Result)) If Trim(ans) = "" Then ans = Default GetProfileText = Trim(ans) End Function Private Function GetStringArg(Arg, Def) As String 'Interprets string argument Arg and returns "", Def, or Arg depending on what is found in Arg (Null, "", or string) Dim ans As String If IsNull(Arg) Then 'no value desired; return empty string ans = "" ElseIf Arg = "" Then 'argument value not given; use default value ans = Def Else 'use supplied argument value ans = Arg End If GetStringArg = ans End Function Public Function MAPILogon(Optional sProfileName As String = "") As Long 'Performs a session logon for MAPI Dim sKeyName As String Dim sValueName As String 1 Const SubName = "MAPILogon" 2 On Error Resume Next 3 Call GetProfile_MAPI 'get .ini parameters 4 Set MAPISess = CreateObject("MSMAPI.MAPISession") 5 If MAPISess Is Nothing Then 6 Err.Raise Err.Number, "", "FileSender.MAPILogon:Create failed: " + Err.Description 7 Exit Function 8 End If TryProfile: 9 On Error GoTo TryDefault 10 If Len(sProfileName) Then 'first try to Logon with passed ProfileName 11 MAPISess.UserName = sProfileName 12 ElseIf Len(ProfileName) Then 13 MAPISess.UserName = ProfileName 14 End If If MAPISess.UserName = "" Then GoTo TryDefault 15 MAPISess.SignOn 16 LoggedOn = True 17 ProfileName = MAPISess.UserName 18 Exit Function TryDefault: '19 If Err.Number = -2147221231 Or Err.Number = 0 Or MAPISess.UserName = "" Then 'MAPI_E_LOGON_FAILED 20 'Need to find out what OS is in use, the keys are different for WinNT and Win95. 21 Select Case SystemVersionInfo.dwPlatformId Case 0 'Unidentified OS 22 Exit Function 23 Case 1 'Win95 24 sKeyName = "Software\Microsoft\" & _ "Windows Messaging " & _ "Subsystem\Profiles" 25 Case 2 'NT 26 sKeyName = "Software\Microsoft\Windows NT\" & _ "CurrentVersion\" & _ "Windows Messaging Subsystem\Profiles" 27 End Select 28 sValueName = "DefaultProfile" 29 ProfileName = QueryValue(sKeyName, sValueName) 30 MAPISess.UserName = ProfileName '31 Else '32 GoTo HandleTheError '33 End If 34 On Error GoTo HandleTheError 35 MAPISess.SignOn 'finally try a normal MAPILogon Call PutProfileText("MAPI", "ProfileName", ProfileName) 36 LoggedOn = True 37 Exit Function HandleTheError: 38 Call FormatError(SubName, Err.Number, Err.Description + " Logon failed", Erl) 39 MAPILogon = Err.Number End Function Public Function MAPIReceive(MessageFile As String) As Long 'Recieves available eMail files matching MessageFile and stores them in the path provided withing MessageFile Dim msg As Integer 'index in incoming message array Dim atch As Integer 'index in attachment array Dim Subj As String 'message subject Dim frm As String 'message sender Dim atchfullname As String 'fully qualified name of attachment Dim atchpath As String 'path part of attachment Dim atchname As String 'name part of attachment Dim atchext As String 'extent part of attachment Dim filterpath As String 'path part of filter Dim filtername As String 'name part of filter Dim filterext As String 'extent part of filter 'Dim MAPImsg As MAPImsg Const SubName = "MAPIReceive" On Error GoTo HandleTheError If Not LoggedOn Then MAPILogon If Err.Number Then Exit Function If MessageFile <> "" Then Call FSplit(MessageFile, filterpath, filtername, filterext) PCDirectory = filterpath FileFilter = filterpath + filtername + filterext End If Call GetProfile_MAPI 'get .ini parameters Set MAPImsg = CreateObject("MSMAPI.MAPImessages") If MAPILogon <> 0 Then MsgBox ErStr, vbCritical, "Sorry!" Exit Function End If Call FSplit(FileFilter, filterpath, filtername, filterext) MAPImsg.FetchUnreadOnly = True 'get only new messages MAPImsg.Fetch 'get the mail If MAPImsg.MsgCount <> 0 Then 'we have mail For msg = MAPImsg.MsgCount - 1 To 0 Step -1 'loop through the messages MAPImsg.MsgIndex = msg 'point to a message frm = MAPImsg.MsgOrigDisplayName 'get who sent it Subj = MAPImsg.MsgSubject 'get the message subject If MAPImsg.AttachmentCount <> 0 Then 'there are attachments For atch = 0 To MAPImsg.AttachmentCount - 1 'loop through the attachments MAPImsg.AttachmentIndex = atch 'point to an attachment If MAPImsg.AttachmentType = MAPIConst.MAPI_File Then 'found an attached file atchfullname = MAPImsg.AttachmentPathName 'get name of attachment Call FSplit(atchfullname, atchpath, atchname, atchext) If filtername = "*" Or filtername = atchname Then If filterext = ".*" Or filterext = atchext Then FileCopy atchfullname, PCDirectory + atchname + atchext If Exists(PCDirectory + atchname + atchext) Then Kill atchfullname Else Call FormatError(SubName, 999, "Message " + str(msg + 1) + " From: " + frm + " with Subject: " + Subj + " has Attachment: " + atchfullname + "; copy to " + PCDirectory + atchname + atchext + " failed.", Erl) MAPIReceive = 999 End If End If End If Else Call FormatError(SubName, 999, "Message " + str(msg + 1) + " From: " + frm + " with Subject: " + Subj + " has non-file attachments") MAPIReceive = 999 End If Next 'atch Else 'no attachments End If MAPImsg.Delete 'delete the message Next 'msg End If MAPISess.SignOff Set MAPImsg = Nothing Set MAPISess = Nothing LoggedOn = False Exit Function HandleTheError: MAPIReceive = Err.Number Call FormatError(SubName, Err.Number, Err.Description, Erl) MAPISess.SignOff Set MAPImsg = Nothing Set MAPISess = Nothing LoggedOn = False End Function Public Function MAPISend(AddrList As String, Subj As String, Optional BodyOrFName As String = "", Optional FileList As String = "") As Long 'Performs MAPI eMail send to AddrList with Subj. BodyOrFName provides message body or a file name to send. FileList provides a CSV list of files to send. ' Sends a message to each person in the AddrList. Each message is identified by ' its subject (Subj), may contain a message body (BodyOrFName), and may have one ' or more attached files (FileList). If problems are encountered and the .ini file ' specifies an ErrorPOC, that person gets a message indicating the problem, who the ' addresses were, what addresses might have been faulty, and having all the attachments ' that were to be in the original message. If a non-zero value is returned, function ' Error may be used to obtain the text describing the error encountered. 8 Dim ACount As Integer 'count of attachments 9 Dim adr As String 'addressee name 10 Dim BadAddresses As String 'list of any bad recipients found 11 Dim BodyPrefix As String 12 Dim FileExt As String 'file extent 13 Dim FileName As String 'file name 14 Dim FilePath As String 'path to file 15 Dim FL As String 'local copy of FileList 16 Dim Note As String 'content of Error Message body 17 Dim s As String 'temp 18 Dim TSBody As TextStream 'text stream for file supplied message body 19 Const SubName = "MAPISend" 20 On Error Resume Next 21 If Not LoggedOn Then MAPILogon 'logon when needed 22 If Err.Number Then Exit Function 'if we can't logon, we can't do anything 23 Call GetProfile_MAPI 'get .ini parameters 24 Set MAPImsg = CreateObject("MSMAPI.MAPImessages") 25 With MAPImsg 26 .SessionID = MAPISess.SessionID 27 .Compose 'start a message 28 s = Trim(AddrList) 29 If Left$(s, 2) = "'" + Chr$(34) Or Left$(s, 2) = Chr$(34) + "'" Then s = CSV.StringFrom(s) 30 While s <> "" 'loop through the input address list 31 adr = CSV.StringFrom(s) 'get a recipient name 32 If adr <> "" Then 33 On Error Resume Next 34 adr = ChangeChar(adr, "''", "'") 'fixup apostrophes 35 .RecipIndex = .RecipCount 'set index for this recipient 36 .RecipAddress = adr 'set recipient particulars 37 .RecipType = MAPIConst.mapito 38 .ResolveName 'make sure address is valid 39 If Err.Number Then 'accumulate bad addresses 40 If BadAddresses = "" Then BadAddresses = "'" + adr + "'" Else BadAddresses = BadAddresses + "," + "'" + adr + "'" 41 .Delete MAPIConst.mapRecipientDelete '=1; delete current recipient so that message can be sent 42 On Error GoTo 0 43 End If 44 End If 45 Wend 'end of recipient loop 46 On Error Resume Next 47 FL = FileList 'get the file list 48 ACount = 0 'initialize attachment counter 49 While FL <> "" 'loop through the list of files 50 s = CSV.StringFrom(FL) 'get a file name 51 If s <> "" Then 'we have a file name 52 If Exists(s) Then 'make sure file exists 53 Call FSplit(s, FilePath, FileName, FileExt) 'get its parts 54 .AttachmentIndex = ACount 'set index for this message 55 .AttachmentType = MAPIConst.MAPI_File 'set the attachment particulars 56 .AttachmentPathName = s 57 .AttachmentName = FileName + FileExt 58 ACount = ACount + 1 'prepare for next attachment 59 End If 60 End If 61 Wend 62 .MsgSubject = Subj 'set the message subject 63 If .AttachmentCount > 0 Then 64 BodyPrefix = String$(.AttachmentCount, " ") 65 Else 66 BodyPrefix = "" 67 End If 68 If Trim(BodyOrFName) <> "" And Exists(BodyOrFName) Then 'we have some body text 69 Set TSBody = FSO.OpenTextFile(AddPath(BodyOrFName), ForReading) 'open message body file 70 Note = "" 71 While Not TSBody.AtEndOfStream 'copy to message file 72 s = TSBody.ReadLine 73 If Note = "" Then 74 Note = s 75 Else 76 Note = Note + vbCrLf + s 'accumulate body text 77 End If 78 Wend 79 TSBody.Close 80 Set TSBody = Nothing 81 .MsgNoteText = BodyPrefix + Note 82 ElseIf Trim(BodyOrFName) <> "" Then 'message body supplied as string 83 .MsgNoteText = BodyPrefix + BodyOrFName 84 End If 85 If .RecipCount >= 1 Then .Send 'send the message 88 End With 89 MAPISend = Err.Number 'return our success or failure 90 If Err.Number <> 0 Or BadAddresses <> "" Then 'we had an error 91 If Err.Number <> 0 Then 92 Call FormatError(SubName, Err.Number, Err.Description, Erl) 'set up error text 93 Else 94 Call FormatError(SubName, 0, "Recipient list contains invalid addresses: " + BadAddresses) 'set up error text 95 End If 96 If ErrorPOC <> "" Then 'notify the ErrorPOC of the problem we had 97 With MAPImsg 98 .Compose 'start a new message 99 s = Trim(ErrorPOC) 100 If Left$(ErrorPOC, 2) = "'" + Chr$(34) Or Left$(s, 2) = Chr$(34) + "'" Then s = CSV.StringFrom(s) 101 While s <> "" 'loop through the input list 102 adr = CSV.StringFrom(s) 'get a recipient name 103 If adr <> "" Then 104 adr = ChangeChar(adr, "''", "'") 'fixup apostrophes 105 .RecipIndex = .RecipCount 106 .RecipAddress = adr 107 .RecipType = MAPIConst.mapito 108 .ResolveName 109 End If 110 Wend 111 FL = FileList 112 ACount = 0 113 While FL <> "" 114 s = CSV.StringFrom(FL) 115 If s <> "" Then 116 If Exists(s) Then 117 Call FSplit(s, FilePath, FileName, FileExt) 118 .AttachmentIndex = ACount 119 ACount = ACount + 1 120 .AttachmentType = MAPIConst.MAPI_File 121 .AttachmentPathName = s 122 .AttachmentName = FileName + FileExt 123 End If 124 End If 125 .MsgSubject = "Error Sending Message--" + Subj 'tell'em what happened 126 Note = BodyPrefix + ErStr + vbCrLf + vbCrLf + BodyOrFName + vbCrLf + vbCrLf + "Message Recipients: " + AddrList 'identify who was being sent to 127 If BadAddresses <> "" Then 'identify any bad addresses 128 Note = Note + vbCrLf + vbCrLf + "Invalid Recipients: " + BadAddresses 129 ErStr = ErStr + vbCrLf + vbCrLf + "Invalid Recipients: " + BadAddresses 130 End If 131 If FileList <> "" Then 'note attachments 132 Note = Note + vbCrLf + vbCrLf + "Attachments were included and are attached to this message." 133 End If 134 .MsgNoteText = Note 135 Wend 136 .Send 'send the message 137 End With 138 End If 139 End If 140 MAPISess.SignOff 141 Set MAPImsg = Nothing 142 Set MAPISess = Nothing LoggedOn = False End Function Private Sub PutProfileText(Sect As String, Item As String, V As String) 'Write string 'V' to the .ini file in section 'Sect' with the name 'Item' Dim Result As Integer Result = WritePrivateProfileString(ByVal Sect, ByVal Item, ByVal V, MyIniFileName) End Sub Private Function RemoveMyPath(s As String) As String 'If S begins with MyPath, returns S with MyPath removed. Otherwise returns S unchanged. 'Using this with .ini files, allows them to be moved to new directories without 'change as long as the associated data files are in the same directory as the program. If InStr(UCase$(s), UCase$(MyPath)) = 1 Then RemoveMyPath = Right$(s, Len(s) - Len(MyPath)) Else RemoveMyPath = s End If End Function Public Sub SetupIni(APath As String, AnIniFile As String) 'Sets MyPath=APath and MyIniFileName=AnIniFile If APath <> "" Then MyPath = ConditionPath(APath) If AnIniFile <> "" Then MyIniFileName = AddPath(AnIniFile) End Sub Public Function ZipFile(ZFile As String, File As String) As Long 'compress File into ZFile Const SubName = "ZipFile" Call GetProfile_PKZip 'get .ini parameters If Not Exists(File) Then ZipFile = 2 Call FormatError(SubName, 2, File + " does not exist") ElseIf Not Exists(PKZip) Then ZipFile = 99 Call FormatError(SubName, 99, PKZip + " does not exist") Else Call Shell.Init(AutoClose) Call Shell.AddCmd(PKZip + " " + ZFile + " " + File) ZipFile = Shell.Run End If End Function Private Sub Class_Initialize() IAmADll = (App.StartMode = vbSModeAutomation) 'TRUE if we are operating as a DLL LoggedOn = False If IAmADll Then MyPath = App.Path + "\" MyIniFileName = MyPath + App.EXEName + ".ini" Else End If IniRead = False SystemVersionInfo.dwOSVersionInfoSize = 148 Call GetVersionEx(SystemVersionInfo) 'get operating system information Set Shell = New Sheller Set CSV = New CSVStrings Set FSO = New FileSystemObject End Sub Private Sub Class_Terminate() Set Shell = Nothing Set CSV = Nothing Set FSO = Nothing End Sub Public Function FS_ccMail() 'Returns "ccMail," FS_ccMail = "ccMail," End Function Public Function FS_Exchange() 'Returns "Exchange," FS_Exchange = "Exchange," End Function Public Function FS_MAPI() 'Returns "MAPI," FS_MAPI = "MAPI," End Function Private Sub GetProfile_Banyan() 'get .ini file settings SetDrive = AddPath(GetProfileText("Banyan", "SetDrive", "z:\SetDrive.com")) ServerName = GetProfileText("Banyan", "ServerName", "FSUSERS@CIS1@CRP") ServerFilePath = ConditionPath(GetProfileText("Banyan", "ServerFilePath", "CIS1\ALL\CHAOS")) PCDirectory = GetProfileText("Banyan", "PCDirectory") On Error Resume Next Call PutProfileText("Banyan", "SetDrive", RemoveMyPath(SetDrive)) Call PutProfileText("Banyan", "ServerName", ServerName) Call PutProfileText("Banyan", "ServerFilePath", ServerFilePath) Call PutProfileText("Banyan", "PCDirectory", PCDirectory) End Sub Private Sub GetProfile_ccMail() 'get .ini file settings ImportProgram = AddPath(GetProfileText("ccMail", "ImportProgram", "Import.exe")) ExportProgram = AddPath(GetProfileText("ccMail", "ExportProgram", "Export.exe")) PostOffice = GetProfileText("ccMail", "PostOffice", "LCOR-TOR") MailDirectory = GetProfileText("ccMail", "MailDirectory", "M:\CCDATA") UserName = GetProfileText("ccMail", "UserName", "FaisUser") UserPassword = GetProfileText("ccMail", "UserPassword", "FaisUser2") MailOptions = GetProfileText("ccMail", "MailOptions", "NAME/1") FileFilter = GetProfileText("ccMail", "FileFilter") PCDirectory = GetProfileText("ccMail", "PCDirectory") ErrorPOC = GetProfileText("ccMail", "ErrorPOC") On Error Resume Next Call PutProfileText("ccMail", "ImportProgram", RemoveMyPath(ImportProgram)) Call PutProfileText("ccMail", "ExportProgram", RemoveMyPath(ExportProgram)) Call PutProfileText("ccMail", "PostOffice", PostOffice) Call PutProfileText("ccMail", "MailDirectory", MailDirectory) Call PutProfileText("ccMail", "UserName", UserName) Call PutProfileText("ccMail", "UserPassword", UserPassword) Call PutProfileText("ccMail", "MailOptions", MailOptions) Call PutProfileText("ccMail", "FileFilter", FileFilter) Call PutProfileText("ccMail", "PCDirectory", PCDirectory) Call PutProfileText("ccMail", "ErrorPOC", ErrorPOC) End Sub Private Sub GetProfile_DOS() 'get .ini file settings ServerFilePath = ConditionPath(GetProfileText("DOS", "ServerFilePath")) PCDirectory = GetProfileText("DOS", "PCDirectory") On Error Resume Next Call PutProfileText("DOS", "ServerFilePath", ServerFilePath) Call PutProfileText("DOS", "PCDirectory", PCDirectory) End Sub Private Sub GetProfile_FTP() 'get .ini file settings Dim I As Integer Dim s As String ServerName = GetProfileText("FTP", "ServerName", "koala.corp.logicon.com") ServerFilePath = ConditionPath(GetProfileText("FTP", "ServerFilePath")) UserName = GetProfileText("FTP", "UserName") UserPassword = GetProfileText("FTP", "UserPassword") PCDirectory = GetProfileText("FTP", "PCDirectory") RECFMCount = 0 'Load RECFM definitions For I = 1 To MaxRECFMCount s = UCase$(GetProfileText("FTP", "RECFM" + Format(I, "00"))) If s <> "" Then RECFMCount = RECFMCount + 1 RECFMs(RECFMCount) = s End If Next I On Error Resume Next Call PutProfileText("FTP", "ServerName", ServerName) Call PutProfileText("FTP", "ServerFilePath", ServerFilePath) Call PutProfileText("FTP", "UserName", UserName) Call PutProfileText("FTP", "UserPassword", UserPassword) Call PutProfileText("FTP", "PCDirectory", PCDirectory) For I = 1 To RECFMCount Call PutProfileText("FTP", "RECFM" + Format(I, "00"), RECFMs(I)) Next I End Sub Private Sub GetProfile_FTTSO() 'get .ini file settings DCAProgram = AddPath(GetProfileText("FTTSO", "DCAProgram", "FTTSO")) HostDirectoryName = GetProfileText("FTTSO", "HostDirectoryName") HostName = GetProfileText("FTTSO", "HostName") RECFM = GetProfileText("FTTSO", "RECFM") PCDirectory = GetProfileText("FTTSO", "PCDirectory") On Error Resume Next Call PutProfileText("FTTSO", "DCAProgram", RemoveMyPath(DCAProgram)) Call PutProfileText("FTTSO", "HostDirectoryName", HostDirectoryName) Call PutProfileText("FTTSO", "HostName", HostName) Call PutProfileText("FTTSO", "RECFM", RECFM) Call PutProfileText("FTTSO", "PCDirectory", PCDirectory) End Sub Private Sub GetProfile_MAPI() 'get .ini file settings ProfileName = GetProfileText("MAPI", "ProfileName") ', "MS Exchange Settings") FileFilter = GetProfileText("MAPI", "FileFilter", "*.*") PCDirectory = ConditionPath(GetProfileText("MAPI", "PCDirectory", MyPath)) ErrorPOC = GetProfileText("MAPI", "ErrorPOC") On Error Resume Next Call PutProfileText("MAPI", "ProfileName", ProfileName) Call PutProfileText("MAPI", "FileFilter", FileFilter) Call PutProfileText("MAPI", "PCDirectory", PCDirectory) Call PutProfileText("MAPI", "ErrorPOC", ErrorPOC) End Sub Private Sub GetProfile_PKZip() 'get .ini file settings PKZip = AddPath(GetProfileText("PKZip", "PKZip", "PKZip.exe")) PKUnZip = AddPath(GetProfileText("PKZIP", "PKUnZip", "PKUnZip.exe")) On Error Resume Next Call PutProfileText("PKZip", "PKZip", RemoveMyPath(PKZip)) Call PutProfileText("PKZip", "PKUnZip", RemoveMyPath(PKUnZip)) End Sub Public Function SendError() As String SendError = ErStr End Function Private Function QueryValue(sKeyName As String, sValueName As String) Dim lRetVal As Long 'result of the API functions Dim hKey As Long 'handle of opened key Dim vValue As Variant 'setting of queried value lRetVal = RegOpenKeyEx(HKEY_CURRENT_USER, sKeyName, 0, KEY_ALL_ACCESS, hKey) lRetVal = QueryValueEx(hKey, sValueName, vValue) QueryValue = vValue RegCloseKey (hKey) End Function Function QueryValueEx(ByVal lhKey As Long, ByVal szValueName As String, vValue As Variant) As Long Dim cch As Long Dim lrc As Long Dim lType As Long Dim lValue As Long Dim sValue As String On Error GoTo QueryValueExError lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch) 'Determine size and type of data to be read If lrc <> ERROR_NONE Then Error 5 Select Case lType Case REG_SZ: 'For strings sValue = String(cch, 0) lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, sValue, cch) If lrc = ERROR_NONE Then vValue = Left$(sValue, cch) Else vValue = Empty End If Case REG_DWORD: ' For DWORDS lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, lValue, cch) If lrc = ERROR_NONE Then vValue = lValue Case Else 'all other data types not supported lrc = -1 End Select QueryValueExExit: QueryValueEx = lrc Exit Function QueryValueExError: Resume QueryValueExExit End Function