ivanszabo/Nuvolar
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

First create solution

Browse Source
This commit is contained in:
ivanszabo
2017-03-08 11:21:27 +01:00
commit a2fb86bacf
5508 changed files with 1082238 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files
Nuvolar.Module/BusinessObjects/SIS/App_Code/DynamicLinq.vb
+1941
View File
File diff suppressed because it is too large Load Diff
Nuvolar.Module/BusinessObjects/SIS/App_Code/EncryptDecrypt.vb
+95
View File
@@ -0,0 +1,95 @@
Imports System.Text
Imports System.Security.Cryptography
Imports System.IO
Imports DevExpress.Xpo.Metadata
Public Module EncryptDecrypt
Public Function AESEncrypt(ByVal PlainText As String, ByVal Password As String, ByVal salt As String) As String
Const HashAlgorithm As String = "SHA1" 'Can be SHA1 or MD5
Const PasswordIterations As Integer = 2
Const InitialVector As String = "CanEncryption123" 'This should be a string of 16 ASCII characters.
Const KeySize As Integer = 256 'Can be 128, 192, or 256.
If (String.IsNullOrEmpty(PlainText)) Then
Return ""
Exit Function
End If
Dim InitialVectorBytes As Byte() = Encoding.ASCII.GetBytes(InitialVector)
Dim SaltValueBytes As Byte() = Encoding.ASCII.GetBytes(salt)
Dim PlainTextBytes As Byte() = Encoding.UTF8.GetBytes(PlainText)
Dim DerivedPassword As PasswordDeriveBytes = New PasswordDeriveBytes(Password, SaltValueBytes, HashAlgorithm, PasswordIterations)
Dim KeyBytes As Byte() = DerivedPassword.GetBytes(KeySize / 8)
Dim SymmetricKey As RijndaelManaged = New RijndaelManaged() With {.Mode = CipherMode.CBC}
Dim CipherTextBytes As Byte() = Nothing
Using Encryptor As ICryptoTransform = SymmetricKey.CreateEncryptor(KeyBytes, InitialVectorBytes)
Using MemStream As New MemoryStream()
Using CryptoStream As New CryptoStream(MemStream, Encryptor, CryptoStreamMode.Write)
CryptoStream.Write(PlainTextBytes, 0, PlainTextBytes.Length)
CryptoStream.FlushFinalBlock()
CipherTextBytes = MemStream.ToArray()
MemStream.Close()
CryptoStream.Close()
End Using
End Using
End Using
SymmetricKey.Clear()
Return Convert.ToBase64String(CipherTextBytes)
End Function
Public Function AESDecrypt(ByVal CipherText As String, ByVal password As String, ByVal salt As String) As String
On Error Resume Next
Const HashAlgorithm As String = "SHA1"
Const PasswordIterations As Integer = 2
Const InitialVector As String = "CanEncryption123"
Const KeySize As Integer = 256
If (String.IsNullOrEmpty(CipherText)) Then
Return ""
End If
Dim InitialVectorBytes As Byte() = Encoding.ASCII.GetBytes(InitialVector)
Dim SaltValueBytes As Byte() = Encoding.ASCII.GetBytes(salt)
Dim CipherTextBytes As Byte() = Convert.FromBase64String(CipherText)
Dim DerivedPassword As PasswordDeriveBytes = New PasswordDeriveBytes(password, SaltValueBytes, HashAlgorithm, PasswordIterations)
Dim KeyBytes As Byte() = DerivedPassword.GetBytes(KeySize / 8)
Dim SymmetricKey As RijndaelManaged = New RijndaelManaged() With {.Mode = CipherMode.CBC}
Dim PlainTextBytes As Byte() = New Byte(CipherTextBytes.Length - 1) {}
Dim ByteCount As Integer = 0
Using Decryptor As ICryptoTransform = SymmetricKey.CreateDecryptor(KeyBytes, InitialVectorBytes)
Using MemStream As MemoryStream = New MemoryStream(CipherTextBytes)
Using CryptoStream As CryptoStream = New CryptoStream(MemStream, Decryptor, CryptoStreamMode.Read)
ByteCount = CryptoStream.Read(PlainTextBytes, 0, PlainTextBytes.Length)
MemStream.Close()
CryptoStream.Close()
End Using
End Using
End Using
SymmetricKey.Clear()
Return Encoding.UTF8.GetString(PlainTextBytes, 0, ByteCount)
End Function
End Module
Public Class Encryption
Inherits ValueConverter
Public Overrides Function ConvertToStorageType(ByVal value As Object) As Object
If value IsNot Nothing Then
Return AESEncrypt(value.ToString, "HrX12!!0Zm7764W2", "vXm657YS+!0@mmT")
Else
Return Nothing
End If
End Function
Public Overrides Function ConvertFromStorageType(ByVal value As Object) As Object
If value Is Nothing Then
Return Nothing
Else
Return AESDecrypt(value.ToString, "HrX12!!0Zm7764W2", "vXm657YS+!0@mmT")
End If
End Function
Public Overrides ReadOnly Property StorageType() As Type
Get
Return GetType(String)
End Get
End Property
End Class
Nuvolar.Module/BusinessObjects/SIS/App_Code/GLFunctions.vb
+528
View File
@@ -0,0 +1,528 @@
Imports System
Imports System.ComponentModel
Imports DevExpress.Xpo
Imports DevExpress.Data.Filtering
Imports DevExpress.ExpressApp
Imports DevExpress.Persistent.Base
Imports DevExpress.Persistent.BaseImpl
Imports DevExpress.Persistent.Validation
Imports DevExpress.Persistent.Base.General
Imports System.Data.SqlClient
Imports System.Configuration
Imports System.Linq
Imports System.Linq.Expressions
Public Module GLFunctions
Public Sub ReconfigurePCI(_uow As UnitOfWork, _CustomersFrom As CustomersFrom, _Customers As Customers, _PartnerType As ePartnerType, _ConnectInfo As String)
Dim _PCIDetail As PCIDetail = Nothing
Dim _PCIDetail1 As PCIDetail = Nothing
Dim _PCIGroup As PCIGroup = Nothing
Dim _GLAccounts As GLAccounts = Nothing
Dim _GLRows As GLRows = Nothing
Dim _InvoiceHeader As InvoiceHeader = Nothing
Dim _RegistryHeader As RegistryHeader = Nothing
Dim _DateExecution_Account As Date
Dim _DatePayment_Account As Date
Dim _CurrencyName_Account As CurrencyName = Nothing
Dim _PCIDetail_Collection As XPCollection(Of PCIDetail)
If _Customers Is Nothing Then Exit Sub
If _CustomersFrom Is Nothing Then Exit Sub
If _PartnerType = ePartnerType.eNotSet Then Exit Sub
If _ConnectInfo Is Nothing Then _ConnectInfo = ""
Try
' HIBAJAVÍTÁS MIATT
Dim _GLAccount_Collection_X As New XPCollection(Of GLAccounts)(_uow, CriteriaOperator.Parse("IsNull(ConnectInfo)=True or ConnectInfo=''"))
For Each _GLAccounts In _GLAccount_Collection_X
Select Case GLOBAL_SQLType
Case eSQLType.PostgreSQL
_uow.ExecuteNonQuery("update ""GLAccounts"" set ""ConnectInfo""='" & _GLAccounts.DocumentNumber & "' Where ""Oid""='" & _GLAccounts.Oid.ToString & "'")
Case eSQLType.MSSQL, eSQLType.MySQL
_uow.ExecuteNonQuery("update GLAccounts set ConnectInfo='" & _GLAccounts.DocumentNumber & "' Where Oid='" & _GLAccounts.Oid.ToString & "'")
End Select
Next
_uow.CommitChanges()
'--- Itt kezdődik -----------------------------------------------------------------------------------------------------------------------------------
Dim _PCIGroup_Collection As New XPCollection(Of PCIGroup)(PersistentCriteriaEvaluationBehavior.InTransaction, _
_uow, CriteriaOperator.Parse("CustomersFrom.Oid=? and Customers.Oid=? and PartnerType=? and ConnectInfo=?", _
_CustomersFrom.Oid, _Customers.Oid, _PartnerType, _ConnectInfo))
For Each _PCIGroup In _PCIGroup_Collection
Select Case GLOBAL_SQLType
Case eSQLType.PostgreSQL
_uow.ExecuteNonQuery("update ""InvoiceHeader"" set ""PCIGroup""=Null Where ""PCIGroup""='" & _PCIGroup.Oid.ToString & "'")
_uow.ExecuteNonQuery("update ""PCIGroupAging"" set ""PCIGroup""=Null Where ""PCIGroup""='" & _PCIGroup.Oid.ToString & "'")
_uow.CommitChanges()
Case Else
_uow.ExecuteNonQuery("update InvoiceHeader set PCIGroup=Null Where PCIGroup='" & _PCIGroup.Oid.ToString & "'")
_uow.ExecuteNonQuery("update PCIGroupAging set PCIGroup=Null Where PCIGroup='" & _PCIGroup.Oid.ToString & "'")
_uow.CommitChanges()
End Select
Next
Dim _SQL As String = ""
Select Case GLOBAL_SQLType
Case eSQLType.PostgreSQL
_SQL = "delete from ""PCIDetail"" where ""CustomersFrom""='" & _CustomersFrom.Oid.ToString & "' and"
_SQL += " ""Customers""='" & _Customers.Oid.ToString & "' and"
_SQL += " ""PartnerType""=" & _PartnerType & " and"
_SQL += " ""ConnectInfo""='" & _ConnectInfo & "'"
_uow.ExecuteNonQuery(_SQL)
_SQL = "delete from ""PCIGroup"" where ""CustomersFrom""='" & _CustomersFrom.Oid.ToString & "' and"
_SQL += " ""Customers""='" & _Customers.Oid.ToString & "' and"
_SQL += " ""PartnerType""=" & _PartnerType & " and"
_SQL += " ""ConnectInfo""='" & _ConnectInfo & "'"
_uow.ExecuteNonQuery(_SQL)
Case Else
_SQL = "delete from PCIDetail where CustomersFrom='" & _CustomersFrom.Oid.ToString & "' and"
_SQL += " Customers='" & _Customers.Oid.ToString & "' and"
_SQL += " PartnerType=" & _PartnerType & " and"
_SQL += " ConnectInfo='" & _ConnectInfo & "'"
_uow.ExecuteNonQuery(_SQL)
_SQL = "delete from PCIGroup where CustomersFrom='" & _CustomersFrom.Oid.ToString & "' and"
_SQL += " Customers='" & _Customers.Oid.ToString & "' and"
_SQL += " PartnerType=" & _PartnerType & " and"
_SQL += " ConnectInfo='" & _ConnectInfo & "'"
_uow.ExecuteNonQuery(_SQL)
End Select
_uow.CommitChanges()
_PCIGroup = Nothing
_PCIDetail = Nothing
'I. A lekönyvelt GLAccounts dokumentumok
Dim _GLAccounts_Collection As New XPCollection(Of GLAccounts)(PersistentCriteriaEvaluationBehavior.InTransaction, _
_uow, CriteriaOperator.Parse("IsDeleted=False and CustomersFrom.Oid=? and Customers.Oid=? and PartnerType=? and ConnectInfo=? and IsEditable=False", _
_CustomersFrom.Oid, _Customers.Oid, _PartnerType, _ConnectInfo))
For Each _GLAccounts In _GLAccounts_Collection
'If _PCIDetail Is Nothing Then
_PCIDetail = New PCIDetail(_uow)
_PCIDetail.GLAccounts = _GLAccounts
_PCIDetail.MainType = "01-Account"
_PCIDetail.CustomersFrom = _uow.GetObjectByKey(Of CustomersFrom)(_CustomersFrom.Oid)
_PCIDetail.Customers = _uow.GetObjectByKey(Of Customers)(_Customers.Oid)
_PCIDetail.PartnerType = _PartnerType
_PCIDetail.ConnectInfo = _ConnectInfo
_PCIDetail.DocumentNumber = _GLAccounts.DocumentNumber
_PCIDetail.CurrencyName = _GLAccounts.CurrencyName
_PCIDetail.DateExecution = _GLAccounts.DateExecution
_PCIDetail.DateCreated = _GLAccounts.DateCreated
_PCIDetail.DateExecution_Account = _GLAccounts.DateExecution
_PCIDetail.DatePayment_Account = _GLAccounts.DatePayment
If _GLAccounts.PaymentOption Is Nothing Then
_PCIDetail.Paymode_Account = ePayMode.InTransfer
Else
_PCIDetail.Paymode_Account = _GLAccounts.PaymentOption.PayMode
End If
_PCIDetail.CurrencyName_Account = _GLAccounts.CurrencyName
_PCIDetail.AmountDEV_Account = _GLAccounts.AmountDEVBrutto
_PCIDetail.AmountHUF_Account = _GLAccounts.AmountHUFBrutto
_CurrencyName_Account = _GLAccounts.CurrencyName
_DateExecution_Account = _GLAccounts.DateExecution
_DatePayment_Account = _GLAccounts.DatePayment
If _GLAccounts.ImportedRegistryHeader IsNot Nothing Then
_PCIDetail.RegistryNumber = _GLAccounts.ImportedRegistryHeader.RegistryNumber
Else
_PCIDetail.RegistryNumber = _GLAccounts.RegistryNumber
End If
If _PCIGroup Is Nothing Then
_PCIGroup = New PCIGroup(_uow)
_PCIGroup.CustomersFrom = _uow.GetObjectByKey(Of CustomersFrom)(_CustomersFrom.Oid)
_PCIGroup.Customers = _uow.GetObjectByKey(Of Customers)(_Customers.Oid)
_PCIGroup.PartnerType = _PartnerType
_PCIGroup.ConnectInfo = _ConnectInfo
_PCIGroup.DocumentNumber = _GLAccounts.DocumentNumber
_PCIGroup.Description = _GLAccounts.NoteHeader
_PCIGroup.GLAccounts = _GLAccounts
_PCIGroup.CurrencyName = _CurrencyName_Account
_PCIGroup.CurrencyName_Account = _CurrencyName_Account
_PCIGroup.DateCreated_Account = _GLAccounts.DateCreated
_PCIGroup.DateExecution_Account = _DateExecution_Account
_PCIGroup.DatePayment_Account = _GLAccounts.DatePayment
If _GLAccounts.PaymentOption Is Nothing Then
_PCIGroup.Paymode_Account = ePayMode.InTransfer
Else
_PCIGroup.Paymode_Account = _GLAccounts.PaymentOption.PayMode
End If
_PCIGroup.AmountDEV_Account = _GLAccounts.AmountDEVBrutto
_PCIGroup.AmountHUF_Account = _GLAccounts.AmountHUFBrutto
If _GLAccounts.ImportedRegistryHeader IsNot Nothing Then
_PCIGroup.RegistryNumber = _GLAccounts.ImportedRegistryHeader.RegistryNumber
Else
_PCIGroup.RegistryNumber = _GLAccounts.RegistryNumber
End If
If _GLAccounts.PartnerType = ePartnerType.ePayabels Then
_PCIGroup.RegistryHeader = _GLAccounts.ImportedRegistryHeader
Else
_PCIGroup.InvoiceHeader = _GLAccounts.ImportedInvoice
End If
End If
_PCIDetail.PCIGroup = _PCIGroup
'End If
_PCIDetail.BallanceDEV += _GLAccounts.AmountDEVBrutto
_PCIDetail.BallanceHUF += _GLAccounts.AmountHUFBrutto
_PCIGroup.BallanceDEV += _GLAccounts.AmountDEVBrutto
_PCIGroup.BallanceHUF += _GLAccounts.AmountHUFBrutto
If _GLAccounts.ImportedInvoice IsNot Nothing Then
_GLAccounts.ImportedInvoice.PCIGroup = _PCIGroup
End If
Next
_uow.CommitChanges()
_PCIDetail = Nothing
'II. A kimenő számla, ami nincs feladva !
If _PartnerType = ePartnerType.eReceivables Then
Dim _InvoiceHeader_Collection As New XPCollection(Of InvoiceHeader)(PersistentCriteriaEvaluationBehavior.InTransaction, _
_uow, CriteriaOperator.Parse("IsDeleted=False and isnull(DocumentNumber)=False and CustomersFrom.Oid=? and Customers.Oid=? and ConnectInfo=? and IsEditable=False and isnull(GLAccounts)=True", _
_CustomersFrom.Oid, _Customers.Oid, _ConnectInfo))
For Each _InvoiceHeader In _InvoiceHeader_Collection
'If _PCIDetail Is Nothing Then
_PCIDetail = New PCIDetail(_uow)
_PCIDetail.InvoiceHeader = _InvoiceHeader
_PCIDetail.MainType = "01-Account"
_PCIDetail.CustomersFrom = _uow.GetObjectByKey(Of CustomersFrom)(_CustomersFrom.Oid)
_PCIDetail.Customers = _uow.GetObjectByKey(Of Customers)(_Customers.Oid)
_PCIDetail.PartnerType = _PartnerType
_PCIDetail.ConnectInfo = _ConnectInfo
_PCIDetail.DocumentNumber = _InvoiceHeader.DocumentNumber
_PCIDetail.CurrencyName = _InvoiceHeader.CurrencyName
_PCIDetail.DateExecution = _InvoiceHeader.DateExecution
_PCIDetail.DateCreated = _InvoiceHeader.DateCreated
_PCIDetail.DateExecution_Account = _InvoiceHeader.DateExecution
_PCIDetail.DatePayment_Account = _InvoiceHeader.DatePayment
_PCIDetail.Paymode_Account = _InvoiceHeader.PaymentOption.PayMode
_PCIDetail.CurrencyName_Account = _InvoiceHeader.CurrencyName
_PCIDetail.AmountDEV_Account = _InvoiceHeader.TotalBruttoDEV
_PCIDetail.AmountHUF_Account = _InvoiceHeader.TotalBruttoHUF
_PCIDetail.Description = _InvoiceHeader.DocumentNumber
_CurrencyName_Account = _InvoiceHeader.CurrencyName
_DateExecution_Account = _InvoiceHeader.DateExecution
_DatePayment_Account = _InvoiceHeader.DatePayment
If _PCIGroup Is Nothing Then
_PCIGroup = New PCIGroup(_uow)
_PCIGroup.CustomersFrom = _uow.GetObjectByKey(Of CustomersFrom)(_CustomersFrom.Oid)
_PCIGroup.Customers = _uow.GetObjectByKey(Of Customers)(_Customers.Oid)
_PCIGroup.PartnerType = _PartnerType
_PCIGroup.ConnectInfo = _ConnectInfo
_PCIGroup.DocumentNumber = _InvoiceHeader.DocumentNumber
_PCIGroup.Description = _InvoiceHeader.Description
_PCIGroup.CurrencyName = _CurrencyName_Account
_PCIGroup.CurrencyName_Account = _CurrencyName_Account
_PCIGroup.DateCreated_Account = _InvoiceHeader.DateCreated
_PCIGroup.DateExecution_Account = _DateExecution_Account
_PCIGroup.DatePayment_Account = _InvoiceHeader.DatePayment
_PCIGroup.Paymode_Account = _InvoiceHeader.PaymentOption.PayMode
_PCIGroup.InvoiceHeader = _InvoiceHeader
_PCIGroup.AmountDEV_Account = _InvoiceHeader.TotalBruttoDEV
_PCIGroup.AmountHUF_Account = _InvoiceHeader.TotalBruttoHUF
End If
_PCIDetail.PCIGroup = _PCIGroup
'End If
_PCIDetail.BallanceDEV += _InvoiceHeader.TotalBruttoDEV
_PCIDetail.BallanceHUF += _InvoiceHeader.TotalBruttoHUF
_PCIGroup.BallanceDEV += _InvoiceHeader.TotalBruttoDEV
_PCIGroup.BallanceHUF += _InvoiceHeader.TotalBruttoHUF
_InvoiceHeader.PCIGroup = _PCIGroup
Next
End If
_uow.CommitChanges()
_PCIDetail = Nothing
'IV. A rögzített számla iktatás, ami nincs feladva !
If _PartnerType = ePartnerType.ePayabels Then
Dim _RegistryHeader_Collection As New XPCollection(Of RegistryHeader)(PersistentCriteriaEvaluationBehavior.InTransaction, _
_uow, CriteriaOperator.Parse("IsStorno=False and IsDeleted=False and RegistryAcceptState=0 and RegistryType.RegistryMainType in (0,2,4) and CustomersFrom.Oid=? and Customers.Oid=? and F_ConnectInfo=? and IsEditable=False and isnull(F_GLAccounts)=True", _
_CustomersFrom.Oid, _Customers.Oid, _ConnectInfo))
For Each _RegistryHeader In _RegistryHeader_Collection
'If _PCIDetail Is Nothing Then
_PCIDetail = New PCIDetail(_uow)
_PCIDetail.RegistryHeader = _RegistryHeader
_PCIDetail.MainType = "01-Account"
_PCIDetail.CustomersFrom = _uow.GetObjectByKey(Of CustomersFrom)(_CustomersFrom.Oid)
_PCIDetail.Customers = _uow.GetObjectByKey(Of Customers)(_Customers.Oid)
_PCIDetail.PartnerType = _PartnerType
_PCIDetail.ConnectInfo = _ConnectInfo
_PCIDetail.DocumentNumber = _RegistryHeader.DocumentNumber
_PCIDetail.CurrencyName = _RegistryHeader.F_CurrencyName
_PCIDetail.DateExecution = _RegistryHeader.F_DateExecution
_PCIDetail.DateCreated = _RegistryHeader.DateCreated
_PCIDetail.DatePayment_Account = _RegistryHeader.F_DatePayment
_PCIDetail.Paymode_Account = _RegistryHeader.F_PayMode
_PCIDetail.DateExecution_Account = _RegistryHeader.F_DateExecution
_PCIDetail.CurrencyName_Account = _RegistryHeader.F_CurrencyName
_PCIDetail.AmountDEV_Account = _RegistryHeader.F_AmountBruttoDEV
_PCIDetail.AmountHUF_Account = _RegistryHeader.F_AmountBruttoHUF
_CurrencyName_Account = _RegistryHeader.F_CurrencyName
_DateExecution_Account = _RegistryHeader.F_DateExecution
_DatePayment_Account = _RegistryHeader.F_DatePayment
_PCIDetail.RegistryNumber = _RegistryHeader.RegistryNumber
If _PCIGroup Is Nothing Then
_PCIGroup = New PCIGroup(_uow)
_PCIGroup.CustomersFrom = _uow.GetObjectByKey(Of CustomersFrom)(_CustomersFrom.Oid)
_PCIGroup.Customers = _uow.GetObjectByKey(Of Customers)(_Customers.Oid)
_PCIGroup.PartnerType = _PartnerType
_PCIGroup.ConnectInfo = _ConnectInfo
_PCIGroup.DocumentNumber = _RegistryHeader.DocumentNumber
_PCIGroup.Description = _RegistryHeader.ShortName
_PCIGroup.RegistryHeader = _RegistryHeader
_PCIGroup.CurrencyName = _CurrencyName_Account
_PCIGroup.CurrencyName_Account = _CurrencyName_Account
_PCIGroup.DateCreated_Account = _RegistryHeader.F_DateCreated
_PCIGroup.DateExecution_Account = _DateExecution_Account
_PCIGroup.DatePayment_Account = _RegistryHeader.F_DatePayment
_PCIGroup.Paymode_Account = _RegistryHeader.F_PayMode
_PCIGroup.AmountDEV_Account = _RegistryHeader.F_AmountBruttoDEV
_PCIGroup.AmountHUF_Account = _RegistryHeader.F_AmountBruttoHUF
_PCIGroup.RegistryNumber = _RegistryHeader.RegistryNumber
End If
_PCIDetail.PCIGroup = _PCIGroup
'End If
_PCIDetail.BallanceDEV += _RegistryHeader.F_AmountBruttoDEV
_PCIDetail.BallanceHUF += _RegistryHeader.F_AmountBruttoHUF
_PCIGroup.BallanceDEV += _RegistryHeader.F_AmountBruttoDEV
_PCIGroup.BallanceHUF += _RegistryHeader.F_AmountBruttoHUF
Next
End If
_uow.CommitChanges()
_PCIDetail = Nothing
'II A pénzügyi teljesítések (soronként !)
Dim _GLRows_Collection As New XPCollection(Of GLRows)(PersistentCriteriaEvaluationBehavior.InTransaction, _
_uow, CriteriaOperator.Parse("GLHeader.IsDeleted=False and GLHeader.CustomersFrom.Oid=? and Customer.Oid=? and PartnerType=? and ConnectInfo=? and GLHeader.GLDocumentType in (0,2,3,4,5)", _
_CustomersFrom.Oid, _Customers.Oid, _PartnerType, _ConnectInfo))
For Each _GLRows In _GLRows_Collection
If _GLRows.GLHeader.GLDocumentType = eGLDocumentType.eGLMixed And _GLRows.GLRowsType <> eGLRowsType.eNormal Then
Else
_PCIDetail = New PCIDetail(_uow)
_PCIDetail.GLRows = _GLRows
If _PCIGroup Is Nothing Then
_PCIGroup = New PCIGroup(_uow)
_PCIGroup.CustomersFrom = _uow.GetObjectByKey(Of CustomersFrom)(_CustomersFrom.Oid)
_PCIGroup.Customers = _uow.GetObjectByKey(Of Customers)(_Customers.Oid)
_PCIGroup.PartnerType = _PartnerType
_PCIGroup.ConnectInfo = _ConnectInfo
_PCIGroup.CurrencyName = _GLRows.GLHeader.CurrencyName
_PCIGroup.DateCreated_Account = Nothing
_PCIGroup.CurrencyName_Account = Nothing
_PCIGroup.DateExecution_Account = Nothing
_PCIGroup.DatePayment_Account = Nothing
_PCIGroup.Paymode_Account = ePayMode.NotSet
_PCIGroup.AmountDEV_Account = 0
_PCIGroup.AmountHUF_Account = 0
End If
_PCIDetail.PCIGroup = _PCIGroup
Select Case _GLRows.GLHeader.GLDocumentType
Case eGLDocumentType.eGLMixed
_PCIDetail.MainType = "06-Mixed"
Case eGLDocumentType.eGLBank
_PCIDetail.MainType = "02-Bank"
Case eGLDocumentType.eGLCassa
_PCIDetail.MainType = "03-Cassa"
Case eGLDocumentType.eGLCompensation
_PCIDetail.MainType = "04-Compensation"
Case eGLDocumentType.eGLRateDiff
_PCIDetail.MainType = "05-Ratediff"
Case eGLDocumentType.eLateCharge
_PCIDetail.MainType = "06-Latecharge"
End Select
_PCIDetail.CustomersFrom = _uow.GetObjectByKey(Of CustomersFrom)(_CustomersFrom.Oid)
_PCIDetail.Customers = _uow.GetObjectByKey(Of Customers)(_Customers.Oid)
_PCIDetail.PartnerType = _PartnerType
_PCIDetail.ConnectInfo = _ConnectInfo
_PCIDetail.DocumentNumber = _GLRows.GLHeader.DocumentNumber
_PCIDetail.CurrencyName = _GLRows.GLHeader.CurrencyName
_PCIDetail.DateExecution = _GLRows.GLHeader.DateExecution
_PCIDetail.DateCreated = _GLRows.GLHeader.DateCreated
_PCIDetail.AmountDEV_Account = 0
_PCIDetail.AmountHUF_Account = 0
If _GLRows.LiquidAssets IsNot Nothing Then
_PCIDetail.Description = _GLRows.LiquidAssets.ShortName & ", " & _GLRows.GLHeader.DocumentNumber
Else
_PCIDetail.Description = "<NINCS>, " & _GLRows.GLHeader.DocumentNumber
End If
If _CurrencyName_Account IsNot Nothing Then
_PCIDetail.DateExecution_Account = _DateExecution_Account
_PCIDetail.CurrencyName_Account = _CurrencyName_Account
_PCIDetail.DatePayment_Account = _DatePayment_Account
Select Case _PartnerType
Case ePartnerType.ePayabels
If _GLRows.InAmountHUF <> 0 Then _PCIDetail.BallanceHUF = _GLRows.InAmountHUF
If _GLRows.OutAmountHUF <> 0 Then _PCIDetail.BallanceHUF = _GLRows.OutAmountHUF * -1
If _GLRows.InAmountDEV <> 0 And _GLRows.GLHeader.CurrencyName Is _CurrencyName_Account Then _PCIDetail.BallanceDEV = _GLRows.InAmountDEV
If _GLRows.OutAmountDEV <> 0 And _GLRows.GLHeader.CurrencyName Is _CurrencyName_Account Then _PCIDetail.BallanceDEV = _GLRows.OutAmountDEV * -1
If _GLRows.InAmountDEV2 <> 0 And _GLRows.GLHeader.CurrencyName IsNot _CurrencyName_Account And _CurrencyName_Account.ShortName <> "HUF" Then _PCIDetail.BallanceDEV = _GLRows.InAmountDEV2
If _GLRows.OutAmountDEV2 <> 0 And _GLRows.GLHeader.CurrencyName IsNot _CurrencyName_Account And _CurrencyName_Account.ShortName <> "HUF" Then _PCIDetail.BallanceDEV = _GLRows.OutAmountDEV2 * -1
Case ePartnerType.eReceivables
If _GLRows.InAmountHUF <> 0 Then _PCIDetail.BallanceHUF = _GLRows.InAmountHUF * -1
If _GLRows.OutAmountHUF <> 0 Then _PCIDetail.BallanceHUF = _GLRows.OutAmountHUF
If _GLRows.InAmountDEV <> 0 And _GLRows.GLHeader.CurrencyName Is _CurrencyName_Account Then _PCIDetail.BallanceDEV = _GLRows.InAmountDEV * -1
If _GLRows.OutAmountDEV <> 0 And _GLRows.GLHeader.CurrencyName Is _CurrencyName_Account Then _PCIDetail.BallanceDEV = _GLRows.OutAmountDEV
If _GLRows.InAmountDEV2 <> 0 And _GLRows.GLHeader.CurrencyName IsNot _CurrencyName_Account And _CurrencyName_Account.ShortName <> "HUF" Then _PCIDetail.BallanceDEV = _GLRows.InAmountDEV2 * -1
If _GLRows.OutAmountDEV2 <> 0 And _GLRows.GLHeader.CurrencyName IsNot _CurrencyName_Account And _CurrencyName_Account.ShortName <> "HUF" Then _PCIDetail.BallanceDEV = _GLRows.OutAmountDEV2
End Select
Else
_PCIDetail.DateExecution_Account = Nothing
_PCIDetail.CurrencyName_Account = Nothing
Select Case _PartnerType
Case ePartnerType.ePayabels
If _GLRows.InAmountHUF <> 0 Then _PCIDetail.BallanceHUF = _GLRows.InAmountHUF
If _GLRows.OutAmountHUF <> 0 Then _PCIDetail.BallanceHUF = _GLRows.OutAmountHUF * -1
If _GLRows.InAmountDEV <> 0 Then _PCIDetail.BallanceDEV = _GLRows.InAmountDEV
If _GLRows.OutAmountDEV <> 0 Then _PCIDetail.BallanceDEV = _GLRows.OutAmountDEV * -1
Case ePartnerType.eReceivables
If _GLRows.InAmountHUF <> 0 Then _PCIDetail.BallanceHUF = _GLRows.InAmountHUF * -1
If _GLRows.OutAmountHUF <> 0 Then _PCIDetail.BallanceHUF = _GLRows.OutAmountHUF
If _GLRows.InAmountDEV <> 0 Then _PCIDetail.BallanceDEV = _GLRows.InAmountDEV * -1
If _GLRows.OutAmountDEV <> 0 Then _PCIDetail.BallanceDEV = _GLRows.OutAmountDEV
End Select
End If
_PCIGroup.BallanceDEV += _PCIDetail.BallanceDEV
_PCIGroup.BallanceHUF += _PCIDetail.BallanceHUF
End If
Next
_uow.CommitChanges()
If _PCIGroup IsNot Nothing Then
_PCIDetail_Collection = New XPCollection(Of PCIDetail)(_uow, CriteriaOperator.Parse("PCIGroup.Oid=?", _PCIGroup.Oid))
_PCIDetail_Collection.Sorting.Add(New SortProperty("DateExecution", DB.SortingDirection.Descending))
Dim _IsDateLastConnected As Boolean = False
For Each _PCIDetail In _PCIDetail_Collection
_PCIDetail.BallanceRateDiff = _PCIGroup.BallanceRateDiff
_PCIDetail.BallanceState = _PCIGroup.BallanceState
_PCIDetail.Save()
_uow.CommitChanges()
If _IsDateLastConnected = False Then
Select Case _PCIDetail.MainType
Case "02-Bank", "03-Cassa", "04-Compensation"
_PCIDetail.PCIGroup.DateLastConnected = _PCIDetail.DateExecution
_IsDateLastConnected = True
_uow.CommitChanges()
End Select
End If
Next
If _PCIGroup.InvoiceHeader IsNot Nothing Then
If _PCIGroup.InvoiceHeader.InvoiceHold IsNot Nothing Then
If _PCIGroup.InvoiceHeader.InvoiceHold.Count > 0 Then
If _PCIGroup.CurrencyName_Account.ShortName = "HUF" Then
Dim _InvoiceHold As InvoiceHold
Dim _AmountHUF As Double = _PCIGroup.AmountHUF_Account - _PCIGroup.BallanceHUF
If _AmountHUF > 0 Then
_PCIGroup.InvoiceHeader.InvoiceHold.Sorting.Add(New SortProperty("DatePayment", DB.SortingDirection.Ascending))
For Each _InvoiceHold In _InvoiceHeader.InvoiceHold
_InvoiceHold.BallanceHUF = 0
Next
For Each _InvoiceHold In _InvoiceHeader.InvoiceHold
If _AmountHUF <= _InvoiceHold.AmountHUF Then
_InvoiceHold.BallanceHUF = _AmountHUF
Exit For
Else
_InvoiceHold.BallanceHUF = _InvoiceHold.AmountHUF
_AmountHUF -= _InvoiceHold.AmountHUF
End If
Next
For Each _InvoiceHold In _InvoiceHeader.InvoiceHold
_InvoiceHold.BallanceHUF = _InvoiceHold.AmountHUF - _InvoiceHold.BallanceHUF
Next
End If
Else
End If
End If
End If
End If
_uow.CommitChanges()
If _PCIGroup.RegistryHeader IsNot Nothing Then
If _PCIGroup.RegistryHeader.RegistryBankTransfer IsNot Nothing Then
If _PCIGroup.RegistryHeader.RegistryBankTransfer.Count > 0 Then
If _PCIGroup.CurrencyName_Account.ShortName = "HUF" Then
Dim _RegistryBankTransfer As RegistryBankTransfer
Dim _AmountHUF As Double = _PCIGroup.AmountHUF_Account - _PCIGroup.BallanceHUF
If _AmountHUF > 0 Then
_PCIGroup.RegistryHeader.RegistryBankTransfer.Sorting.Add(New SortProperty("DatePayment", DB.SortingDirection.Ascending))
For Each _RegistryBankTransfer In _PCIGroup.RegistryHeader.RegistryBankTransfer
_RegistryBankTransfer.BallanceHUF = 0
Next
For Each _RegistryBankTransfer In _PCIGroup.RegistryHeader.RegistryBankTransfer
If _AmountHUF <= _RegistryBankTransfer.AmountHUF Then
_RegistryBankTransfer.BallanceHUF = _AmountHUF
Exit For
Else
_RegistryBankTransfer.BallanceHUF = _RegistryBankTransfer.AmountHUF
_AmountHUF -= _RegistryBankTransfer.AmountHUF
End If
Next
For Each _RegistryBankTransfer In _PCIGroup.RegistryHeader.RegistryBankTransfer
_RegistryBankTransfer.BallanceHUF = _RegistryBankTransfer.AmountHUF - _RegistryBankTransfer.BallanceHUF
Next
End If
Else
End If
End If
End If
End If
_uow.CommitChanges()
End If
_uow.CommitChanges()
Catch exp As Exception
Dim _uow_exception As New UnitOfWork(_uow.DataLayer)
Dim _ErrorLog As ErrorLog = New ErrorLog(_uow_exception)
_ErrorLog.Description = exp.Message.ToString
_ErrorLog.Description += Chr(13) + Chr(10) + _ConnectInfo
_ErrorLog.Save()
_uow_exception.CommitChanges()
Finally
End Try
End Sub
Public Sub CorrectPCI(ByVal _uow As UnitOfWork, ByVal _Object As Object)
Dim _AuditDataItemPersistent_Collection As XPCollection(Of AuditDataItemPersistent)
Dim _AuditDataItemPersistent As AuditDataItemPersistent
If TryCast(_Object, RegistryHeader) IsNot Nothing Then
_AuditDataItemPersistent_Collection = AuditedObjectWeakReference.GetAuditTrail(_uow, _Object)
For Each _AuditDataItemPersistent In _AuditDataItemPersistent_Collection
If _AuditDataItemPersistent.PropertyName = "DocumentNumber" Then
End If
Next
End If
End Sub
End Module
Nuvolar.Module/BusinessObjects/SIS/App_Code/GeneralFunction.vb
+481
View File
@@ -0,0 +1,481 @@
Imports System
Imports DevExpress.Xpo
Imports DevExpress.Xpo.DB
Imports DevExpress.Data.Filtering
Imports DevExpress.ExpressApp
Imports System.Linq
Imports System.Linq.Expressions
Imports System.IO
Public Module GeneralFunction
'-- Globális változó !
Public GLOBAL_CustomersFrom_Oid As String
Public GLOBAL_ConnectionString As String
Public GLOBAL_WINFormCaption As String
Public GLOBAL_WEBFormCaption As String
Public GLOBAL_RegistryTask_Current_Oid As Guid
Public GLOBAL_CustomersFrom_String As String = ""
Public GLOBAL_PreviewName As String = ""
Public GLOBAL_PrevievFilter As String = ""
Public GLOBAL_ApplicationStartupPath As String = ""
Public GLOBAL_ApplicationStartupPath_Mail As String = ""
Public GLOBAL_SQLType As eSQLType
Public GLOBAL_HAS_EXPLICIT_TRANSACTION As Boolean = False
Public GLOBAL_EUMemberStates As String() = {"AT", "BE", "BG", "CY", "CZ", "DK", "UK", "EE", "FI", "FR", "GR", "GB", "NL",
"IE", "PL", "LV", "LT", "LU", "HU", "MT", "DE", "IT", "PT", "RO", "ES", "SE", "SK", "SI"}
Public GLOBAL_HAS_Audit As Boolean = True
Public GLOBAL_MainModuleVersion As String = ""
'winApplication_LastLogonParametersWriting'
Public GLOBAL_SQLServer As String = ""
Public GLOBAL_SQLUser As String = ""
Public GLOBAL_SQLDatabase As String = ""
Public GLOBAL_SQLPassword As String = ""
Public GLOBAL_Company As String = ""
Public GLOBAL_Plattform As String = ""
Public GLOBAL_Company_Info As String = ""
Public GLOBAL_ActivityID As String = ""
Public GLOBAL_Download_MemoryStream As MemoryStream
Public GLOBAL_Download_FileName As String
Public GLOBAL_Download_FileExtension As String
'Dashboard
Public GLOBAL_DASHBOARD_XML_DashboardXmlFile As String = ""
Public GLOBAL_DASHBOARD_XML_ServerName As String = ""
Public GLOBAL_DASHBOARD_XML_UserName As String = ""
Public GLOBAL_DASHBOARD_XML_DatabaseName As String = ""
Public GLOBAL_DASHBOARD_XML_Password As String = ""
Public GLOBAL_DASHBOARD_XML_SQLType As String = ""
Public GLOBAL_ListViewReset As Boolean = False
Enum eDirection
Left = 0
Right = 1
End Enum
Public Function GetConnectionGLOBAL() As String
Dim connstr As String = ""
Select Case UCase(GLOBAL_Company)
Case "FR (MICROSERVER2008)"
GLOBAL_SQLUser = "root"
GLOBAL_SQLPassword = "pcl718"
GLOBAL_SQLType = eSQLType.MySQL
GLOBAL_SQLServer = "MICROSERVER2008"
GLOBAL_SQLDatabase = "frinput"
GLOBAL_Company_Info = "Franciska Kft : MICROSERVER2008, FRINPUT"
GLOBAL_Plattform = "MySQL"
connstr = DevExpress.Xpo.DB.MySqlConnectionProvider.GetConnectionString(GLOBAL_SQLServer, GLOBAL_SQLUser, GLOBAL_SQLPassword, GLOBAL_SQLDatabase)
Case "MC LOCAL", "MC (LOCAL)"
GLOBAL_SQLUser = "sa"
GLOBAL_SQLPassword = "pcl718"
GLOBAL_SQLType = eSQLType.MSSQL
GLOBAL_SQLServer = "SISI5SSD2\SQLExpress"
GLOBAL_SQLDatabase = "MC"
GLOBAL_Company_Info = "Mol-Control Kft. TESZT adatbázis : SISI5SSD2\SQLExpress, MC"
GLOBAL_Plattform = "MS SQL"
connstr = DevExpress.Xpo.DB.MSSqlConnectionProvider.GetConnectionString(GLOBAL_SQLServer, GLOBAL_SQLUser, GLOBAL_SQLPassword, GLOBAL_SQLDatabase)
Case "MC OFFICE TEST"
GLOBAL_SQLUser = "sa"
GLOBAL_SQLPassword = "pcl718"
GLOBAL_SQLType = eSQLType.MSSQL
GLOBAL_SQLServer = "192.168.6.9"
GLOBAL_SQLDatabase = "Nuvolar_TEST"
GLOBAL_Company_Info = "Mol-Control Kft. TESZT adatbázis : 192.168.6.9, Nuvolar_TEST"
GLOBAL_Plattform = "MS SQL"
connstr = DevExpress.Xpo.DB.MSSqlConnectionProvider.GetConnectionString(GLOBAL_SQLServer, GLOBAL_SQLUser, GLOBAL_SQLPassword, GLOBAL_SQLDatabase)
Case "MC REMOTE", "MC (REMOTE)", "MC"
GLOBAL_SQLUser = "sa"
GLOBAL_SQLPassword = "pcl718"
GLOBAL_SQLType = eSQLType.MSSQL
GLOBAL_SQLServer = "78.131.7.14"
GLOBAL_SQLDatabase = "Nuvolar"
GLOBAL_Company_Info = "Mol-Control Kft. adatbázis : 78.131.7.14, MC"
GLOBAL_Plattform = "MS SQL"
connstr = DevExpress.Xpo.DB.MSSqlConnectionProvider.GetConnectionString(GLOBAL_SQLServer, GLOBAL_SQLUser, GLOBAL_SQLPassword, GLOBAL_SQLDatabase)
Case "SISTEST (LOCAL)", "SISTEST LOCAL"
GLOBAL_SQLUser = "sa"
GLOBAL_SQLPassword = "pcl718"
GLOBAL_SQLType = eSQLType.MSSQL
GLOBAL_SQLServer = "SISI5SSD2\SQLExpress"
GLOBAL_SQLDatabase = "SISTEST"
GLOBAL_Company_Info = "TESZT adatbázis : SISI5SSD2\SQLExpress, SISTEST"
GLOBAL_Plattform = "MS SQL"
connstr = DevExpress.Xpo.DB.MSSqlConnectionProvider.GetConnectionString(GLOBAL_SQLServer, GLOBAL_SQLUser, GLOBAL_SQLPassword, GLOBAL_SQLDatabase)
Case "PH (REMOTE)", "PH REMOTE", "PH"
GLOBAL_SQLUser = "sisuser"
GLOBAL_SQLPassword = "pcl718"
GLOBAL_SQLType = eSQLType.MSSQL
GLOBAL_SQLServer = "iroda.pestihazak.hu "
GLOBAL_SQLDatabase = "Nuvolar"
GLOBAL_Company_Info = "Pesti Házak : iroda.pestihazak.hu, Nuvolar"
GLOBAL_Plattform = "MS SQL"
connstr = DevExpress.Xpo.DB.MSSqlConnectionProvider.GetConnectionString(GLOBAL_SQLServer, GLOBAL_SQLUser, GLOBAL_SQLPassword, GLOBAL_SQLDatabase)
Case "SISTEST"
GLOBAL_SQLUser = "sa"
GLOBAL_SQLPassword = "pcl718"
GLOBAL_SQLType = eSQLType.MSSQL
GLOBAL_SQLServer = "DATACENTER\SIS"
GLOBAL_SQLDatabase = "SISTEST"
GLOBAL_Company_Info = "SISTEST adatbázis : DATACENTER\SIS, SISTEST"
GLOBAL_Plattform = "MS SQL"
connstr = DevExpress.Xpo.DB.MSSqlConnectionProvider.GetConnectionString(GLOBAL_SQLServer, GLOBAL_SQLUser, GLOBAL_SQLPassword, GLOBAL_SQLDatabase)
Case "FRANCISKA (LOCAL)", "FRANCISKA LOCAL"
GLOBAL_SQLUser = "root"
GLOBAL_SQLPassword = "pcl718"
GLOBAL_SQLType = eSQLType.MySQL
GLOBAL_SQLServer = "frserver"
GLOBAL_SQLDatabase = "frinput"
GLOBAL_Company_Info = "Franciska Input Kft : FRSERVER, FRINPUT"
GLOBAL_Plattform = "MySQL"
connstr = DevExpress.Xpo.DB.MySqlConnectionProvider.GetConnectionString(GLOBAL_SQLServer, GLOBAL_SQLUser, GLOBAL_SQLPassword, GLOBAL_SQLDatabase)
Case "FRANCISKA (REMOTE)", "FRANCISKA REMOTE", "FR"
GLOBAL_SQLUser = "root"
GLOBAL_SQLPassword = "pcl718"
GLOBAL_SQLType = eSQLType.MySQL
GLOBAL_SQLServer = "91.137.135.109"
GLOBAL_SQLDatabase = "frinput"
GLOBAL_Company_Info = "Franciska Input Kft : 91.137.135.109, FRINPUT"
GLOBAL_Plattform = "MySQL"
connstr = DevExpress.Xpo.DB.MySqlConnectionProvider.GetConnectionString(GLOBAL_SQLServer, GLOBAL_SQLUser, GLOBAL_SQLPassword, GLOBAL_SQLDatabase)
Case "BATIMPUT (REMOTE)", "BATINPUT REMOTE", "BI"
GLOBAL_SQLUser = "root"
GLOBAL_SQLPassword = "pcl718"
GLOBAL_SQLType = eSQLType.MySQL
GLOBAL_SQLServer = "91.137.135.109"
GLOBAL_SQLDatabase = "batinput"
GLOBAL_Company_Info = "Bát Input Kft : 91.137.135.109, BATINPUT"
GLOBAL_Plattform = "MySQL"
connstr = DevExpress.Xpo.DB.MySqlConnectionProvider.GetConnectionString(GLOBAL_SQLServer, GLOBAL_SQLUser, GLOBAL_SQLPassword, GLOBAL_SQLDatabase)
Case "FR DB01"
GLOBAL_SQLUser = "root"
GLOBAL_SQLPassword = "pcl718"
GLOBAL_SQLType = eSQLType.MySQL
GLOBAL_SQLServer = "91.137.135.109"
GLOBAL_SQLDatabase = "db01"
GLOBAL_Company_Info = "Franciska Input Kft : 91.137.135.109, db01"
GLOBAL_Plattform = "MySQL"
connstr = DevExpress.Xpo.DB.MySqlConnectionProvider.GetConnectionString(GLOBAL_SQLServer, GLOBAL_SQLUser, GLOBAL_SQLPassword, GLOBAL_SQLDatabase)
End Select
Return connstr
End Function
Public Function AlignStr(ByVal s As String, ByVal Direction As eDirection, ByVal AlignChar As String, ByVal MaxLen As Integer) As String
Dim I As Integer
Dim J As Long
Dim seged As String = ""
Dim _AlignStr As String = ""
If AlignChar = "" Then AlignChar = " "
If MaxLen > Len(s) Then
I = MaxLen - Len(s)
For J = 1 To I
seged += AlignChar
Next
Select Case Direction
Case eDirection.Left : _AlignStr = seged & s
Case eDirection.Right : _AlignStr = s & seged
End Select
Return _AlignStr
Else
Return Mid(s, 1, MaxLen)
End If
End Function
Public Function GetSQLTime(ByVal session As Session) As Date
Try
Dim funcNow As CriteriaOperator = New FunctionOperator(FunctionOperatorType.Now)
Dim serverTime As Date = session.Evaluate(Of XPObjectType)(funcNow, Nothing)
Return serverTime
Catch
Return Now
End Try
End Function
Public Function Change3Value(ByVal s As String) As String
Dim EStr(4) As String
Select Case Mid(s, 3, 1)
Case "0" : EStr(3) = ""
Case "1" : EStr(3) = "egy"
Case "2" : EStr(3) = "kettő"
Case "3" : EStr(3) = "három"
Case "4" : EStr(3) = "négy"
Case "5" : EStr(3) = "öt"
Case "6" : EStr(3) = "hat"
Case "7" : EStr(3) = "hét"
Case "8" : EStr(3) = "nyolc"
Case "9" : EStr(3) = "kilenc"
End Select
Select Case Mid(s, 2, 1)
Case "0" : EStr(2) = ""
Case "1"
If EStr(3) = "" Then
EStr(2) = "tíz"
Else
EStr(2) = "tizen"
End If
Case "2"
If EStr(3) = "" Then
EStr(2) = "húsz"
Else
EStr(2) = "huszon"
End If
Case "3" : EStr(2) = "harminc"
Case "4" : EStr(2) = "negyven"
Case "5" : EStr(2) = "ötven"
Case "6" : EStr(2) = "hatvan"
Case "7" : EStr(2) = "hetven"
Case "8" : EStr(2) = "nyolcvan"
Case "9" : EStr(2) = "kilencven"
End Select
Select Case Mid(s, 1, 1)
Case "0" : EStr(1) = ""
Case "1" : EStr(1) = "száz"
Case "2" : EStr(1) = "kettőszáz"
Case "3" : EStr(1) = "háromszáz"
Case "4" : EStr(1) = "négyszáz"
Case "5" : EStr(1) = "ötszáz"
Case "6" : EStr(1) = "hatszáz"
Case "7" : EStr(1) = "hétszáz"
Case "8" : EStr(1) = "nyolcszáz"
Case "9" : EStr(1) = "kilencszáz"
End Select
Return UCase$(EStr(1) & EStr(2) & EStr(3))
End Function
Public Function GetHUNumberToText(ByVal l As Double) As String
Dim SzámSzöveg As String
Dim seged As String
Dim VégStr As String
l = Math.Round(Math.Abs(l), 2, MidpointRounding.AwayFromZero)
VégStr = ""
SzámSzöveg = Format(l, "000000000000.0")
seged = Mid(SzámSzöveg, 1, 3)
seged = Change3Value(seged)
If seged <> "" Then
VégStr = VégStr & seged & "milliárd "
Else
VégStr = VégStr & ""
End If
seged = Mid(SzámSzöveg, 4, 3)
seged = Change3Value(seged)
If seged <> "" Then
VégStr = VégStr & seged & "millió "
Else
VégStr = VégStr & ""
End If
seged = Mid(SzámSzöveg, 7, 3)
seged = Change3Value(seged)
If seged <> "" Then
VégStr = VégStr & seged & "ezer "
Else
VégStr = VégStr & ""
End If
seged = Mid(SzámSzöveg, 10, 3)
seged = Change3Value(seged)
VégStr = VégStr & seged
seged = Mid(SzámSzöveg, 14, 1)
VégStr = VégStr & " " & seged & "0/100"
Return UCase$(VégStr)
End Function
Public Function LastDayOfYear(ByVal d As DateTime) As DateTime
Dim time As New DateTime((d.Year + 1), 1, 1)
Return time.AddDays(-1)
End Function
Public Function FirstDayOfYear(ByVal y As DateTime) As DateTime
Return New DateTime(y.Year, 1, 1)
End Function
Public Function CorrectFileName(_FileName As String) As String
Dim _FileName_Good As String = ""
Dim _s As String = ""
Dim _i As Long = 0
For i = 1 To Len(_FileName)
_s = Mid(_FileName, i, 1)
Select Case _s
Case "/", "'", ":", ",", ">", "<"
_FileName_Good += "_"
Case Else
_FileName_Good += _s
End Select
Next
Return _FileName_Good
End Function
Public Function SQLNum(_NumberText As String) As String
Dim _decimalSeparator As String = Globalization.CultureInfo.CurrentCulture.NumberFormat.NumberDecimalSeparator
Dim _groupSeparator As String = Globalization.CultureInfo.CurrentCulture.NumberFormat.NumberGroupSeparator
Return Replace(Replace(_NumberText, _groupSeparator, ""), _decimalSeparator, ".")
End Function
'-- Hiba kezelés
Public Function ThrowNewException(_p_Message As String) As Boolean
MsgBox(_p_Message, MsgBoxStyle.Critical, "Nuvolar Framework 20.")
Return True
End Function
Public Function GenerateDateCollection(_StartDate As Date, _StopDate As Date, Optional _Week As Boolean = False) As ArrayList
Dim _DateArray As New ArrayList
If _Week Then
Dim _WeekCount As Integer = DateDiff(DateInterval.WeekOfYear, _StartDate, _StopDate)
Dim _DayOfWeek As Integer = _StartDate.DayOfWeek
If _DayOfWeek <> 0 Then
_DateArray.Add(New Date(_StartDate.Year, _StartDate.Month, _StartDate.Day + (7 - _DayOfWeek)))
Else
_DateArray.Add(New Date(_StartDate.Year, _StartDate.Month, _StartDate.Day + 7))
End If
For ik = 1 To _WeekCount
_DateArray.Add((New Date(CType(_DateArray(ik - 1), Date).Year, CType(_DateArray(ik - 1), Date).Month, CType(_DateArray(ik - 1), Date).Day).AddDays(7)))
Next
Else
Dim _MountCount As Integer = DateDiff(DateInterval.Month, _StartDate, _StopDate)
For ik = 1 To _MountCount + 1
_DateArray.Add((New Date(_StartDate.Year, _StartDate.Month, 1).AddMonths(ik)).AddDays(-1))
Next
End If
Return _DateArray
End Function
'//Raktárkezelés
Public Sub CheckInventoryTransferStorageInRows(_uow As UnitOfWork, _StorageInRows_Collection_Base As XPCollection(Of StorageInRows))
Dim _SQL As String = ""
Dim _StorageInRows_Base As StorageInRows
For Each _StorageInRows_Base In _StorageInRows_Collection_Base
If _SQL = "" Then
_SQL = " Oid in ('" & _StorageInRows_Base.Oid.ToString & "'"
Else
_SQL += ",'" & _StorageInRows_Base.Oid.ToString & "'"
End If
Next
If _SQL <> "" Then
_SQL += ")"
Else
Exit Sub
End If
Select Case GLOBAL_SQLType
Case eSQLType.MSSQL, eSQLType.MySQL
_uow.ExecuteNonQuery("update StorageInRows set QTT_Overstor=0,QTT_Overstor_Will=0,QTT_Overstored=0,QTT_Overstored_Will=0 Where " & _SQL)
Case eSQLType.PostgreSQL
_SQL = Replace(_SQL, "Oid", """Oid""")
_uow.ExecuteNonQuery("update ""StorageInRows"" set ""QTT_Overstor""=0,""QTT_Overstor_Will""=0,""QTT_Overstored""=0,""QTT_Overstored_Will""=0 Where " & _SQL)
End Select
For Each _StorageInRows_Base In _StorageInRows_Collection_Base
Dim _StorageOutRowsInRows_XPQuery As New XPQuery(Of StorageOutRowsInRows)(_uow)
Dim query = From _StorageOutRowsInRows In _StorageOutRowsInRows_XPQuery
Where _StorageOutRowsInRows.StorageOutRows.StorageOutHeader.StorageMoveType.MoveType = eMoveType.InventoryTransfer And
_StorageOutRowsInRows.StorageOutRows.StorageOutHeader.IsEditable = False And
String.IsNullOrEmpty(_StorageOutRowsInRows.StorageOutRows.StorageOutHeader.DocumentNumber) = False And
_StorageOutRowsInRows.StorageOutRows.StorageOutHeader IsNot Nothing And
_StorageOutRowsInRows.StorageInRows.Oid = _StorageInRows_Base.Oid
Group _StorageOutRowsInRows By _StorageOutRowsInRows.StorageInRows.Oid Into g = Group
Select New With {.StorageInRows = Oid,
.QTT_Sum = g.Sum(Function(inv) inv.QTT)}
For Each item In query
Dim _StorageInRows As StorageInRows = _uow.FindObject(Of StorageInRows)(CriteriaOperator.Parse("Oid=?", item.StorageInRows.ToString))
If _StorageInRows IsNot Nothing Then
_StorageInRows.QTT_Overstor = item.QTT_Sum
_uow.CommitChanges()
End If
Next
query = From _StorageOutRowsInRows In _StorageOutRowsInRows_XPQuery
Where _StorageOutRowsInRows.StorageOutRows.StorageOutHeader.StorageMoveType.MoveType = eMoveType.InventoryTransfer And
_StorageOutRowsInRows.StorageOutRows.StorageOutHeader.IsEditable = True And
_StorageOutRowsInRows.StorageOutRows.StorageOutHeader IsNot Nothing And
_StorageOutRowsInRows.StorageInRows.Oid = _StorageInRows_Base.Oid
Group _StorageOutRowsInRows By _StorageOutRowsInRows.StorageInRows.Oid Into g = Group
Select New With {.StorageInRows = Oid,
.QTT_Sum = g.Sum(Function(inv) inv.QTT_Will)}
For Each item In query
Dim _StorageInRows As StorageInRows = _uow.FindObject(Of StorageInRows)(CriteriaOperator.Parse("Oid=?", item.StorageInRows.ToString))
If _StorageInRows IsNot Nothing Then
_StorageInRows.QTT_Overstor_Will = item.QTT_Sum
_uow.CommitChanges()
End If
Next
'__Overstored renberakása
Dim _StorageInRows_XPQuery As New XPQuery(Of StorageInRows)(_uow)
Dim query1 = From _StorageInRows In _StorageInRows_XPQuery
Where _StorageInRows.StorageInHeader IsNot Nothing And
String.IsNullOrEmpty(_StorageInRows.StorageInHeader.DocumentNumber) = False AndAlso
_StorageInRows.StorageInHeader.StorageMoveType.MoveType = eMoveType.InventoryTransfer And
_StorageInRows.StorageInHeader.IsEditable = False And
_StorageInRows.StorageInRowsFrom.Oid = _StorageInRows_Base.Oid
Group _StorageInRows By _StorageInRows.StorageInRowsFrom.Oid Into g = Group
Select New With {.StorageInRows = Oid,
.QTT_Sum = g.Sum(Function(inv) inv.QTT)}
For Each item In query1
Dim _StorageInRows As StorageInRows = _uow.FindObject(Of StorageInRows)(CriteriaOperator.Parse("Oid=?", item.StorageInRows.ToString))
If _StorageInRows IsNot Nothing Then
_StorageInRows.QTT_Overstored = item.QTT_Sum
_uow.CommitChanges()
End If
Next
query1 = From _StorageInRows In _StorageInRows_XPQuery
Where _StorageInRows.StorageInHeader IsNot Nothing And
String.IsNullOrEmpty(_StorageInRows.StorageInHeader.DocumentNumber) = False AndAlso
_StorageInRows.StorageInHeader.StorageMoveType.MoveType = eMoveType.InventoryTransfer And
_StorageInRows.StorageInHeader.IsEditable = True And
_StorageInRows.StorageInRowsFrom.Oid = _StorageInRows_Base.Oid
Group _StorageInRows By _StorageInRows.StorageInRowsFrom.Oid Into g = Group
Select New With {.StorageInRows = Oid,
.QTT_Sum = g.Sum(Function(inv) inv.QTT_Will)}
For Each item In query1
Dim _StorageInRows As StorageInRows = _uow.FindObject(Of StorageInRows)(CriteriaOperator.Parse("Oid=?", item.StorageInRows.ToString))
If _StorageInRows IsNot Nothing Then
_StorageInRows.QTT_Overstored_Will = item.QTT_Sum
_uow.CommitChanges()
End If
Next
Next
End Sub
Function EAN13Generator(ByVal _Base As String) As String
If _Base.Length = 12 Then
Dim i As Long
Dim _CheckSum As Long = 0
For i = 1 To Len(_Base)
If i Mod 2 = 0 Then
_CheckSum += Val(Mid(_Base, i, 1)) * 3
Else
_CheckSum += Val(Mid(_Base, i, 1))
End If
Next
_CheckSum = 10 - (_CheckSum Mod 10)
If _CheckSum = 10 Then _CheckSum = 0
Return _Base & LTrim(RTrim(CStr(_CheckSum)))
Else
Return ""
End If
End Function
End Module
Nuvolar.Module/BusinessObjects/SIS/App_Code/HTMLModule.vb
+223
View File
@@ -0,0 +1,223 @@
Imports DevExpress.Xpo
Imports DevExpress.Data.Filtering
Imports DevExpress.ExpressApp.Utils
Module HTMLModule
Public Function CreateHTMLEvents(_Question As Question, _Session As DevExpress.Xpo.Session) As String
Dim _Events_Collection As New XPCollection(Of Events)(PersistentCriteriaEvaluationBehavior.InTransaction, _
_Session, CriteriaOperator.Parse("Question.Oid=?", _Question.Oid))
Dim _Events As Events
Dim s As String = ""
's = " <style> "
's += " * { font-family: Arial; }"
's += " h1 { color: #8080a0; font-weight: normal; padding: 0px; margin: 5px 0px; }"
's += " p { padding: 0px; margin: 3px 0px; color: #808080; }"
's += " </style> "
If _Events_Collection IsNot Nothing Then
_Events_Collection.Sorting.Add(New SortProperty("ObjectCreated", DB.SortingDirection.Ascending))
For Each _Events In _Events_Collection
If _Events.EventDirection = eEventDirection.eIn Then
s += "<table cellspacing='0' cellpadding='0' border='0' width=100% style='background-color:&&ECDEEC;'>"
s += "<tr>"
s += "<td style='width:10px;border-top:solid 1px;border-bottom:solid 1px;background-color:&&ECDEEC;color:&&866A86;"
s += " font-size:small;'>"
s += "</td>"
s += "<td style='background-color:&&ECDEEC;color:&&866A86;vertical-align:center;width:25px;height:30px;"
s += " border-top:solid 1px;border-bottom:solid 1px;"
s += "'>"
s += "<img id='1' alt='<-' src='" & GLOBAL_ApplicationStartupPath & "Images\iRedArrow.png' style='height:22px;width:21px;border-style:none;'/>"
s += "</td>"
s += "<td style='background-color:&&ECDEEC;color:&&866A86;vertical-align:center;"
s += " border-top:solid 1px;border-bottom:solid 1px;"
s += "'>"
s += _Events.UserCreated.LastName & " " & _Events.UserCreated.FirstName & " írta (" & CaptionHelper.GetLocalizedText("Enums\Nuvolar.Module.eQuestionStatus", _Events.QuestionStatus.ToString) & ")"
s += "</td>"
s += "<td style='background-color:&&ECDEEC;color:&&866A86;vertical-align:center;text-align:right;"
s += " border-top:solid 1px;border-bottom:solid 1px;font-size:small;"
s += "'>"
s += Format(_Events.ObjectCreated, "yyyy/MM/dd HH:mm")
s += "</td>"
s += "<td style='width:5px;border-top:solid 1px;border-bottom:solid 1px;background-color:&&ECDEEC;color:&&866A86;"
s += " font-size:small;'>"
s += "</td>"
s += "</tr>"
s += "</table><br>"
s += "<table cellspacing='0' cellpadding='0' border='0' width=100%>"
s += "<tr>"
s += "<td style='width:25px;'></td>"
s += "<td>"
If _Events.Attachment IsNot Nothing Then
s += "<span id='100'><b>Csatolmány:</b> <a href='GetAttachments.ashx?id=" & _Events.Attachment.Oid.ToString & "' target='_blank'>" & _Events.Attachment.FileName & "</a> (" & _Events.Attachment.Size & " bytes)</span><br><br>"
End If
s += _Events.Description
s += "</td>"
s += "</tr>"
s += "</table>"
s += "<br><br>"
End If
If _Events.EventDirection = eEventDirection.eOut Then
s += "<table cellspacing='0' cellpadding='0' border='0' width=100% style='background-color:&&E1F7EC;'>"
s += "<tr>"
s += "<td style='width:10px;border-top:solid 1px;border-bottom:solid 1px;background-color:&&E1F7EC;color:&&83968D;"
s += " font-size:small;'>"
s += "</td>"
s += "<td style='background-color:&&E1F7EC;color:&&83968D;vertical-align:center;width:25px;height:30px;"
s += " border-top:solid 1px;border-bottom:solid 1px;"
s += "'>"
s += "<img id='1' alt='->' src='" & GLOBAL_ApplicationStartupPath & "Images\iGreenArrow.png' style='height:22px;width:21px;border-style:none;'/>"
s += "</td>"
s += "<td style='background-color:&&E1F7EC;color:&&83968D;vertical-align:center;"
s += " border-top:solid 1px;border-bottom:solid 1px;"
s += "'>"
s += _Events.UserCreated.LastName & " " & _Events.UserCreated.FirstName & " válaszolta (" & CaptionHelper.GetLocalizedText("Enums\Nuvolar.Module.eQuestionStatus", _Events.QuestionStatus.ToString) & ")"
s += "</td>"
s += "<td style='background-color:&&E1F7EC;color:&&83968D;vertical-align:center;text-align:right;"
s += " border-top:solid 1px;border-bottom:solid 1px;font-size:small;"
s += "'>"
s += Format(_Events.ObjectCreated, "yyyy/MM/dd HH:mm")
s += "</td>"
s += "<td style='width:5px;border-top:solid 1px;border-bottom:solid 1px;background-color:&&E1F7EC;color:&&83968D;"
s += " font-size:small;'>"
s += "</td>"
s += "</tr>"
s += "</table><br>"
s += "<table cellspacing='0' cellpadding='0' border='0' width=100%>"
s += "<tr>"
If LTrim(RTrim(_Events.Description)) <> "" Then
s += "<td style='width:25px;'></td>"
s += "<td>"
If _Events.Attachment IsNot Nothing Then
s += "<span id='100'><b>Csatolmány:</b> <a href='GetAttachments.ashx?id=" & _Events.Attachment.Oid.ToString & "' target='_blank'>" & _Events.Attachment.FileName & "</a> (" & _Events.Attachment.Size & " bytes)</span><br><br>"
End If
s += _Events.Description
s += "</td>"
s += "</tr>"
s += "</table>"
s += "<br><br>"
End If
End If
Next
End If
s = Replace(s, "'", """")
s = Replace(s, "&&", "#")
Return s
End Function
Public Function CreateHTMLEventsMail(_Question As Question, _Session As DevExpress.Xpo.Session) As String
Dim _Events_Collection As New XPCollection(Of Events)(PersistentCriteriaEvaluationBehavior.InTransaction, _
_Session, CriteriaOperator.Parse("Question.Oid=?", _Question.Oid))
Dim _Events As Events
Dim s As String = ""
's = " <style> "
's += " * { font-family: Arial; }"
's += " h1 { color: #8080a0; font-weight: normal; padding: 0px; margin: 5px 0px; }"
's += " p { padding: 0px; margin: 3px 0px; color: #808080; }"
's += " </style> "
If _Events_Collection IsNot Nothing Then
_Events_Collection.Sorting.Add(New SortProperty("ObjectCreated", DB.SortingDirection.Ascending))
For Each _Events In _Events_Collection
If _Events.EventDirection = eEventDirection.eIn Then
s += "<table cellspacing='0' cellpadding='0' border='0' width=100% style='background-color:&&ECDEEC;'>"
s += "<tr>"
s += "<td style='width:10px;border-top:solid 1px;border-bottom:solid 1px;background-color:&&ECDEEC;color:&&866A86;"
s += " font-size:small;'>"
s += "</td>"
s += "<td style='background-color:&&ECDEEC;color:&&866A86;vertical-align:center;width:25px;height:30px;"
s += " border-top:solid 1px;border-bottom:solid 1px;"
s += "'>"
s += "<img id='1' alt='<-' <img src='cid:c001' style='height:22px;width:21px;border-style:none;'/>"
s += "</td>"
s += "<td style='background-color:&&ECDEEC;color:&&866A86;vertical-align:center;"
s += " border-top:solid 1px;border-bottom:solid 1px;"
s += "'>"
s += _Events.UserCreated.LastName & " " & _Events.UserCreated.FirstName & " írta (" & CaptionHelper.GetLocalizedText("Enums\Nuvolar.Module.eQuestionStatus", _Events.QuestionStatus.ToString) & ")"
s += "</td>"
s += "<td style='background-color:&&ECDEEC;color:&&866A86;vertical-align:center;text-align:right;"
s += " border-top:solid 1px;border-bottom:solid 1px;font-size:small;"
s += "'>"
s += Format(_Events.ObjectCreated, "yyyy/MM/dd HH:mm")
s += "</td>"
s += "<td style='width:5px;border-top:solid 1px;border-bottom:solid 1px;background-color:&&ECDEEC;color:&&866A86;"
s += " font-size:small;'>"
s += "</td>"
s += "</tr>"
s += "</table><br>"
s += "<table cellspacing='0' cellpadding='0' border='0' width=100%>"
s += "<tr>"
s += "<td style='width:25px;'></td>"
s += "<td>"
s += _Events.Description
s += "</td>"
s += "</tr>"
s += "</table>"
s += "<br><br>"
End If
If _Events.EventDirection = eEventDirection.eOut Then
s += "<table cellspacing='0' cellpadding='0' border='0' width=100% style='background-color:&&E1F7EC;'>"
s += "<tr>"
s += "<td style='width:10px;border-top:solid 1px;border-bottom:solid 1px;background-color:&&E1F7EC;color:&&83968D;"
s += " font-size:small;'>"
s += "</td>"
s += "<td style='background-color:&&E1F7EC;color:&&83968D;vertical-align:center;width:25px;height:30px;"
s += " border-top:solid 1px;border-bottom:solid 1px;"
s += "'>"
s += "<img id='1' alt='->' src='cid:c002' style='height:22px;width:21px;border-style:none;'/>"
s += "</td>"
s += "<td style='background-color:&&E1F7EC;color:&&83968D;vertical-align:center;"
s += " border-top:solid 1px;border-bottom:solid 1px;"
s += "'>"
s += _Events.UserCreated.LastName & " " & _Events.UserCreated.FirstName & " válaszolta (" & CaptionHelper.GetLocalizedText("Enums\Nuvolar.Module.eQuestionStatus", _Events.QuestionStatus.ToString) & ")"
s += "</td>"
s += "<td style='background-color:&&E1F7EC;color:&&83968D;vertical-align:center;text-align:right;"
s += " border-top:solid 1px;border-bottom:solid 1px;font-size:small;"
s += "'>"
s += Format(_Events.ObjectCreated, "yyyy/MM/dd HH:mm")
s += "</td>"
s += "<td style='width:5px;border-top:solid 1px;border-bottom:solid 1px;background-color:&&E1F7EC;color:&&83968D;"
s += " font-size:small;'>"
s += "</td>"
s += "</tr>"
s += "</table><br>"
s += "<table cellspacing='0' cellpadding='0' border='0' width=100%>"
s += "<tr>"
If LTrim(RTrim(_Events.Description)) <> "" Then
s += "<td style='width:25px;'></td>"
s += "<td>"
s += _Events.Description
s += "</td>"
s += "</tr>"
s += "</table>"
s += "<br><br>"
End If
End If
Next
End If
s = Replace(s, "'", """")
s = Replace(s, "&&", "#")
Return s
End Function
End Module
Nuvolar.Module/BusinessObjects/SIS/App_Code/SISEmail.vb
+372
View File
@@ -0,0 +1,372 @@
Imports System.Net
Imports System.Net.Sockets
Imports System.IO
Imports System.Net.Mail
Imports DevExpress.Xpo
Public Class SISPOP3Base
' variables for pop3 class
Public pop3host As [String]
Public port As Integer
Public user As [String]
Public pwd As [String]
Public command As [String]
Public w_TcpClient As TcpClient
Public w_NetStream As NetworkStream
Public w_ReadStream As StreamReader
Public bData As Byte()
'for the data, tat we'll recive
Public Function DoConnect(pop3host As [String], port As Integer, user As [String], pwd As [String]) As String
' create POP3 connection
w_TcpClient = New TcpClient(pop3host, port)
Try
' initialization
w_NetStream = w_TcpClient.GetStream()
w_ReadStream = New StreamReader(w_TcpClient.GetStream())
w_ReadStream.ReadLine()
' send login
command = "USER " & user & vbCr & vbLf
bData = System.Text.Encoding.ASCII.GetBytes(command.ToCharArray())
w_NetStream.Write(bData, 0, bData.Length)
w_ReadStream.ReadLine()
' send pwd
command = "PASS " & pwd & vbCr & vbLf
bData = System.Text.Encoding.ASCII.GetBytes(command.ToCharArray())
w_NetStream.Write(bData, 0, bData.Length)
w_ReadStream.ReadLine()
Catch err As InvalidOperationException
Return ("Error: " & err.ToString())
End Try
Return "+OK"
End Function
Public Function GetStat() As String
' Send STAT command to get number of mail and total size
command = "STAT" & vbCr & vbLf
bData = System.Text.Encoding.ASCII.GetBytes(command.ToCharArray())
w_NetStream.Write(bData, 0, bData.Length)
Return w_ReadStream.ReadLine()
End Function
Public Function GetList() As String
' Send LIST command with no parametrs to get all information
Dim sTemp As String
' For saving 'list' results
Dim sList As String = ""
command = "LIST" & vbCr & vbLf
bData = System.Text.Encoding.ASCII.GetBytes(command.ToCharArray())
w_NetStream.Write(bData, 0, bData.Length)
sTemp = w_ReadStream.ReadLine()
If sTemp(0) <> "-"c Then
' errors begins with '-'
While sTemp <> "."
'saving data to string while not found '.'
sList += sTemp & vbCr & vbLf
sTemp = w_ReadStream.ReadLine()
End While
Else
Return sTemp
End If
Return sList
End Function
Public Function GetList(num As Integer) As String
' Send LIST command with number of a letter
command = "LIST " & num & vbCr & vbLf
bData = System.Text.Encoding.ASCII.GetBytes(command.ToCharArray())
w_NetStream.Write(bData, 0, bData.Length)
Return w_ReadStream.ReadLine()
End Function
Public Function Retr(num As Integer) As String
Dim sTemp As String
Dim sBody As String = ""
Try
command = "RETR " & num & vbCr & vbLf
bData = System.Text.Encoding.ASCII.GetBytes(command.ToCharArray())
w_NetStream.Write(bData, 0, bData.Length)
sTemp = w_ReadStream.ReadLine()
If sTemp(0) <> "-"c Then
'errors begins with -
While sTemp <> "."
' . - is the end of the server response
sBody += sTemp & vbCr & vbLf
sTemp = w_ReadStream.ReadLine()
End While
Else
Return sTemp
End If
Catch err As InvalidOperationException
Return ("Error: " & err.ToString())
End Try
Return sBody
End Function
Public Function Dele(num As Integer) As String
' Send DELE command to delete message with specified number
command = "DELE " & num & vbCr & vbLf
bData = System.Text.Encoding.ASCII.GetBytes(command.ToCharArray())
w_NetStream.Write(bData, 0, bData.Length)
Return w_ReadStream.ReadLine()
End Function
Public Function Rset() As String
' Send RSET command to unmark all deleteting messages
command = "RSET" & vbCr & vbLf
bData = System.Text.Encoding.ASCII.GetBytes(command.ToCharArray())
w_NetStream.Write(bData, 0, bData.Length)
Return w_ReadStream.ReadLine()
End Function
Public Function Quit() As String
' Send QUIT
command = "QUIT" & vbCr & vbLf
bData = System.Text.Encoding.ASCII.GetBytes(command.ToCharArray())
w_NetStream.Write(bData, 0, bData.Length)
Dim tmp As [String] = w_ReadStream.ReadLine()
w_NetStream.Close()
w_ReadStream.Close()
Return tmp
End Function
Public Function GetTop(num As Integer) As String
Dim sTemp As String
Dim [sTop] As String = ""
Try
' retrieve mail with number mail parameter
command = "TOP " & num & " n" & vbCr & vbLf
bData = System.Text.Encoding.ASCII.GetBytes(command.ToCharArray())
w_NetStream.Write(bData, 0, bData.Length)
sTemp = w_ReadStream.ReadLine()
If sTemp(0) <> "-"c Then
While sTemp <> "."
[sTop] += sTemp & vbCr & vbLf
sTemp = w_ReadStream.ReadLine()
End While
Else
Return sTemp
End If
Catch err As InvalidOperationException
Return ("Error: " & err.ToString())
End Try
Return [sTop]
End Function
Public Function GetTop(num_mess As Integer, num_strok As Integer) As String
Dim sTemp As String
Dim [sTop] As String = ""
Try
' retrieve mail with number mail parameter
command = "TOP " & num_mess & " " & num_strok & vbCr & vbLf
bData = System.Text.Encoding.ASCII.GetBytes(command.ToCharArray())
w_NetStream.Write(bData, 0, bData.Length)
sTemp = w_ReadStream.ReadLine()
If sTemp(0) <> "-"c Then
While sTemp <> "."
[sTop] += sTemp & vbCr & vbLf
sTemp = w_ReadStream.ReadLine()
End While
Else
Return sTemp
End If
Catch err As InvalidOperationException
Return ("Error: " & err.ToString())
End Try
Return [sTop]
End Function
Public Function GetUidl() As String
Dim sTemp As String
Dim sUidl As String = ""
command = "UIDL" & vbCr & vbLf
bData = System.Text.Encoding.ASCII.GetBytes(command.ToCharArray())
w_NetStream.Write(bData, 0, bData.Length)
sTemp = w_ReadStream.ReadLine()
If sTemp(0) <> "-"c Then
' errors begins with '-'
While sTemp <> "."
'saving data to string while not found '.'
sUidl += sTemp & vbCr & vbLf
sTemp = w_ReadStream.ReadLine()
End While
Else
Return sTemp
End If
Return sUidl
End Function
Public Function GetUidl(num As Integer) As String
command = "UIDL " & num & vbCr & vbLf
bData = System.Text.Encoding.ASCII.GetBytes(command.ToCharArray())
w_NetStream.Write(bData, 0, bData.Length)
Return w_ReadStream.ReadLine()
End Function
Public Function GetNoop() As String
' Send NOOP command to check if we are connected
command = "NOOP" & vbCr & vbLf
bData = System.Text.Encoding.ASCII.GetBytes(command.ToCharArray())
w_NetStream.Write(bData, 0, bData.Length)
Return w_ReadStream.ReadLine()
End Function
End Class
Public Class SISPOP3Message
Public Function GetFrom(messTop As String) As String
messTop = messTop.Remove(0, (messTop.IndexOf(vbCr & vbLf & "From:") + 7))
messTop = messTop.Remove(messTop.IndexOf(ControlChars.Cr), ((messTop.Length - messTop.IndexOf(ControlChars.Cr)) - 1))
Return messTop
End Function
Public Function GetDate(messTop As String) As String
messTop = messTop.Remove(0, (messTop.IndexOf(vbCr & vbLf & "Date:") + 7))
messTop = messTop.Remove(messTop.IndexOf(ControlChars.Cr), (messTop.Length - messTop.IndexOf(ControlChars.Cr)))
Return messTop
End Function
Public Function GetMessID(messTop As String) As String
messTop = messTop.Remove(0, (messTop.IndexOf(vbCr & vbLf & "Message-ID: ") + 13))
messTop = messTop.Remove(messTop.IndexOf(ControlChars.Cr), (messTop.Length - messTop.IndexOf(ControlChars.Cr)))
Return messTop
End Function
Public Function GetTo(messTop As String) As String
messTop = messTop.Remove(0, (messTop.IndexOf(vbCr & vbLf & "To:") + 6))
messTop = messTop.Remove(messTop.IndexOf(ControlChars.Cr), (messTop.Length - messTop.IndexOf(ControlChars.Cr)))
Return messTop
End Function
Public Function GetSubject(messTop As String) As String
messTop = messTop.Remove(0, (messTop.IndexOf(vbCr & vbLf & "Subject:") + 10))
messTop = messTop.Remove(messTop.IndexOf(ControlChars.Cr), (messTop.Length - messTop.IndexOf(ControlChars.Cr)))
Return messTop
End Function
Public Function GetBody(AllMessage As String) As String
AllMessage = AllMessage.Remove(0, (AllMessage.IndexOf(vbCr & vbLf & vbCr & vbLf)))
Return AllMessage
End Function
End Class
'Public Class SISSendMail
' ReadOnly Property ContactsTo As XPCollection(Of Contacts)
' Get
' Return New xpcoll
' End Get
' End Property
' Private Function SendMail(_Host As String, _Port As Long, _FromAddress As String, _Subject As String, _Body As String) As String
' Try
' Dim smtp As New SmtpClient()
' Dim message As New MailMessage()
' smtp.Host = _Host
' smtp.Port = _Port
' smtp.Credentials = System.Net.CredentialCache.DefaultNetworkCredentials
' 'smtp.Credentials = new System.Net.NetworkCredential("username", "password");
' message.Subject = _Subject
' message.Body = _Body
' message.From = New MailAddress(_FromAddress)
' message.DeliveryNotificationOptions = DeliveryNotificationOptions.OnFailure
' message.Priority = MailPriority.Normal
' ' Make the list of recipients.
' If [To].Count > 0 Then
' For Each item As Contact In [To]
' message.[To].Add(New MailAddress(item.Email, item.FullName))
' Next
' End If
' If CC.Count > 0 Then
' For Each item As Contact In CC
' message.CC.Add(New MailAddress(item.Email, item.FullName))
' Next
' End If
' If Bcc.Count > 0 Then
' For Each item As Contact In Bcc
' message.Bcc.Add(New MailAddress(item.Email, item.FullName))
' Next
' End If
' ' Create the file attachment (from the File property) for this e-mail message.
' If File IsNot Nothing Then
' Dim tempFileName As String = Oid.ToString()
' Using fileStream As New FileStream(tempFileName, FileMode.OpenOrCreate)
' File.SaveToStream(fileStream)
' fileStream.Position = 0
' ' Create attachment by using existing fileStream.
' Dim data As New Attachment(fileStream, System.Net.Mime.MediaTypeNames.Application.Octet)
' ' Add time stamp information for the file.
' Dim disposition As System.Net.Mime.ContentDisposition = data.ContentDisposition
' disposition.FileName = File.FileName
' disposition.Size = fileStream.Length
' disposition.CreationDate = System.IO.File.GetCreationTime(tempFileName)
' disposition.ModificationDate = System.IO.File.GetLastWriteTime(tempFileName)
' disposition.ReadDate = System.IO.File.GetLastAccessTime(tempFileName)
' ' Add the attachment to this message.
' message.Attachments.Add(data)
' ' Send the message.
' smtp.Send(message)
' data.Dispose()
' ' Delete temp file.
' If System.IO.File.Exists(tempFileName) Then
' System.IO.File.Delete(tempFileName)
' End If
' End Using
' End If
' Catch E As SmtpException
' Return "Mail send failed with message: " + E.Message
' End Try
' Return "Mail was send successfully"
' End Function
'End Class
'Dim pop3 As POP3class
'pop3 = New POP3class()
'pop3.DoConnect("your.mail.server", 110, "username", "password")
'pop3.GetStat()
'' and if we have mail:
'Dim msg As MessageClass
'msg = New MessageClass()
'Dim sMessageTop As String = msg.GetTop(1)
''OK, message is well, lets download it.
'Dim sAllMessage As String = msg.Retr(1)
'msg.GetBody(sAllMessage)
Nuvolar.Module/BusinessObjects/SIS/App_Code/SISPOP3.vb
+461
View File
@@ -0,0 +1,461 @@
Option Strict On
Option Explicit On
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' POP3 - Copyright 2011 © by David Ross Goben.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'This VB.NET Code was inspired by C# code originally written Randy Charles Morin,
'author of KBCafe.com.
'
' I have optimized the heck out of the code to speed I/O and program execution,
' forcing a complete rewrite, I have added MANY language and POP3 enhancements,
' cleaned up a lot of clutter, and added Port and SSL support.
' Oh! And I include REAL comments.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Imports System.Net, System.Text
'-------------------------------------------------------------------------------
' Class Name : POP3
' Purpose : POP3 Interface Class
'-------------------------------------------------------------------------------
Public Class POP3
Inherits Sockets.TcpClient 'this class shall inherit all the functionality of a TC/IP Client
Dim Stream As Sockets.NetworkStream 'non-SSL stream object
Dim UsesSSL As Boolean = False 'True if SLL authentication required
Dim SslStream As Security.SslStream 'set to SSL stream supporting SSL authentication if UsesSSL is True
Dim SslStreamDisposed As Boolean = False 'true if we disposed of SSL Stream object
Public LastLineRead As String = vbNullString 'copy of the last response line read from the TCP server
'*******************************************************************************
' Sub Name : Connect (This is the first the we do with a POP3 object)
' Purpose : Connect to the server using the Server, User Name, Password,
' : and a flag indicating if SSL authentication is required
' :
' Returns : Nothing
' :
' Typical TelNet I/O:
'telnet mail.domain.net 110 (submit)
'+OK POP3 mail.domain.net v2011.83 server ready
'USER myusername (submit)
'+OK User name accepted, password please
'PASS mysecretpassword (submit)
'+OK Mailbox open, 3 messages (the server locks and opens the appropriate maildrop)
'*******************************************************************************
Public Overloads Sub Connect(ByVal Server As String, _
ByVal Username As String, _
ByVal Password As String, _
Optional ByVal InPort As Integer = 110, _
Optional ByVal UseSSL As Boolean = False)
If Connected Then Disconnect() 'check underlying boolean flag to see if we are presently connected, and if so, disconnect that session
UsesSSL = UseSSL 'set flag True or False for SSL authentication
MyBase.Connect(Server, InPort) 'now connect to the server via our base class
Stream = MyBase.GetStream 'before we can check for a response, we first have to set up a non-SSL stream
If UsesSSL Then 'do we also need to use SSL authentication?
SslStream = _
New Security.SslStream(Stream) 'yes, so build an SSL stream object on top of the Network Stream
SslStream.AuthenticateAsClient(Server) 'add authentication as a client to the server
End If
If Not CheckResponse() Then Exit Sub 'exit if an error was encountered
If CBool(Len(Username)) Then 'if the username is defined (some servers will reject submissions)
Me.Submit("USER " & Username & vbCrLf) 'submit user name
If Not CheckResponse() Then Exit Sub 'exit if an error was encountered
End If
If CBool(Len(Password)) Then 'if the password is defined (some servers will reject submissions)
Me.Submit("PASS " & Password & vbCrLf) 'submit password
If Not CheckResponse() Then Exit Sub 'exit if an error was encountered
End If
End Sub
'*******************************************************************************
' Function Name : CheckResponse
' Purpose : Check the response to a POP3 command
' :
' Returns : Boolean flag. True = Success, False = Failure
' :
' NOTE : All status responses from the server begin with:
' : +OK (OK; Success, or request granted)
' or : -ERR (NAGATIVE; error)
'*******************************************************************************
Public Function CheckResponse() As Boolean
If Not IsConnected() Then Return False 'exit if not in TRANSACTION mode
LastLineRead = Me.Response 'check response (and save response line)
If (Left(LastLineRead, 3) <> "+OK") Then 'OK?
Throw New POP3Exception(LastLineRead) 'no, so throw an exception
Return False 'return failure flag
End If
Return True 'else return success flag
End Function
'*******************************************************************************
' Function Name : IsConnected
' Purpose : Return connected to Server state, throw error if not
' :
' Returns : Boolean Flag. True if connected to server
' :
'*******************************************************************************
Public Function IsConnected() As Boolean
If Not Connected Then 'if not connected, throw an exception
Throw New POP3Exception("Not Connected to an POP3 Server.")
Return False 'return failure flag
End If
Return True 'Indicate that we are in the TRANSACTION state)
End Function
'*******************************************************************************
' Function Name : Response
' Purpose : get response from server (read from the mail stream into a buffer)
' :
' Returns : string of data from the server
' :
' NOTE : If a dataSize value > 1 is supplied, then those number of bytes will be streamed in.
' : Otherwise, the data will be read in a line at a time, and end with the line end code (Linefeed (vbLf) 10 decimal)
'*******************************************************************************
Public Function Response(Optional ByVal dataSize As Integer = 1) As String
Dim enc As New ASCIIEncoding 'medium for ASCII representation of Unicode characters
Dim ServerBufr() As Byte 'establish buffer
Dim Index As Integer = 0 'init server buffer index and character counter
If dataSize > 1 Then 'did invoker specify a data length to read?
'-------------------------------------------------------
ReDim ServerBufr(dataSize - 1) 'size to dataSize to read as a single stream block (allow for 0 index)
Dim dtsz As Integer = dataSize
Dim sz As Integer 'variable to store actual number of bytes read from the stream
Do While Index < dataSize 'while we have not read the entire message...
If UsesSSL Then 'process through SSL Stream if secure stream
sz = SslStream.Read(ServerBufr, Index, dtsz) 'read a server-defined block of data from SSLstream
Else 'else process through general TCP Stream
sz = Stream.Read(ServerBufr, Index, dtsz) 'read a server-defined block of data from Network Stream
End If
If sz = 0 Then Return vbNullString 'we lost data, so we could not read the string
Index += sz 'bump index for data count actually read
dtsz -= sz 'drop amount left in buffer
Loop
Else '------------------------------------------------------
ReDim ServerBufr(255) 'initially dimension buffer to 256 bytes (including 0 offset)
Do
If UsesSSL Then 'process through SSL Stream if secure stream
ServerBufr(Index) = CByte(SslStream.ReadByte) 'read a byte from SSLstream
Else 'else process through general TCP Stream
ServerBufr(Index) = CByte(Stream.ReadByte) 'read a byte from Network stream
End If
If ServerBufr(Index) = -1 Then Exit Do 'end of stream if -1 encountered
Index += 1 'bump our offset index and counter
If ServerBufr(Index - 1) = 10 Then Exit Do 'done with line if Newline code (10; Linefeed) read in
If Index > UBound(ServerBufr) Then 'if the index points past end of buffer...
ReDim Preserve ServerBufr(Index + 255) 'then bump buffer another 256 bytes (Inc Index), but keep existing data
End If
Loop 'loop until line read in
End If
Return enc.GetString(ServerBufr, 0, Index) 'decode from a byte array into a string and return the string
End Function
'*******************************************************************************
' Sub Name : Submit
' Purpose : Submit a request to the server
' :
' Returns : Nothing
' :
' NOTE : Command name must be in UPPERCASE, such as "PASS pw1Smorf".
' : "pass pw1Smorf" would not be acceptable, though some servers do allow for this.
'*******************************************************************************
Public Sub Submit(ByVal message As String)
Dim enc As New ASCIIEncoding 'medium for ASCII representation of Unicode characters
Dim WriteBuffer() As Byte = enc.GetBytes(message) 'converts the submitted string into to a sequence of bytes
If UsesSSL Then 'using SSL authentication?
SslStream.Write(WriteBuffer, 0, WriteBuffer.Length) 'yes, so write SSL buffer
Else
Stream.Write(WriteBuffer, 0, WriteBuffer.Length) 'else write to Network buffer
End If
End Sub
'*******************************************************************************
' Sub Name : Disconnect (This is the last the we do with a POP3 object)
' Purpose : Disconnect from the server and have it enter the UPDATE mode
' :
' Returns : Nothing
' :
' Typical telNet I/O:
'QUIT (submit)
'+OK Sayonara
'
' NOTE: When the client issues the QUIT command from the TRANSACTION state,
' the POP3 session enters the UPDATE state. (Note that if the client
' issues the QUIT command from the AUTHORIZATION state, the POP3
' session terminates but does NOT enter the UPDATE state.)
'
' If a session terminates for some reason other than a client-issued
' QUIT command, the POP3 session does NOT enter the UPDATE state and
' MUST NOT remove any messages from the maildrop.
'
' The POP3 server removes all messages marked as deleted from the
' maildrop and replies as to the status of this operation. If there
' is an error, such as a resource shortage, encountered while removing
' messages, the maildrop may result in having some or none of the
' messages marked as deleted be removed. In no case may the server
' remove any messages not marked as deleted.
'
' Whether the removal was successful or not, the server the releases
' any exclusive-access lock on the maildrop and closes the TCP connection.
'*******************************************************************************
Public Sub Disconnect()
Me.Submit("QUIT" & vbCrLf) 'submit quit request
CheckResponse() 'check response
If UsesSSL Then 'SSL authentication used?
SslStream.Dispose() 'dispose of created SSL stream object if so
SslStreamDisposed = True
End If
End Sub
'*******************************************************************************
' Function Name : Statistics
' Purpose : Get the number of email messages and the total size as any integer array
' :
' Returns : 2-selement interger array.
' : Element(0) is the number of user email messages on the server
' : Element(1) is the total bytes of all messages taken up on the server
' :
' Typical telNet I/O:
'STAT (submit)
'+OK 3 16487 (3 records (emails/messages) totaling 16487 bytes (octets))
'*******************************************************************************
Public Function Statistics() As Integer()
If Not IsConnected() Then Return Nothing 'exit if not in TRANSACTION mode
Me.Submit("STAT" & vbCrLf) 'submit Statistics request
LastLineRead = Me.Response 'check response
If (Left(LastLineRead, 3) <> "+OK") Then 'OK?
Throw New POP3Exception(LastLineRead) 'no, so throw an exception
Return Nothing 'return failure flag
End If
Dim msgInfo() As String = Split(LastLineRead, " "c) 'separate by spaces, which divide its fields
Dim Result(1) As Integer
Result(0) = Integer.Parse(msgInfo(1)) 'get the number of emails
Result(1) = Integer.Parse(msgInfo(2)) 'get the size of the email messages
Return Result
End Function
'*******************************************************************************
' Function Name : List
' Purpose : Get the drop listing from the maildrop
' :
' Returns : Any Arraylist of POP3Message objects
' :
' Typical telNet I/O:
'LIST (submit)
'+OK Mailbox scan listing follows
'1 2532 (record index and size in bytes)
'2 1610
'3 12345
'. (end of records terminator)
'*******************************************************************************
Public Function List() As ArrayList
If Not IsConnected() Then Return Nothing 'exit if not in TRANSACTION mode
Me.Submit("LIST" & vbCrLf) 'submit List request
If Not CheckResponse() Then Return Nothing 'check for a response, but if an error, return nothing
'
'get a list of emails waiting on the server for the authenticated user
'
Dim retval As New ArrayList 'set aside message list storage
Do
Dim response As String = Me.Response 'check response
If (response = "." & vbCrLf) Then 'done with list?
Exit Do 'yes
End If
Dim msg As New POP3Message 'establish a new message
Dim msgInfo() As String = Split(response, " "c) 'separate by spaces, which divide its fields
msg.MailID = Integer.Parse(msgInfo(0)) 'get the list item number
msg.ByteCount = Integer.Parse(msgInfo(1)) 'get the size of the email message
msg.Retrieved = False 'indicate its message body is not yet retreived
retval.Add(msg) 'add a new entry into the retrieval list
Loop
Return retval 'return the list
End Function
'*******************************************************************************
' Function Name : GetHeader
' Purpose : Grab the email header and optionally a number of lines from the body
' :
' Returns : Gets the Email header of the selected email. If an integer value is
' : provided, that number of body lines will be returned. The returned
' : object is the submitted POP3Message.
' :
' Typical telNet I/O:
'TOP 1 0 (submit request for record 1's message header only, 0=no lines of body)
'+OK Top of message follows
' xxxxx (header for current record is transmitted)
'. (end of record terminator)
'
'TOP 1 10 (submit request for record 1's message header plus 10 lines of body data)
'+OK Top of message follows
' xxxxx (header for current record is transmitted)
' xxxxx (first 10 lines of body)
'. (end of record terminator)
'*******************************************************************************
Public Function GetHeader(ByRef msg As POP3Message, Optional ByVal BodyLines As Integer = 0) As POP3Message
If Not IsConnected() Then Return Nothing 'exit if not in TRANSACTION mode
Me.Submit("TOP " & msg.MailID.ToString & " " & BodyLines.ToString & vbCrLf)
If Not CheckResponse() Then Return Nothing 'check for a response, but if an error, return nothing
msg.Message = vbNullString 'erasde current contents of the message
'
'now process message data by binding the lines into a single string
'
Do
Dim response As String = Me.Response 'grab message line
If response = "." & vbCrLf Then 'end of data?
Exit Do 'yes, done with the loop if so
End If
msg.Message &= response 'else build message by appending the new line
Loop
Return msg 'return new filled Message object
End Function
'*******************************************************************************
' Function Name : Retrieve
' Purpose : Retrieve email from POP3 server for the provided POP3Message object
' :
' Returns : The submitted POP3 Message object with its Message property filled,
' : and its ByteCount property properly fitted to the message size.
' :
' NOTE : Some email servers are set up to automatically delete an email once
' : it is retrieved from the server. Outlook, Outlook Express, and
' : Windows Mail do this. It is an option under Juno and Gmail. So, if we
' : do not submit a POP3 QUIT (the Disconnect() method), but just close
' : out the POP3 object, the message(s) will not be deleted.
' : Even so, most Windows-based server-processors will add an additional
' : CR for each LF, but the reported email size does not account for them.
' : So we must retreive more data to account for this.
'
' Typical telNet I/O:
'RETR 1 (submit request to retrive record index 1 (cannot be an index marked for deletion))
'+OK 2532 octets (an octet is an fancy term for a 8-bit byte)
' xxxx (message header and message are retreived)
'. (end of record terminator)
'*******************************************************************************
Public Function Retrieve(ByRef msg As POP3Message) As POP3Message
If Not IsConnected() Then Return Nothing 'exit if not in TRANSACTION mode
Me.Submit("RETR " & msg.MailID.ToString & vbCrLf) 'issue request for indicated message number
If Not CheckResponse() Then Return Nothing 'check for a response, but if an error, return nothing
msg.Message = Me.Response(msg.ByteCount) 'grab message line
'the stream reader automatically convers the NewLine code, vbLf, to vbCrLf, so the files is not yet
'fully read. For example, a files that was 233 lines will therefore have 233 more characters not
'yet read from the files when it has reached its reported data size. So we will scan these in.
'But even if this was not the case, the trailing "." & vbCrLf is still pending.
Do
Dim S As String = Response() 'grab more data
If S = "." & vbCrLf Then 'end of data?
Exit Do 'If so, then exit app
End If
msg.Message &= S 'else tack data to end of message
Loop 'keep trying
msg.ByteCount = Len(msg.Message) 'ensure full size updated
Return msg 'return new message object
End Function
'*******************************************************************************
' Sub Name : Delete
' Purpose : Delete an email
' :
' Returns : Nothing
' :
' NOTE : Some email servers are set up to automatically delete an email once
' : it is retrieved from the server. Outlook, Outlook Express, and
' : Windows Mail do this. It is an option under Juno and Gmail.
'
' Typical telNet I/O:
'DELE 1 (submit request to delete record index 1)
'+OK Message deleted
'*******************************************************************************
Public Sub Delete(ByVal msgHdr As POP3Message)
If Not IsConnected() Then Exit Sub 'exit if not in TRANSACTION mode
Me.Submit("DELE " & msgHdr.MailID.ToString & vbCrLf) 'submit Delete request
CheckResponse() 'check response
End Sub
'*******************************************************************************
' Sub Name : Reset
' Purpose : Reset any deletion (automatic or manual) of all email from
' : the current session.
' :
' Returns : Nothing
' :
' Typical telNet I/O:
'RSET (submit)
'+OK Reset state
'*******************************************************************************
Public Sub Reset()
If Not IsConnected() Then Exit Sub 'exit if not in TRANSACTION mode
Me.Submit("RSET" & vbCrLf) 'submit Reset request
CheckResponse() 'check response
End Sub
'*******************************************************************************
' Function Name : NOOP (No Operation)
' Purpose : Does nothing. Juts gets a position response from the server
' :
' Returns : Boolean flag. False if disconnected, else True if connected.
' :
' NOTE : This NO OPERATION command is useful when you have a server that
' : automatically disconnects after a certain idle period of activity.
' : This command can be issued by a timer that also monitors users
' : inactivity, and issues a NOOP to reset the server timer.
' :
' Typical telNet I/O:
'NOOP (submit)
'+OK
'*******************************************************************************
Public Function NOOP() As Boolean
If Not IsConnected() Then Return False 'exit if not in TRANSACTION mode
Me.Submit("NOOP")
Return CheckResponse()
End Function
'*******************************************************************************
' Function Name : Finalize
' Purpose : remove SSL Stream object if not removed
'*******************************************************************************
Protected Overrides Sub Finalize()
If Not SslStreamDisposed Then 'SSL Stream object Disposed?
SslStream.Dispose() 'no, so do it
End If
MyBase.Finalize() 'then do normal finalization
End Sub
End Class
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'-------------------------------------------------------------------------------
' Class Name : POP3Message
' Purpose : POP3 message data
'-------------------------------------------------------------------------------
Public Class POP3Message
Public MailID As Integer = 0 'message number
Public ByteCount As Integer = 0 'length of message in bytes
Public Retrieved As Boolean = False 'flag indicating if the message has be retrieved
Public Message As String = vbNullString 'the text of the message
Public Overrides Function ToString() As String
Return Message
End Function
End Class
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'-------------------------------------------------------------------------------
' Class Name : POP3Exception
' Purpose : process exception
' NOTE : This is a normal exception, but we wrap it to give it an identy
' : that can be associated with clsPOP3
'-------------------------------------------------------------------------------
Public Class POP3Exception
Inherits ApplicationException
Public Sub New(ByVal str As String)
MyBase.New(str)
End Sub
End Class
Nuvolar.Module/BusinessObjects/SIS/App_Code/SISSMTP.vb
+233
View File
@@ -0,0 +1,233 @@
Option Strict On
Option Explicit On
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' SMTP - Copyright 2011 © by David Ross Goben.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Imports System.Net, VB = Microsoft.VisualBasic
'-------------------------------------------------------------------------------
' Class Name : SMTP
' Purpose : SMTP Interface Class
'-------------------------------------------------------------------------------
Public Class SMTP
'*******************************************************************************
' Function Name : BrainDeadSimpleEmailSend
' Purpose : Send super simple email message (works with most SMTP servers)
'===============================================================================
'NOTES: strFrom : Full email address of who is sending the email. ie, David Dingus <daviddingus@att.net>
' strTo : Full email address of who to send the email to. ie, "Bubba Dingus" <bob.dingus@cox.com>
' strSubject: Brief text regarding what the email concerns.
' strBody : text that comprises the message body of the email.
' smtpHost : This is the email host you are using for sending emails, such
' : as "smtp.comcast.net", "authsmtp.juno.com", etc.
'*******************************************************************************
Public Shared Sub BrainDeadSimpleEmailSend(ByVal strFrom As String, _
ByVal strTo As String, _
ByVal strSubject As String, _
ByVal strBody As String, _
ByVal smtpHost As String)
Dim smtpEmail As New Mail.SmtpClient(smtpHost) 'create new SMTP client using TCP Port 25
smtpEmail.Send(strFrom, strTo, strSubject, strBody) 'send email
End Sub
'*******************************************************************************
' Function Name : QuickiEMail
' Purpose : Send a simple email message (but packed with a lot of muscle)
'===============================================================================
'NOTES: strFrom : Full email address of who is sending the email. ie, David Dingus <daviddingus@att.net>
' strTo : Full email address of who to send the email to. ie, "Bubba Dingus" <bob.dingus@cox.com>
' strSubject: Brief text regarding what the email concerns.
' strBody : text that comprises the message body of the email.
' smtpHost : This is the email host you are using for sending emails, such
' : as "smtp.gmail.com", "smtp.comcast.net", "authsmtp.juno.com", etc.
' smtpPort : TCP Communications Port to use. Most servers default to 25.
' usesSLL : If this value is TRUE, then use SSL Authentication protocol for secure communications.
' SSLUsername: If usesSLL is True, this is the username to use for creating a credential. Leave blank if the same as strFrom.
' SSLPassword: If usesSLL is True, this is the password to use for creating a credential. If this field and SSLUsername
' : are blank, then default credentials will be used (only works on local, intranet servers).
' SSLDomain : If creating a credential when a specific domain is required, set this parameter, otherwise, leave it blank.
'*******************************************************************************
Public Shared Function QuickiEMail(ByVal strFrom As String, _
ByVal strTo As String, _
ByVal strSubject As String, _
ByVal strBody As String, _
ByVal smtpHost As String, _
Optional ByVal smtpPort As Integer = 25, _
Optional ByVal usesSSL As Boolean = False, _
Optional ByVal SSLUsername As String = vbNullString, _
Optional ByVal SSLPassword As String = vbNullString, _
Optional ByVal SSLDomain As String = vbNullString) As Boolean
Try
Dim smtpEmail As New Mail.SmtpClient(smtpHost, smtpPort) 'create new SMTP client
smtpEmail.EnableSsl = usesSSL 'true if SSL Authentication required
If usesSSL Then 'SSL authentication required?
If Len(SSLUsername) = 0 AndAlso Len(SSLPassword) = 0 Then 'if both SSLUsername and SSLPassword are blank...
smtpEmail.UseDefaultCredentials = True 'use default credentials
Else 'otherwise, we must create a new credential
If Not CBool(Len(SSLUsername)) Then 'if SSLUsername is blank, use strFrom
smtpEmail.Credentials = New NetworkCredential(strFrom, SSLPassword, SSLDomain)
Else
smtpEmail.Credentials = New NetworkCredential(SSLUsername, SSLPassword, SSLDomain)
End If
End If
End If
smtpEmail.Send(strFrom, strTo, strSubject, strBody) 'send email using text/plain content type and QuotedPrintable encoding
Catch e As Exception 'if error, report it
MsgBox(e.Message, MsgBoxStyle.OkOnly Or MsgBoxStyle.Exclamation, "Mail Send Error")
Return False 'return a failure flag
End Try
Return True 'if no error, then return a success flag
End Function
'*******************************************************************************
' Function Name : SendEMail
' Purpose : Send a more complex email message
'===============================================================================
'NOTES: strFrom : Full email address of who is sending the email. ie, David Dingus <daviddingus@att.net>
' strTo : Full email address of who to send the email to. ie, "Bubba Dingus" <bob.dingus@cox.com>
' : If multiple recipients, separate each full email address using a semicolon (;)
' strSubject: Brief text regarding what the email concerns.
' strBody : text that comprises the message body of the email. May be raw text or HTML code.
' IsHTML : True if the strBody data is HTML, or the type of data that would be contained within an HTML Body block.
' smtpHost : This is the email host you are using for sending emails, such
' : as "smtp.gmail.com", "smtp.comcast.net", "authsmtp.juno.com", etc.
' AltView : A System.Net.Mail.AlternateView object, such as Rich Text or HTML.
' : If need be, set AltView.ContentType.MediaType and AltView.TransferEncoding to properly format the AlternateView.
' : For example: AltView.ContentType.MediaType = Mime.MediaTypeNames.Text.Rtf
' : AltView.TransferEncoding = Mime.TransferEncoding.SevenBit
' StrCC : Send "carbon copies" of email to this or these recipients.
' : If multiple recipients, separate each full email address using a semicolon (;)
' strBcc : Blind Carbon Copy. Hide this or these recipients from view by others.
' : If multiple recipients, separate each full email address using a semicolon (;)
' strAttachments: A single filepath, or a list of filepaths to send to the recipient.
' : If multiple attachments, separate each filepath using a semicolon (;) (C:\my data\win32.txt; c:\jokes.rtf)
' : The contents of the attachments will be encoded and sent.
' : If you wish to send the attachment by specifying content type (MediaType) and content transfer encoding
' : (Encoding), then follow the attachment name with the MediaType and optional encoding (default is
' : application/octet-stream,Base64) by placing them within parentheses, and separated by a comma. For example:
' : C:\My Files\API32.txt (text/plain, SevenBit); C:\telnet.exe (application/octet-stream, Base64)
' : Where: The MediaType is determined from the System.Net.Mime.MediaTypeNames class, which
' : can specify Application, Image, or Text lists. For example, the above content type,
' : "text\plain", was defined by acquiring System.Net.Mime.MediaTypeNames.Text.Plain.
' : The second parameter, Encoding, is determined by the following the values specified by the
' : System.Net.Mime.TrasperEncoding enumeration:
' : QuotedPrintable (acquired by System.Net.Mime.TransferEncoding.QuotedPrintable.ToString)
' : Base64 (acquired by System.Net.Mime.TransferEncoding.Base64.ToString)
' : SevenBit (acquired by System.Net.Mime.TransferEncoding.SevenBit.ToString)
' smtpPort : TCP Communications Port to use. Most servers default to 25.
' usesSLL : If this value is TRUE, then use SSL Authentication protocol for secure communications.
' SSLUsername: If usesSLL is True, this is the username to use for creating a credential. Leave blank if the same as strFrom.
' SSLPassword: If usesSLL is True, this is the password to use for creating a credential. If this field and SSLUsername
' : are blank, then default credentials will be used (only works on local, intranet servers).
' SSLDomain : If creating a credential when a specific domain is required, set this parameter, otherwise, leave it blank.
'*******************************************************************************
Public Shared Function SendEMail(ByVal strFrom As String, _
ByVal strTo As String, _
ByVal strSubject As String, _
ByVal strBody As String, _
ByVal IsHTML As Boolean, _
ByVal smtpHost As String, _
Optional ByVal AltView As Mail.AlternateView = Nothing, _
Optional ByVal strCC As String = vbNullString, _
Optional ByVal strBcc As String = vbNullString, _
Optional ByVal strAttachments As String = vbNullString, _
Optional ByVal smtpPort As Integer = 25, _
Optional ByVal usesSSL As Boolean = False, _
Optional ByVal SSLUsername As String = vbNullString, _
Optional ByVal SSLPassword As String = vbNullString, _
Optional ByVal SSLDomain As String = vbNullString) As Boolean
Dim Email As New Mail.MailMessage 'create a new mail message
With Email
.From = New Mail.MailAddress(strFrom) 'add FROM to mail message (must be a Mail Address object)
'-------------------------------------------
Dim Ary() As String = Split(strTo, ";") 'add TO to mail message (possible list of email addresses; separated each with ";")
For Idx As Integer = 0 To UBound(Ary)
If Len(Trim(Ary(Idx))) <> 0 Then .To.Add(Trim(Ary(Idx))) 'add each TO recipent (primary recipients)
Next
'-------------------------------------------
.Subject = strSubject 'add SUBJECT text line to mail message
'-------------------------------------------
.Body = strBody 'add BODY text of email to mail message.
.IsBodyHtml = IsHTML 'indicate if the message body is actually HTML text.
.IsBodyHtml = True
'-------------------------------------------
If AltView IsNot Nothing Then 'if an alternate view of plaint text message is defined...
.AlternateViews.Add(AltView) 'add the alternate view
End If
'-------------------------------------------
If CBool(Len(strCC)) Then 'add CC (Carbon Copy) email addresses to mail message
Ary = Split(strCC, ";") '(possible list of email addresses, separated each with ";")
For Idx As Integer = 0 To UBound(Ary)
If Len(Trim(Ary(Idx))) <> 0 Then .CC.Add(Trim(Ary(Idx))) 'add each recipent
Next
End If
'-------------------------------------------
If CBool(Len(strBcc)) Then 'add Bcc (Blind Carbon Copy) email addresses to mail message
Ary = Split(strBcc, ";") '(possible list of email addresses; separated each with ";")
For Idx As Integer = 0 To UBound(Ary)
If Len(Trim(Ary(Idx))) <> 0 Then .Bcc.Add(Trim(Ary(Idx))) 'add each recipent (hidden recipents)
Next
End If
'-------------------------------------------
If CBool(Len(strAttachments)) Then 'add any attachments to mail message
Ary = Split(strAttachments, ";") '(possible list of file paths, separated each with ";")
For Idx As Integer = 0 To UBound(Ary) 'process each attachment
Dim attach As String = Trim(Ary(Idx)) 'get attachment data
If Len(attach) <> 0 Then 'if an attachment present...
Dim I As Integer = InStr(attach, "(") 'check for formatting instructions
If CBool(I) Then 'formatting present?
Dim Fmt As String 'yes, so set up format cache
Fmt = Mid(attach, I + 1, Len(attach) - I - 1) 'get format data
attach = Trim(VB.Left(attach, I - 1)) 'strip format data from the attachment path
Dim Atch As New Mail.Attachment(attach) 'create a new attachment
Dim fmts() As String = Split(Fmt, ",") 'break formatting up
For I = 0 To UBound(fmts) 'process each format specification
Fmt = Trim(fmts(I)) 'grab a format instruction
If CBool(Len(Fmt)) Then 'data defined?
Select Case I 'yes, so determine which type of instruction to process
Case 0 'index 0 specified MediaType
Atch.ContentType.MediaType = Fmt 'set media type to attachment
Case 1 'index 1 specifes Encoding
Select Case LCase(Fmt) 'check the encoding types and process accordingly
Case "quotedprintable", "quoted-printable"
Atch.TransferEncoding = Mime.TransferEncoding.QuotedPrintable
Case "sevenbit", "7bit"
Atch.TransferEncoding = Mime.TransferEncoding.SevenBit
Case Else
Atch.TransferEncoding = Mime.TransferEncoding.Base64
End Select
End Select
End If
Next
.Attachments.Add(Atch) 'add attachment to email
Else
.Attachments.Add(New Mail.Attachment(attach)) 'add filepath (if no format specified, encoded in effiecient Base64)
End If
End If
Next
End If
End With
'-----------------------------------------------------------------------
'now open the email server...
Try
Dim SmtpEmail As New Mail.SmtpClient(smtpHost, smtpPort) 'create new SMTP client on the SMTP server
SmtpEmail.EnableSsl = usesSSL 'true if SSL Authentication required
If usesSSL Then 'SSL authentication required?
If Len(SSLUsername) = 0 AndAlso Len(SSLPassword) = 0 Then 'if both SSLUsername and SSLPassword are blank...
SmtpEmail.UseDefaultCredentials = True 'use default credentials
Else 'otherwise, we must create a new credential
If Not CBool(Len(SSLUsername)) Then 'if SSLUsername is blank, use strFrom
SmtpEmail.Credentials = New NetworkCredential(strFrom, SSLPassword, SSLDomain)
Else
SmtpEmail.Credentials = New NetworkCredential(SSLUsername, SSLPassword, SSLDomain)
End If
End If
End If
SmtpEmail.Send(Email) 'finally, send the email...
Catch e As Exception 'if error, report it
MsgBox(e.Message, MsgBoxStyle.OkOnly Or MsgBoxStyle.Exclamation, "Mail Error")
Return False 'return failure flag
End Try
Return True 'return success flag
End Function
End Class
Nuvolar.Module/BusinessObjects/SIS/App_Code/SISUtilities.vb
+643
View File
@@ -0,0 +1,643 @@
Option Strict On
Option Explicit On
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Utilities - Copyright 2011 © by David Ross Goben.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Imports System.Text, VB = Microsoft.VisualBasic
Public Class Utilities
'*******************************************************************************
' Function Name : DecodeBase64ToStr
' Purpose : Decode a provided raw email message string that is encoded to Base64.
' :
' Returns : Decoded String
' :
' NOTES : note that the lone vbCrLf at the end of lines is filtered out.
'*******************************************************************************
Public Shared Function DecodeBase64ToStr(ByVal strData As String) As String
Return Encoding.UTF8.GetChars(DecodeBase64ToBytes(strData))
End Function
'*******************************************************************************
' Function Name : DecodeBase64ToBytes
' Purpose : Decode a provided raw email message string that is encoded to Base64.
' :
' Returns : Decoded binary Byte Array
' :
' NOTES : note that the lone vbCrLf at the end of lines is filtered out.
'*******************************************************************************
'this modification returns a Byte Array of the Base64 encoded source data
Public Shared Function DecodeBase64ToBytes(ByVal strData As String) As Byte()
Return System.Convert.FromBase64String(strData.Replace(vbCrLf, vbNullString))
End Function
'==========================================================================
'==========================================================================
'*******************************************************************************
' Function Name : DecodeQuotedPrintable
' Purpose : Method to clean typical control translations, or all of them.
' : This should be invoked for all data coded Quoted-Printable.
' :
' Returns : Provided a raw message string block, it returns a decoded string.
' :
' NOTES : Typical cleaning involves changing "=0D" to vbCr, "=0A" to vbLf,
' : "=20" to a space, and "=3D" to "=", plus any line wrap
' : terminators at the end of lines to vbNullstring.
' :
' : A StringBuilder object will be used, which will very quickly
' : do a replacement of all control code translations using fewer
' : resources, and what resources that are used will be instantly
' : flushed when the method exits.
'*******************************************************************************
Public Shared Function DecodeQuotedPrintable(ByVal Message As String, Optional ByVal QuickClean As Boolean = False) As String
'set up StringBuilder object with data stripped of any line continuation tags
Dim Msg As New StringBuilder(Message.Replace("=" & vbCrLf, vbNullString))
If QuickClean Then 'perform a quick clean (clean up common basics)
Return Msg.Replace("=" & vbCrLf, vbNullString).Replace("=0D", vbCr).Replace("=0A", _
vbLf).Replace("=20", " ").Replace("=3D", "=").ToString
Else 'perform total cleaning
'store 2-character hex values that require a leading "0"
Dim HxData As String = "X0102030405060708090A0B0C0D0E0F"
For Idx As Integer = 1 To &HF 'initially process codes 1-15, which require a leading zero
Msg.Replace("=" & Mid(HxData, Idx << 1, 2), Chr(Idx)) 'replace hex data with single character code (SHIFT is faster)
Next
For idx As Integer = &H10 To &HFF 'process the whole 8-bit extended ASCII gambit
Msg.Replace("=" & Hex(idx), Chr(idx)) 'replace hex data with single character code
Next
Return Msg.ToString 'return result string
End If
End Function
'==========================================================================
'==========================================================================
'*******************************************************************************
' Function Name : DecodeBinHex
' Purpose : Decode a provided raw email message string that is encoded to BinHex.
' :
' Returns : Decoded String
' :
' NOTES : note that the lone vbCrLf at the end of lines is filtered out.
'*******************************************************************************
Public Shared Function DecodeBinHex(ByVal StrData As String) As Byte()
Dim Src() As Byte = Encoding.UTF8.GetBytes(StrData.Replace(vbCrLf, vbNullString).ToUpper)
Dim Result() As Byte 'init output buffer
ReDim Result(UBound(Src) \ 2) 'set initial dimension to 1024 bytes (includes offset 0)
Dim Index As Integer = 0 'init index for Result() array
For Idx As Integer = 0 To UBound(Src) Step 2 'scan the string, 2 hex characters at a time
Dim CL As Integer = Src(Idx) - 48 'Convert "0" - "F" to 0-F
If CL > 10 Then CL -= 7
Dim CR As Integer = Src(Idx + 1) - 48 'do the same for the right hex digit
If CR > 10 Then CR -= 7
If Index > UBound(Result) Then
ReDim Preserve Result(Index + 255) 'bump by 256 (allow for Index offset)
End If
Result(Index) = CByte(CL * 16 + CR) 'stuff byte value
Index += 1 'bump index
Next
ReDim Preserve Result(Index - 1) 'set array to final size
Return Result 'return the final result
End Function
'==========================================================================
'==========================================================================
'*******************************************************************************
' Function Name : TextNeedsEncoding
' Purpose : Determine if HTML text, Rich Text, or Plain Text requires
' : 8-bit code translation to 7-bit Quoted-Printable tags.
' :
' Returns : Provided a source string, it returns a boolena flag.
' : If the returned value is true, the source contains 8-bit data
' : and will be encoded by server.
' :
' NOTES : If text data contains 8-bit values, the default .NET
' : SMTP processor will force this code to be encoded to Base64,
' : even if only a single byte is 8-bit.
' :
' : To avoid this, the Force7BitHtml() method can be invoked on
' : HTML text to ensure that it is 7-bit encoded so that it can
' : be processed as Quoted-Printable or as 7Bit. The ForceQuotedPrintable()
' : method performs essential conversions for non-HTML text, but this
' : would be best served in Attachments and Alternate Views.
'*******************************************************************************
Public Shared Function TextNeedsEncoding(ByVal Message As String) As Boolean
Dim Byt() As Byte = Encoding.UTF8.GetBytes(Message) 'convert message to byte array
For Each B As Byte In Byt
If CBool(B And &H80) Then Return True
Next
Return False
End Function
'==========================================================================
'==========================================================================
'*******************************************************************************
' Function Name : Force7BitHtml
' Purpose : Method to convert 8-bit code in an HTML message to 7-bit.
' :
' Returns : Provided a string containing HTML code, it will return a string
' : containing HTML code that does not have any 8-bit data embedded.
' :
' NOTES : If any characters in an HTML text string are 8-bit (values
' : greater than 127), then they are converted into a special
' : 7-bit HTML Entity Number, For Example, code 149 (•) is an 8-bit
' : value that can be changed to HTML "&#149;", which will ensure
' : that it will still be displayed on the HTML page, but the HTML
' : souce code will no longer carry an actual 8-bit value. If such
' : code had not been corrected, the encoding of the data would be
' : forced to change from quoted-printable to Base64, because that
' : would be the only way the email processor could guarantee that
' : the email text was fully intact.
'*******************************************************************************
Public Shared Function Force7BitHtml(ByVal HtmlSource As String) As String
Dim Sb As New StringBuilder 'set up string builder for appending data
For Idx As Integer = 1 To Len(HtmlSource)
Dim C As Integer = AscW(Mid(HtmlSource, Idx, 1)) 'get a single character from the source
Select Case C 'check each character
Case Is > &H7F, Is < 0 'if 8-bit or unicode code
Sb.Append("&#" & C.ToString & ";") 'convert to 7-bit HTML ecoder
Case Else
Sb.Append(ChrW(C)) 'else save text regardless
End Select
Next
Return Sb.ToString
End Function
'==========================================================================
'==========================================================================
'*******************************************************************************
' Function Name : ForceQuotedPrintable
' Purpose : Force 8-bit code in a text message to 7-bit, without data loss.
' :
' Returns : Provided a source string that contains 8-bit data, the 8-bit
' : data is converted to Hex-Tags, and the returned string is 7-bit.
' :
' NOTES : if any characters in a text string are 8-bit (values greater
' : than 127), then they are converted into special 7-bit tags.
' : For Example, code 149 (•) is an 8-bit value that can be changed
' : to hex "=95", which will ensure that it will still be displayed
' : in the text, but the text data will no longer carry an actual
' : of the data would be forced to change from quoted-printable or 7bit
' : to Base64, because that would be the only way the email processor
' : Base64, because that would be the only way the email processor
' : could guarantee that the email text was fully intact. However,
' : you will have to use the DecodeQuotedPrintable() method to convert
' : it back to its original text form.
' :
' : The Encoded text will begin with "=00". Because unencoded null codes
' : are not permitted in email data, you can use this to instantly
' : determine on the receiving end that this code will need to be
' : processed by DecodeQuotedPrintable() a second time (if initially
' : encoded as Quoted-Printable). A second pass would be required,
' : because if this translated code was afterward encoded as Quoted-
' : Printable, and all the "=xx" byte-translations, would be
' : reinterpreted as "=3Dxx", which DecodeQuotedPrintable() would
' : convert back to "=xx", so passing through a second time would
' : properly convert the additional encoding. Further, by checking the
' : text startiing with "=00", you would know that you would need to
' : double-decode the text. Also, you would want to initially skip this
' : initial tag when passing it the second time to DecodeQuotedPrintable():
' :
' : Dim Result As String = DecodeQuotedPrintable(Message) 'initially decode Quoted-Printable text
' : If VB.Left(Result, 3) = "=00" Then 'tagged as pre-encoded?
' : Return DecodeQuotedPrintable(Mid(Result, 4)) 'yes, so decode again and return, less initial null byte
' : Else
' : Return Result 'otherwise, return result of decoding
' : End If
'*******************************************************************************
Public Shared Function ForceQuotedPrintable(ByVal Message As String) As String
Dim Byt() As Byte = Encoding.UTF8.GetBytes(Message) 'convert message to byte array
Dim Sb As New StringBuilder("=00") 'set up string builder for appending data
For Each B As Byte In Byt
Select Case B 'check each byte
Case Is > &H7F 'if 8-bit code
Sb.Append("=" & Hex(B)) 'convert to 7-bit tag
Case Else
Sb.Append(Chr(B)) 'else save text regardless
End Select
Next
Return Sb.ToString
End Function
'==========================================================================
'==========================================================================
'*******************************************************************************
' Function Name : QConvertHTML2Text
' Purpose : Short-Form Convert HTML formatted text to plain text
' :
' Returns : Provided a simple HTML source string, it will return a Plain Text
' : string with HTML code removed.
'*******************************************************************************
Public Shared Function QConvertHTML2Text(ByVal HTMLText As String) As String
Return RegularExpressions.Regex.Replace(HTMLText.Replace("&nbsp;", " ").Replace("&quot;", """").Replace("&apos;", _
"'"), "<[^>]*>", "").Replace("&lt;", "<").Replace("&gt;", ">").Replace("&amp;", "&").Replace(";;", ";")
End Function
'==========================================================================
'==========================================================================
'*******************************************************************************
' Function Name : ConvertHTML2Text
' Purpose : Convert HTML formatted text to plain text
' :
' Returns : Provided a complex HTML string, it will return a Plain Text string
' : with all HTML codes and formatting removed from it.
' :
' NOTE : Numerous of these conversions will convert the text to 8-bit,
' : though most of these sysmbols will not be encountered in most
' : HTML documents we produce. But regardless of that, if you wish
' : to make this conversion the main body message of an email, you
' : may have to further convert this using ForceQuotedPrintable()
' : to maintain Quoted-Printable encoding and avoid Base64, even
' : though this is typically not an issue. However, some few really
' : primitive email readers, typically those that simply allow you
' : to preview email messages, without fully loading them, will not
' ' know how to support Base64, or will not bother with it, but simply
' : display the raw data. RFC 2045 requires email handlers to support it.
'*******************************************************************************
Public Shared Function ConvertHTML2Text(ByVal HTMLText As String) As String
'instantiate an initially blank StringBuilder object
Dim Sb As New StringBuilder()
'first remove leading whitespace of each line and append the result to the StringBuilder
Dim ary() As String = Split(HTMLText, vbCrLf)
For Each S As String In ary
Sb.Append(S.TrimStart(Chr(9), " "c))
Next
'replace reserved entities (except <, >, and &)
Sb.Replace("&quot;", """").Replace("&apos;", "'").Replace("&nbsp;", " ")
'replace HTML paragraph, line breaks, and table entry terminators with vbCrLf
Sb.Replace("<p>", vbCrLf).Replace("<P>", vbCrLf).Replace("</p>", vbCrLf).Replace("</P>", vbCrLf).Replace("<br>", _
vbCrLf).Replace("<BR>", vbCrLf).Replace("</td>", vbCrLf).Replace("</TD>", vbCrLf)
'replace ISO 8859-1 Symbols (160-255). Note that any matches will make the text 8-bit
Sb.Replace("&iexcl;", "¡").Replace("&cent;", "¢").Replace("&pound;", "£").Replace("&curren;", _
"¤").Replace("&yen;", "¥").Replace("&brvbar;", "¦").Replace("&sect;", "§").Replace("&uml;", _
"¨").Replace("&copy;", "©").Replace("&ordf;", "ª").Replace("&laquo;", "«").Replace("&not;", _
"¬").Replace("&shy;", "-").Replace("&reg;", "®").Replace("&macr;", "¯").Replace("&deg;", _
"°").Replace("&plusmn;", "±").Replace("&sup2;", "²").Replace("&sup3;", "³").Replace("&acute;", _
"´").Replace("&micro;", "µ").Replace("&para;", "").Replace("&middot;", "•").Replace("&cedil;", _
"¸").Replace("&sup1;", "¹").Replace("&ordm;", "º").Replace("&raquo;", "»").Replace("&frac14;", _
"¼").Replace("&frac12;", "½").Replace("&frac34;", "¾").Replace("&iquest;", "¿").Replace("&times;", _
"×").Replace("&divide;", "÷")
'replace ISO 8859-1 characters. Note that any matches will make the text 8-bit
Sb.Replace("&Agrave;", "À").Replace("&Aacute;", "Á").Replace("&Acirc;", "Â").Replace("&Atilde;", "Ã").Replace("&Auml;", _
"Ä").Replace("&Aring;", "Å").Replace("&AElig;", "Æ").Replace("&Ccedil;", "Ç").Replace("&Egrave;", _
"È").Replace("&Eacute;", "É").Replace("&Ecirc;", "Ê").Replace("&Euml;", "Ë").Replace("&Igrave;", _
"Ì").Replace("&Iacute;", "Í").Replace("&Icirc;", "Î").Replace("&Iuml;", "Ï").Replace("&ETH;", _
"Ð").Replace("&Ntilde;", "Ñ").Replace("&Ograve;", "Ò").Replace("&Oacute;", "Ó").Replace("&Ocirc;", _
"Ô").Replace("&Otilde;", "Õ").Replace("&Ouml;", "Ö").Replace("&Oslash;", "Ø").Replace("&Ugrave;", _
"Ù").Replace("&Uacute;", "Ú").Replace("&Ucirc;", "Û").Replace("&Uuml;", "Ü").Replace("&Yacute;", _
"Ý").Replace("&THORN;", "Þ").Replace("&szlig;", "ß").Replace("&agrave;", "à").Replace("&aacute;", _
"á").Replace("&acirc;", "â").Replace("&atilde;", "ã").Replace("&auml;", "ä").Replace("&aring;", _
"å").Replace("&aelig;", "æ").Replace("&ccedil;", "ç").Replace("&egrave;", "è").Replace("&eacute;", _
"é").Replace("&ecirc;", "ê").Replace("&euml;", "ë").Replace("&igrave;", "ì").Replace("&iacute;", _
"í").Replace("&icirc;", "î").Replace("&iuml;", "ï").Replace("&eth;", "ð").Replace("&ntilde;", _
"ñ").Replace("&ograve;", "ò").Replace("&oacute;", "ó").Replace("&ocirc;", "ô").Replace("&otilde;", _
"õ").Replace("&ouml;", "ö").Replace("&oslash;", "ø").Replace("&ugrave;", "ù").Replace("&uacute;", _
"ú").Replace("&ucirc;", "û").Replace("&uuml;", "ü").Replace("&yacute;", "ý").Replace("&thorn;", _
"þ").Replace("&yuml;", "ÿ")
'replace Math Symbols Supported by HTML. Note that any matches will make the text 8-bit
Sb.Replace("&forall;", "∀").Replace("&part;", "∂").Replace("&exist;", "∃").Replace("&empty;", "∅").Replace("&nabla;", _
"∇").Replace("&isin;", "∈").Replace("&notin;", "∉").Replace("&ni;", "∋").Replace("&prod;", _
"∏").Replace("&sum;", "∑").Replace("&minus;", "−").Replace("&lowast;", "∗").Replace("&radic;", _
"√").Replace("&prop;", "∝").Replace("&infin;", "∞").Replace("&ang;", "∠").Replace("&and;", _
"∧").Replace("&or;", "∨").Replace("&cap;", "∩").Replace("&cup;", "∪").Replace("&int;", _
"∫").Replace("&there4;", "∴").Replace("&sim;", "∼").Replace("&cong;", "≅").Replace("&asymp;", _
"≈").Replace("&ne;", "≠").Replace("&equiv;", "≡").Replace("&le;", "≤").Replace("&ge;", _
"≥").Replace("&sub;", "⊂").Replace("&sup;", "⊃").Replace("&nsub;", "⊄").Replace("&sube;", _
"⊆").Replace("&supe;", "⊇").Replace("&oplus;", "⊕").Replace("&otimes;", "⊗").Replace("&perp;", _
"⊥").Replace("&sdot;", "⋅")
'replace Greek Letters Supported by HTML. Note that any matches will make the text 8-bit
Sb.Replace("&Alpha;", "Α").Replace("&Beta;", "Β").Replace("&Gamma;", "Γ").Replace("&Delta;", "Δ").Replace("&Epsilon;", _
"Ε").Replace("&Zeta;", "Ζ").Replace("&Eta;", "Η").Replace("&Theta;", "Θ").Replace("&Iota;", _
"Ι").Replace("&Kappa;", "Κ").Replace("&Lambda;", "Λ").Replace("&Mu;", "Μ").Replace("&Nu;", _
"Ν").Replace("&Xi;", "Ξ").Replace("&Omicron;", "Ο").Replace("&Pi;", "Π").Replace("&Rho;", _
"Ρ").Replace("&Sigma;", "Σ").Replace("&Tau;", "Τ").Replace("&Upsilon;", "Υ").Replace("&Phi;", _
"Φ").Replace("&Chi;", "Χ").Replace("&Psi;", "Ψ").Replace("&Omega;", "Ω").Replace("&alpha;", _
"α").Replace("&beta;", "β").Replace("&gamma;", "γ").Replace("&delta;", "δ").Replace("&epsilon;", _
"ε").Replace("&zeta;", "ζ").Replace("&eta;", "η").Replace("&theta;", "θ").Replace("&iota;", _
"ι").Replace("&kappa;", "κ").Replace("&lambda;", "λ").Replace("&mu;", "μ").Replace("&nu;", _
"ν").Replace("&xi;", "ξ").Replace("&omicron;", "ο").Replace("&pi;", "π").Replace("&rho;", _
"ρ").Replace("&sigmaf;", "ς").Replace("&sigma;", "σ").Replace("&tau;", "τ").Replace("&upsilon;", _
"υ").Replace("&phi;", "φ").Replace("&chi;", "χ").Replace("&psi;", "ψ").Replace("&omega;", _
"ω").Replace("&thetasym;", "ϑ").Replace("&upsih;", "ϒ").Replace("&piv;", "ϖ")
'replace Other Entities Supported by HTML. Note that any matches will make the text 8-bit
Sb.Replace("&OElig;", "Œ").Replace("&oelig;", "œ").Replace("&Scaron;", "Š").Replace("&scaron;", "š").Replace("&Yuml;", _
"Ÿ").Replace("&fnof;", "ƒ").Replace("&circ;", "ˆ").Replace("&tilde;", "˜").Replace("&ensp;", _
" ").Replace("&emsp;", " ").Replace("&thinsp;", " ").Replace("&ndash;", "–").Replace("&mdash;", _
"—").Replace("&lsquo;", "‘").Replace("&rsquo;", "’").Replace("&sbquo;", "‚").Replace("&ldquo;", _
" ").Replace("&rdquo;", " ").Replace("&bdquo;", "„").Replace("&dagger;", "†").Replace("&Dagger;", _
"‡").Replace("&bull;", "•").Replace("&hellip;", "…").Replace("&permil;", "‰").Replace("&prime;", _
"′").Replace("&Prime;", "″").Replace("&lsaquo;", "‹").Replace("&rsaquo;", "›").Replace("&oline;", _
"‾").Replace("&euro;", "€").Replace("&trade;", "™").Replace("&larr;", "←").Replace("&uarr;", _
"↑").Replace("&rarr;", "→").Replace("&darr;", "↓").Replace("&harr;", "↔").Replace("&crarr;", _
"↵").Replace("&lceil;", "⌈").Replace("&rceil;", "⌉").Replace("&lfloor;", "⌊").Replace("&rfloor;", _
"⌋").Replace("&loz;", "◊").Replace("&spades;", "♠").Replace("&clubs;", "♣").Replace("&hearts;", _
"♥").Replace("&diams;", "♦")
'replace special ASCII coding entities that were not captured by the above. Note that values > 127 will make the text 8-bit
For Idx As Integer = 1 To 255 'See www.w3schools.com/tags/ref_entities.asp
Sb.Replace("&#" & Idx.ToString & ";", Chr(Idx)) 'replace most common numeric entities
Next
'Ensure header definitions are followed by vbCrLf
Dim NewText As String = RegularExpressions.Regex.Replace(Sb.ToString(), "</H[^>]*>", vbCrLf)
'Also seek out other Unicode encoded number entities not covered by the above and individually update them
Dim Idy As Integer = InStr(NewText, "&#") 'check for a numeric entity
Do While Idy <> 0 'loop as long as we find one
Dim Idz As Integer = InStr(Idy, NewText, ";") 'find terminating semicolon
Dim S As String = Mid(NewText, Idy, Idz - Idy + 1) 'grab expression
RegularExpressions.Regex.Replace(NewText, S, Chr(CInt(Mid(S, 3, Len(S) - 3)))) 'replace expression
InStr(Idy + 1, NewText, "&#")
Loop
'strip remaining HTML text tags, replace < and > placeholders, convert ampersand, replace ;; with ;, then return result
Return RegularExpressions.Regex.Replace(NewText, "<[^>]*>", "").Replace("&lt;", _
"<").Replace("&gt;", ">").Replace("&amp;", "&").Replace(";;", ";")
End Function
'==========================================================================
'==========================================================================
'*******************************************************************************
' Enum MediaTypes: Structure used by GetMediaType
'*******************************************************************************
Public Enum MediaTypes As Integer
ApplicationOctet ' 0 = Integer Value
ApplicationPdf ' 1
ApplicationRtf ' 2
ApplicationSoap ' 3
ApplicationZip ' 4
ImageGif ' 5
ImageJpeg ' 6
ImageTiff ' 7
TextHtml ' 8
TextPlain ' 9
TextRich '10
TextXml '11
End Enum
'*******************************************************************************
' Function Name : GetMediaType
' Purpose : Provide easy access to System.Net.Mime.MediaTypes text
' :
' Returns : provided a MediaTypes enumeration value, a string representing
' : the selected type will be returned.
'*******************************************************************************
Public Shared Function GetMediaType(ByVal MediaType As MediaTypes) As String
Select Case MediaType
Case MediaTypes.ApplicationPdf
Return "application/pdf"
Case MediaTypes.ApplicationRtf
Return "application/rtf"
Case MediaTypes.ApplicationSoap
Return "application/soap+xml"
Case MediaTypes.ApplicationZip
Return "application/zip"
Case MediaTypes.ImageGif
Return "image/gif"
Case MediaTypes.ImageJpeg
Return "image/jpeg"
Case MediaTypes.ImageTiff
Return "image/tiff"
Case MediaTypes.TextHtml
Return "text/html"
Case MediaTypes.TextPlain
Return "text/plain"
Case MediaTypes.TextRich
Return "text/richtext"
Case MediaTypes.TextXml
Return "text/xml"
Case Else
Return "application/octet-stream"
End Select
End Function
'==========================================================================
'==========================================================================
'*******************************************************************************
' Enum TransferEncodings: Structure used by GetTransferEncoding
'*******************************************************************************
Public Enum TransferEncodings As Integer
QuotedPrintable ' 0 = Integer value
Base64 ' 1
SevenBit ' 2
End Enum
'*******************************************************************************
' Function Name : GetTransferEncoding
' Purpose : Provide easy access to System.Net.Mime.TransferEncoding data
' :
' Returns : Provided a TransferEncodings value, a TransferEncoding value
' : is returned.
'*******************************************************************************
Public Shared Function GetTransferEncoding(ByVal TransferEncoding As TransferEncodings) As System.Net.Mime.TransferEncoding
Return DirectCast(TransferEncoding, System.Net.Mime.TransferEncoding)
End Function
'==========================================================================
'==========================================================================
'*******************************************************************************
' Function Name : GetEmailInfo
' Purpose : Break email down into its component parts.
' :
' Returns : EmailInfo object with component parts of email broken down.
' :
' NOTES : This method uses classes EmailItems and EmailInfo.
' : The Message Body, and each AlternnateView or Attachment are
' : contained within EmailItem objects within the EmailIngo object.
' :
' : An EmailItem contains fields for FROM, TO, SUBJECT, Content-Type,
' : a flag indicating if the ContentTypeData is a filename or if it is
' : text formatting, content-transfer-encoding data, and the raw encoded,
' : data, whether it is a message or binary information. If the content-
' : transfer encoding is set to "base64", the data should be decoded
' : using the DecodeBase64() method. If it is "quoted-printable", the
' : data should be decoded using DecodeQuotedPrintable(). If it is
' : "7bit", it is 7-bit data and does not need to be decoded.
'*******************************************************************************
Public Shared Function GetEmailInfo(ByVal MailMessage As String) As EmailInfo
Dim Info As New EmailInfo 'structure to hold breakdown of email
Dim Ary() As String = Split(MailMessage, vbCrLf) 'break full email into lines
Dim Idx As Integer = 0 'index into Ary()
Dim MX As Integer = UBound(Ary) + 1 'find end if list+1
Dim Boundaries As New Collections.Generic.List(Of String) 'boundary definitions
Dim IsMultiPart As Boolean = False 'true if we have multiple parts
Dim SeekingEncoding As Boolean = False 'true if we are looking for encoding
Dim BuildingDataBlock As Boolean = False 'true if we are building a data block
Dim HaveMessageBody As Boolean = False 'true if we have the message body defined
Dim ContentType As String = vbNullString 'hold last-defined Content Type
Dim ContentTypeIsName As Boolean = False 'true of Content Type specified a file
Dim ContentTypeData As String = vbNullString 'if block isan attachment
Dim ContentEncoding As String = vbNullString 'hold last-defined Content Transfer Encoding
Dim ContentBody As String = vbNullString 'block data accumulator
'-----------------------------------------------------------
Dim Inheader As Integer = 4 'flag for gathering To, From, Date, Subject
Do
Dim S As String = Ary(Idx) 'grab a line of data from the email
'
' check for important header items
'
If CBool(Len(S)) AndAlso CBool(Inheader) Then 'if we are currently in the header...
Dim I As Integer = InStr(S, ":") 'find field delimiter
If CBool(I) Then 'found one?
If VB.Right(S, 1) = ";" Then 'line continues?
Idx += 1 'yes, so bump index
S &= Ary(Idx).Trim(Chr(9), " "c) 'append next line next line
End If
Select Case LCase(VB.Left(S, I)) 'yes, check for one of 4 fields
Case "from:" 'Found FROM field
Info.FromData = Trim(Mid(S, I + 1)) 'stuff to structure
Inheader -= 1 'drop 1 from flag
Case "to:" 'Found TO field
Info.ToData = Trim(Mid(S, I + 1)) 'stuff to structure
Inheader -= 1 'drop 1 from flag
Case "date:" 'Found DATE field
Info.DateData = Trim(Mid(S, I + 1)) 'stuff to structure
Inheader -= 1 'drop 1 from flag
Case "subject:" 'Found SUBJECT field
Info.SubjectData = Trim(Mid(S, I + 1)) 'stuff to structure
Inheader -= 1 'drop 1 from flag
End Select
End If
If Not CBool(Inheader) Then 'if InHeader flag is zero
SeekingEncoding = True 'start looking for a Content-Transfer-Encoding field
S = vbNullString 'purge current data
End If
End If
'-------------------------------------------------------
' check for boundaries
'-------------------------------------------------------
If CBool(Len(S)) AndAlso CBool(Boundaries.Count) Then 'check any defined boundaries
For Idy As Integer = 0 To Boundaries.Count - 1
If CBool(InStr(S, Boundaries.Item(Idy), CompareMethod.Text)) Then
If BuildingDataBlock Then
Dim Itm As New EmailItem 'create a new item
Itm.ContentType = ContentType 'store content type
Itm.ContentTypeData = ContentTypeData 'save filename or character set
Itm.ContentTypeDataIsFilename = ContentTypeIsName 'save flag indicating if Attachment
Itm.ContentEncoding = ContentEncoding 'store encoding
Itm.ContentBody = ContentBody 'store data
ContentBody = vbNullString 'reset accumulator
If HaveMessageBody Then 'already have a message body?
If ContentTypeIsName Then 'if an attachment
Info.Attachments.Add(Itm) 'add an attachment
Else 'otherwise an alternate view
Info.AlternateViews.Add(Itm)
End If
Else
Info.MessageBody = Itm 'else stuff new item to message body
HaveMessageBody = True 'indicate we now have a message body
End If
ContentTypeData = vbNullString 'reset filename/charset
BuildingDataBlock = False 'turn off building flag
End If
SeekingEncoding = True 'turn block seeing on again
S = vbNullString 'purge current data
Exit For
End If
Next
End If
'-------------------------------------------------------
' build data block
'-------------------------------------------------------
If BuildingDataBlock Then
ContentBody &= S & vbCrLf 'add a line to content data
End If
'-------------------------------------------------------
' if seeking encoding
'-------------------------------------------------------
If CBool(Len(S)) AndAlso SeekingEncoding Then 'are we seeking TCE?
Dim I As Integer = InStr(S, ":") 'yes, check for field delimiter
If CBool(I) Then 'did we find one?
Select Case LCase(VB.Left(S, I)) 'yes, check for types
'=======================================================
Case "content-type:" 'Content type?
ContentType = Mid(S, I + 1).Trim(Chr(9), " "c) 'yes, so grab data
If VB.Right(S, 1) = ";" Then 'more to add?
Idx += 1 'yes, so bump index
ContentType &= Ary(Idx).Trim(Chr(9), " "c) 'grab next line
End If
ContentTypeIsName = False 'init flag specifying a file as false
Dim sbAry() As String = Split(ContentType, ";") 'now check the content type data
ContentType = sbAry(0) 'keep first part for ContentType
If StrComp(VB.Left(sbAry(0), 10), "multipart/", CompareMethod.Text) = 0 Then
'multipart, so grab second parameter (boundary definition), and strip any quotes
Dim Bnd As String = Trim(Mid(sbAry(1), InStr(sbAry(1), "=") + 1)).Replace("""", vbNullString)
Boundaries.Add(Bnd) 'and add a boundary
ElseIf StrComp(VB.Left(sbAry(1), 5), "name=", CompareMethod.Text) = 0 Then
ContentTypeIsName = True 'attachment if a filename specified (otherwise a view)
sbAry = Split(sbAry(1), "=") 'multipart, so grab second parameter
'get second part of second parameter (filename definition)
ContentTypeData = sbAry(1).Trim().Replace("""", vbNullString) 'strip any quotes
Else
ContentTypeData = sbAry(1) 'AlternateView, so stuff display character set
End If
'===================================================
Case "content-transfer-encoding:"
ContentEncoding = Mid(S, I + 1).Trim(Chr(9), " "c) 'yes, so grab data
SeekingEncoding = False 'turn off seeking flag
BuildingDataBlock = True 'turn on building data block flag
Idx += 1 'bump to skip required following blank line
End Select
End If
End If
Idx += 1 'bump array index
Loop While Idx < MX
'-----------------------------------------------------------
Return Info 'return with filled data block
End Function
End Class
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'*******************************************************************************
' Class Name : EmailItem (used by EmailInfo class)
' Purpose : Stores structure of an email block
'*******************************************************************************
Public Class EmailItem
Public ContentType As String = vbNullString 'CONTENT-TYPE data
Public ContentTypeData As String = vbNullString 'filename or text encoding
Public ContentTypeDataIsFilename As Boolean = False 'True if ContentTypeData specifies a filename
Public ContentEncoding As String = vbNullString 'CONTENT-TRANSFER-ENCODING data
Public ContentBody As String = vbNullString 'raw data of block
End Class
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'*******************************************************************************
' Class Name : EmailInfo (used by GetEmailInfo method)
' Purpose : Store component parts of an Email
'*******************************************************************************
Public Class EmailInfo
Public FromData As String = vbNullString 'FROM:
Public ToData As String = vbNullString 'TO:
Public DateData As String = vbNullString 'DATE:
Public SubjectData As String = vbNullString 'SUBJECT:
Public MessageBody As EmailItem 'contents of message body
Public AlternateViews As New Collections.Generic.List(Of EmailItem) 'list of alternate views
Public Attachments As New Collections.Generic.List(Of EmailItem) 'list of attachments
End Class