vbscript 旧版KTM WinWrap
Posted
tags:
篇首语：本文由小常识网(cha138.com)小编为大家整理，主要介绍了vbscript 旧版KTM WinWrap相关的知识，希望对你有一定的参考价值。
' Scansation Tools
Dim imTools As New Iron.InvoiceTools
Dim country As Iron.CountryData
Set country = imTools.GetCountryByGeoId(94)
Debug.Print country.friendlyName
Set country = imTools.GetCountryByFriendlyName("germany")
Debug.Print country.friendlyName
Set country = imTools.GetCountryByIso2("gb")
Debug.Print country.Iso3
Set country = imTools.GetCountryByIso3("DEu")
Debug.Print country.GeoId
?country.friendlyName
"France"
?country.geoId
84&
?country.iso2
"FR"
?country.iso3
"FRA"
?country.OfficialName
"French Republic"
Case "test"
Dim IMTools As New IronMountain_Ktm50_InvoicePack10.InvoiceTools
Dim country As IronMountain_Ktm50_InvoicePack10.CountryData
' Set country = IMTools.GetCountryByGeoId(94)
' Debug.Print country.friendlyName
' Set country = IMTools.GetCountryByFriendlyName("germany")
' Debug.Print country.friendlyName
Set country = IMTools.GetCountryByIso2(pXDoc.Fields.ItemByName(FIELD_SUPPLIER_REGION).Text)
Debug.Print country.iso3
' Set country = IMTools.GetCountryByIso3("DEu")
' Debug.Print country.GeoID
Dim WshShell As Variant
Dim test As String
Set WshShell = CreateObject("WScript.Shell")
test = WshShell.RegRead("HKCU\Control Panel\International\sCountry")
MsgBox test
'***************************************************************************
'*** Name : DoesRegexPatternMatchString
'*** Purpose: Perform regex matching using VBScript.RegExp
'*** http://www.regular-expressions.info/vbscript.html
'*** Inputs : regexPattern, inputString.
'*** Outputs: None.
'***
'*** Return : True/False.
'**************************************************************************
Private Function DoesRegexPatternMatchString(regexPattern As String, inputString As String) As Boolean
Dim bResult As Boolean
Dim oRegExp As Object
On Error GoTo DoesRegexPatternMatchStringError
If regexPattern = "" Then
bResult = True
Else
Set oRegExp = CreateObject("VBScript.RegExp")
oRegExp.Pattern = regexPattern
bResult = oRegExp.Test(inputString)
End If
DoesRegexPatternMatchString = bResult
Exit Function
DoesRegexPatternMatchStringError:
Err.Raise Err.Number, "DoesRegexPatternMatchString" & "->" & Err.Source, "Cannot execute regex pattern match: " & Err.Description
End Function
'** Error logging
Global Const LOG_ERROR As Boolean = True
Global Const LOG_ERROR_N As Boolean = False
Global Const DISPLAY_TO_USER As Boolean = True
Global Const DISPLAY_TO_USER_N As Boolean = False
'** Debugging
Public Declare Sub OutputDebugString Lib "kernel32" Alias "OutputDebugStringA" (ByVal lpOutputString As String)
' Logging data structure.
Public Type Logging
CheckedLoggingEnabled As Boolean
LoggingEnabled As Boolean
LogFilePath As String
End Type
Public tLogging As Logging
Public Const SCRIPT_DEBUG_LOGGING_ENABLED = "Logging_DebugLoggingEnabled"
Public Const SCRIPT_LOG_FILES_DIRECTORY_PATH = "Logging_LogFilesDirectoryPath"
Public Const SCRIPT_LOG_FILES_FILENAME_PREFIX = "Logging_LogFilesFileNamePrefix"
'*************************************************
' General_Error_Handler
'-------------------------------------------------
' Purpose:
' Inputs:
' sModuleName: Name of the module or function
' bLogError: True: Write it to Log file
' bDisplayToUser: True: Display the message in the msgbox (suppress the msgbox if in server mode)
' Outputs:
' Returns:
' Notes: The err object is global, so no need to have it as a parameter
'*************************************************
Public Sub General_Error_Handler(sSource As String, bLogError As Boolean, bDisplayToUser As Boolean, Optional vXDoc As Variant, Optional bHaltKTMServer As Boolean)
Dim sMessage As String
sMessage = "Error: " & sSource & ". " & Err.Number & ": " & Err.Description & " STATIONID: " & CStr(Environ("COMPUTERNAME"))
Debug.Print sMessage
' Log to file
If bLogError Then
WriteMessageToLogFile (sMessage)
End If
' Log to screen
If bDisplayToUser Then
displayErrorMessage (sMessage)
End If
' How should KTM Server 1 & 2 respond to the error?
If Project.ScriptExecutionMode = CscScriptModeServer Then
If bHaltKTMServer = True Then
' Raise an error for QC module in Kofax Capture. This sends the batch to the quality control queue
Err.Raise(Err.Number, Err.Source, sMessage)
ElseIf Not IsMissing(vXDoc) Then
' Flag that an error occured so this can be exposed during KTM validation
DocXValueSet(vXDoc, "KTMServer" & CStr(Project.ScriptExecutionInstance) & "_FatalError", sMessage)
End If
End If
End Sub
'***************************************************************************
'*** Name : WriteMessageToLogFile
'*** Purpose: Logs the specified message to the log file.
'*** Inputs : message
'*** Outputs: None
'***
'*** Return : Nothing.
'**************************************************************************
Public Sub WriteMessageToLogFile(ByVal message As String)
Dim strDirectoryPath As String
Dim strLogFileNamePrefix As String
Dim strLogFileName As String
Dim FSO As Object
Dim iFreeFile As Integer
On Error Resume Next
If tLogging.LogFilePath = "" Then
If Project.ScriptVariables.ItemExists(SCRIPT_LOG_FILES_DIRECTORY_PATH) Then
strDirectoryPath = Project.ScriptVariables.ItemByName(SCRIPT_LOG_FILES_DIRECTORY_PATH).Value
strLogFileNamePrefix = Project.ScriptVariables.ItemByName(SCRIPT_LOG_FILES_FILENAME_PREFIX).Value
strLogFileName = strLogFileNamePrefix & "-" & Format(Now, "mmyy") & ".log"
Set FSO = CreateObject("Scripting.FileSystemObject")
tLogging.LogFilePath = FSO.BuildPath(strDirectoryPath, strLogFileName)
End If
End If
If tLogging.LogFilePath <> "" Then
iFreeFile = FreeFile
Open tLogging.LogFilePath For Append As #iFreeFile
Print #iFreeFile, "[" & Format(Now, "dd/mm/yyyy hh:MM:ss") & "] " & message
Close #iFreeFile
End If
End Sub
'***************************************************************************
'*** Name : displayErrorMessage
'*** Purpose: Displays the error based on the runtime environment
'*** Inputs : sMessage (the constructed error mesg)
'*** Outputs: None
'***
'*** Return : Nothing.
'**************************************************************************
Public Sub displayErrorMessage(sMessage As String)
OutputDebugString "KfxKTM_displayErrorMessage: Fired"
Select Case Project.ScriptExecutionMode
' Only display the error if the machine is not a webserver (and the error needs to be displayed)
Case CscScriptModeValidation
OutputDebugString "KfxKTM_Execution Mode=CscScriptModeValidation"
If IsTCS(Environ("COMPUTERNAME")) = False Then
MsgBox(sMessage)
End If
' Within project builder we always want to display message boxes
Case CscScriptModeValidationDesign, CscScriptModeServerDesign
OutputDebugString "KfxKTM_Execution Mode=CscScriptModeValidationDesign/CscScriptModeServerDesign"
MsgBox(sMessage)
End Select
End Sub
'***************************************************************************
'*** Name : IsTCS
'*** Purpose: Is the current machine name a KTM Thin Client Server?
'*** Inputs : sName (the machine name)
'*** Outputs:
'***
'*** Return : True/False
'**************************************************************************
Public Function IsTCS(sName As String) As Boolean
' Check to see if the current workstation/server is a KTM Thin Client Web Server
IsTCS = False
'Is the machine name listed as part of the known server list?
If InStr(1, UCase$(Trim$(Project.ScriptVariables.ItemByName("Logging_ThinClientServers").Value)), UCase$(sName)) Then
OutputDebugString "KfxKTM_IsTCS: Thin client server detected"
IsTCS = True
End If
End Function
'***************************************************************************
'*** Name : DocXValueSet
'*** Purpose: Create and set a new Xvalue for the document.
'*** Inputs : Xdoc, sKey (name of the key to be created), sValue (the value to be assigned)
'*** Outputs:
'***
'*** Return : Nothing.
'**************************************************************************
Public Sub DocXValueSet(ByVal pXDoc As CASCADELib.CscXDocument, sKey As String, sValue As String)
OutputDebugString "KfxKTM_DocXValueSet: Fired"
pXDoc.XValues.Set(sKey, sValue)
OutputDebugString "KfxKTM_DocXValueSet: sKey=" & sKey & ", sValue=" & sValue
End Sub
'***************************************************************************
'*** Name : GetScriptExecutionName
'*** Purpose: Get the name of the runtime environment
'*** Inputs : lMode (the ID of the runtime environment)
'*** Outputs:
'***
'*** Return : String
'**************************************************************************
Public Function GetScriptExecutionName(lMode As Long) As String
Select Case lMode
Case 0
GetScriptExecutionName = "Unknown"
Case 1
GetScriptExecutionName = "Server"
Case 2
GetScriptExecutionName = "Validation"
Case 3
GetScriptExecutionName = "Server Design"
Case 4
GetScriptExecutionName = "Validation Design"
Case 5
GetScriptExecutionName = "Verification"
Case 7
GetScriptExecutionName = "Document Review"
End Select
End Function
Public Function GetBatchName(ByVal pXRootFolder As CASCADELib.CscXFolder) As String
If Project.ScriptExecutionInstance = 3 Then
GetBatchName = DESIGN_BATCHNAME & " " & Now
Exit Function
End If
GetBatchName = pXRootFolder.XValues("AC_BATCH_NAME")
End Function
Public Function GetBatchDir(ByVal pXRootFolder As CASCADELib.CscXFolder) As String
If Project.ScriptExecutionInstance = 3 Then
GetBatchDir = "NULL"
Exit Function
End If
GetBatchDir = pXRootFolder.XValues("AC_BATCH_DIRECTORY")
End Function
Private Sub Batch_Close(ByVal pXRootFolder As CASCADELib.CscXFolder, ByVal CloseMode As CASCADELib.CscBatchCloseMode)
OutputDebugString "KfxKTM_Batch_Close: " & GetScriptExecutionName(Project.ScriptExecutionMode) & " | " & CStr(Project.ScriptExecutionInstance) & " | " & CStr(CloseMode)
OutputDebugString "KfxKTM_Batch Name/Dir: " & GetBatchName(pXRootFolder) & " | " & GetBatchDir(pXRootFolder)
End Sub
Private Sub Batch_Open(ByVal pXRootFolder As CASCADELib.CscXFolder)
OutputDebugString "KfxKTM_Batch_Open: " & GetScriptExecutionName(Project.ScriptExecutionMode) & " | " & CStr(Project.ScriptExecutionInstance)
OutputDebugString "KfxKTM_Batch Name/Dir: " & GetBatchName(pXRootFolder) & " | " & GetBatchDir(pXRootFolder)
End Sub
Private Sub fmtPostCode_FormatField(ByVal FieldText As String, ByRef FormattedText As String, ByRef ErrDescription As String, ByRef ValidFormat As Boolean)
On Error GoTo ErrorHandler
OutputDebugString "KfxKTM_FmtPostCode_FormatField: Fired"
FormattedText = Replace(FieldText, " ", "")
If FormattedText = "" Then FormattedText = vbNullChar
ValidFormat = True
OutputDebugString "KfxKTM_FormattedText: " & FormattedText
Exit Sub
ErrorHandler:
General_Error_Handler("FmtPostCode_FormatField", LOG_ERROR, DISPLAY_TO_USER)
End Sub
' Logging data structure.
Private Type Logging
CheckedLoggingEnabled As Boolean
LoggingEnabled As Boolean
LogFilePath As String
End Type
Private Const SCRIPT_DEBUG_LOGGING_ENABLED = "DebugLoggingEnabled"
Private Const SCRIPT_LOG_FILES_DIRECTORY_PATH = "LogFilesDirectoryPath"
'***************************************************************************
'*** Name : LogError
'*** Purpose: Logs the specified error to the log file.
'*** Inputs : code, source, description
'*** Outputs: None
'***
'*** Return : Nothing.
'**************************************************************************
Private Sub LogError(ByVal code As Long, ByVal source As String, ByVal description As String)
Dim strMessage As String
On Error Resume Next
strMessage = "[Error " & code & "] Source: " & source & ". " & description
WriteMessageToLogFile strMessage
Debug.Print strMessage
If (Project.ScriptExecutionMode = CscScriptModeValidation) Or _
(Project.ScriptExecutionMode = CscScriptModeValidationDesign) Then
MsgBox strMessage, VbMsgBoxStyle.vbCritical, "Critical Error"
End If
End Sub
'***************************************************************************
'*** Name : LogMessage
'*** Purpose: Logs the specified message to the log file if logging is
'*** enabled. Always writes to the debug window.
'*** Inputs : message
'*** Outputs: None
'***
'*** Return : Nothing.
'**************************************************************************
Private Sub LogMessage(ByVal message As String)
Dim strLoggingEnabledValue As String
Dim strMessage As String
On Error Resume Next
strMessage = "[Debug] " & message
If Not tLogging.CheckedLoggingEnabled Then
If Project.ScriptVariables.ItemExists(SCRIPT_DEBUG_LOGGING_ENABLED) Then
strLoggingEnabledValue = Project.ScriptVariables.ItemByName(SCRIPT_DEBUG_LOGGING_ENABLED).Value
tLogging.LoggingEnabled = CBool(strLoggingEnabledValue)
tLogging.CheckedLoggingEnabled = True
End If
End If
If tLogging.LoggingEnabled Then
WriteMessageToLogFile (strMessage)
End If
Debug.Print strMessage
End Sub
'***************************************************************************
'*** Name : WriteMessageToLogFile
'*** Purpose: Logs the specified message to the log file.
'*** Inputs : message
'*** Outputs: None
'***
'*** Return : Nothing.
'**************************************************************************
Private Sub WriteMessageToLogFile(ByVal message As String)
Dim strDirectoryPath As String
Dim strLogFileName As String
Dim FSO As Object
Dim iFreeFile As Integer
On Error Resume Next
If tLogging.LogFilePath = "" Then
If Project.ScriptVariables.ItemExists(SCRIPT_LOG_FILES_DIRECTORY_PATH) Then
strDirectoryPath = Project.ScriptVariables.ItemByName(SCRIPT_LOG_FILES_DIRECTORY_PATH).Value
strLogFileName = "Eurovia-" & Format(Now, "mmyy") & ".log"
Set FSO = CreateObject("Scripting.FileSystemObject")
tLogging.LogFilePath = FSO.BuildPath(strDirectoryPath, strLogFileName)
End If
End If
If tLogging.LogFilePath <> "" Then
iFreeFile = FreeFile
Open tLogging.LogFilePath For Append As #iFreeFile
Print #iFreeFile, "[" & Format(Now, "dd/mm/yyyy hh:MM:ss") & "] " & message
Close #iFreeFile
End If
End Sub'***************************************************************************
'*** Name : String_FuzzyMatch
'*** Purpose: Performs a fuzzy match between two strings.
'*** Uses the Levenshtein Distance.
'***
'*** Inputs : string1, string2, removeSpaces
'*** Outputs: None
'***
'*** Return : String Match Percentage???.
'**************************************************************************
'#Language "WWB-COM"
Public Function String_FuzzyMatch(ByVal a As String, ByVal b As String, removeSpaces As Boolean) As Double
If removeSpaces Then
a=Replace(a," ","")
b=Replace(b," ","")
End If
Dim length As Integer
length=Long_Max(Len(a),Len(b))
If length = 0 Then Return 0
Dim distance As Integer
distance=String_LevenshteinDistance(a, b)
Return CDbl(1.0 - (distance / length)^2)
End Function
Public Function String_LevenshteinDistance(a As String ,b As String) as Integer
'http://en.wikipedia.org/wiki/Levenshtein_distance
'Levenshtein distance between two strings, used for fuzzy matching
Dim i,j,cost,d,ins,del,subs As Integer
If Len(a) = 0 Then Return Len(b)
If Len(b) = 0 Then Return Len(a)
ReDim d(Len(a), Len(b))
For i = 0 To Len(a)
d(i, 0) = i
Next
For j = 0 To Len(b)
d(0, j) = j
Next
For i = 1 To Len(a)
For j = 1 To Len(b)
If Mid(a, i, 1) = Mid(b, j, 1) Then cost = 0 Else cost = 1 ' cost of substitution
del = ( d( i - 1, j ) + 1 ) ' cost of deletion
ins = ( d( i, j - 1 ) + 1 ) ' cost of insertion
subs = ( d( i - 1, j - 1 ) + cost ) 'cost of substition or match
d(i,j)=Long_Min(ins,Long_Min(del,subs))
Next
Next
Return d(Len(a), Len(b))
End Function
Public Function Long_Max(v1 As Long, v2 As Long) As Long
If v1 > v2 Then Return v1 Else Return v2
End Function
Public Function Long_Min(v1 As Long, v2 As Long) As Long
If v1 < v2 Then Return v1 Else Return v2
End Function
'***************************************************************************
'*** Name : String_FuzzyMatch
'*** Purpose: Performs a fuzzy match between two strings.
'*** Uses the Levenshtein Distance.
'*** Edited for KTM - Uses if instead of Return
'*** Inputs : string1, string2, removeSpaces
'*** Outputs: None
'***
'*** Return : String Match Percentage.
'**************************************************************************
Public Function String_FuzzyMatch(ByVal a As String, ByVal b As String, removeSpaces As Boolean) As Double
If removeSpaces Then
a=Replace(a," ","")
b=Replace(b," ","")
End If
Dim length As Integer
length=Long_Max(Len(a),Len(b))
If length = 0 Then
String_FuzzyMatch = 0
Exit Function
End If
Dim distance As Integer
distance=String_LevenshteinDistance(a, b)
String_FuzzyMatch= CDbl(1.0 - (distance / length)^2)
End Function
Public Function String_LevenshteinDistance(a As String ,b As String) As Integer
'http://en.wikipedia.org/wiki/Levenshtein_distance
'Levenshtein distance between two strings, used for fuzzy matching
Dim i,j,cost,d,ins,del,subs As Integer
If Len(a) = 0 Then
String_LevenshteinDistance = Len(b)
Exit Function
End If
If Len(b) = 0 Then
String_LevenshteinDistance = Len(a)
Exit Function
End If
ReDim d(Len(a), Len(b))
For i = 0 To Len(a)
d(i, 0) = i
Next
For j = 0 To Len(b)
d(0, j) = j
Next
For i = 1 To Len(a)
For j = 1 To Len(b)
If Mid(a, i, 1) = Mid(b, j, 1) Then cost = 0 Else cost = 1 ' cost of substitution
del = ( d( i - 1, j ) + 1 ) ' cost of deletion
ins = ( d( i, j - 1 ) + 1 ) ' cost of insertion
subs = ( d( i - 1, j - 1 ) + cost ) 'cost of substition or match
d(i,j)=Long_Min(ins,Long_Min(del,subs))
Next
Next
String_LevenshteinDistance = d(Len(a), Len(b))
End Function
Public Function Long_Max(v1 As Long, v2 As Long) As Long
If v1 > v2 Then
Long_Max = v1
Else
Long_Max = v2
End If
End Function
Public Function Long_Min(v1 As Long, v2 As Long) As Long
If v1 < v2 Then
Long_Min = v1
Else
Long_Min = v2
End If
End Function
'Check OLL existence & Log
Dim lTotDocs As Long
Dim k As Long
lTotDocs = pXRootFolder.GetTotalDocumentCount
For k = 0 To lTotDocs - 1
Dim oXDocInfo2 As CASCADELib.CscXDocInfo
Set oXDocInfo2 = pXRootFolder.GetDocInfoByGlobalIndex(i)
Dim XDocFilename As String
Dim OllFilename As String
Dim FDS As New FileSystemObject
'Dim TS As TextStream
XDocFilename = oXDocInfo2.XDocument.FileName
OllFilename = Left(XDocFilename, Len(XDocFilename)-3) + "oll"
If FDS.FileExists(OllFilename) Then
OutputDebugString "KfxKTM_OLLCheck: OLL File Detected for Document# " & CStr(k + 1)
End If
Next
Private Sub ValidationForm_AfterFieldChanged(ByVal pXDoc As CASCADELib.CscXDocument, ByVal pField As CASCADELib.CscXDocField)
' needed to avoid wrong data in green fields
' everytime, when a field is edited, it becomes dirty = not valid
' as consequence, it has to be validated once more
pField.Modified = True
pField.Valid = False
End Sub
Case "ShowAllTabs" '* Strg+F11
For i = 0 To ValidationForm.Tabs.Count - 1
ValidationForm.Tabs(i).Visible = True
Next
Case "btnShowScripting" '* Shift+Strg+F11
' only for test and development
Project.ShowScriptWindow("Project")
Project.ShowScriptWindow("Invoice")
Dim iFieldIndex As Integer ' debug, shows all unvalid fields
Dim sOutputString As String
sOutputString = "Not Valid fields:"
For iFieldIndex = 0 To ValidationForm.Fields.Count -1
Dim sName As String
sName = ValidationForm.Fields.ItemByIndex(iFieldIndex).FieldName
If pXDoc.Fields.ItemByName(sName).Valid = False Then
sOutputString = sOutputString & vbCrLf & sName
End If
Next
MsgBox sOutputString
Public Function SQL_CheckCondition(ByVal sTablename As String, _
ByVal sCondition As String) As Boolean
Dim conn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim sSQL As String
Dim bResult As Boolean
bResult = False
On Error GoTo Fehler
Set conn = New ADODB.Connection
conn.Open Project.ScriptVariables("Config_DatabaseConnString")
sSQL = "SELECT * from " & sTablename & " where " & sCondition
Set rs = conn.Execute (sSQL)
If (Not rs.EOF) And (Not rs.BOF) Then
' if we found any, then this combination is valid
' and we COULD retrieve one resultrow, in minimum
bResult = True
WriteLog("SQL_CheckCondition.log",sSQL)
Else
bResult = False
WriteLog("SQL_CheckCondition_fails.log",sSQL)
End If
Fehler:
On Error Resume Next
rs.Close
conn.Close
Set rs = Nothing
Set conn = Nothing
SQL_CheckCondition = bResult
End Function
'***************************************************************************
'*** Name : GetWordsMatchingRegex
'*** Purpose:
'*** Inputs :
'***
'*** Outputs: None.
'***
'*** Return : True/False.
'***************************************************************************
Public Function GetWordsMatchingRegex(regexPattern As String, ByVal pXDoc As CASCADELib.CscXDocument) As String
On Error GoTo ErrorHandler
' UNDER CONSTRUCTION
' 1 PAGE ONLY - TO BE BASED ON RANGE
' WORK TOWARDS RETURNING A XDOCFIELD OBJECT WITH ALTERNATIVES (IF MULTIPLE HITS EXIST)
' Use InitFromAlternative
OutputDebugString "KfxKTM_GetWordsMatchingRegex: Fired"
Dim bResult As Boolean
Dim i As Long
Dim oWord As CscXDocWord
For i = 0 To pXDoc.Pages.ItemByIndex(1).Words.Count - 1
Set oWord = pXDoc.Pages.ItemByIndex(1).Words.ItemByIndex(i)
bResult = DoesRegexPatternMatchString(regexPattern, oWord.Text)
If bResult = True Then
GetWordsMatchingRegex = oWord.Text
Exit For
End If
Next
Exit Function
ErrorHandler:
General_Error_Handler("GetWordsMatchingRegex", LOG_ERROR, DISPLAY_TO_USER)
End Function
Project.Databases.ItemByName(�yourdatabasename�). ImportDatabase(True)
'***************************************************************************
'*** Name : CreateOLLFiles
'*** Purpose: Creates Online Learning Files in the xDoc folder.
'***
'***
'*** Inputs : xDoc, SpecificIndicator, GenericIndicator1, GenericIndicator2, comments
'*** Outputs: None
'***
'*** Return : Nothing.
'**************************************************************************
Public Sub CreateOLLFiles(ByRef pXDoc As CASCADELib.CscXDocument, OLLSpecific As String, OLLGenericE As String, OLLGenericC As String, OLLComments As String)
On Error GoTo ErrorHandler
'* Create an online learning (OL) file To go With the XDoc
Dim XDocFilename As String
Dim OllFilename As String
Dim FDS As New FileSystemObject
Dim TS As TextStream
XDocFilename = pXDoc.FileName
OllFilename = Left(XDocFilename, Len(XDocFilename)-3) + "oll"
'If FDS.FileExists(OllFilename) Then
'MsgBox("OLL Exists")
'End If
Set TS = FDS.CreateTextFile(OllFilename, True, False)
TS.WriteLine("NTUser=" & Environ("USERNAME"))
TS.WriteLine("NTStation=" & Environ("COMPUTERNAME"))
TS.WriteLine("Classification=" & OLLGenericC)
TS.WriteLine("Extraction=" & OLLGenericE)
TS.WriteLine("Specific=" & OLLSpecific)
TS.WriteLine("Comment=" & OLLComments)
TS.Close
Exit Sub
ErrorHandler:
General_Error_Handler("CreateOLLFiles", LOG_ERROR, DISPLAY_TO_USER)
End Sub
'***************************************************************************
'*** Name : SuppressOCR
'*** Purpose: Creates Online Learning Files in the xDoc folder.
'***
'***
'*** Inputs : xDoc, SpecificIndicator, GenericIndicator1, GenericIndicator2, comments
'*** Outputs: None
'***
'*** Return : Nothing.
'**************************************************************************
Private Sub SuppressOCRBasic(ByRef pXDoc As CASCADELib.CscXDocument)
'Supress OCR on all pages except 1st, 2nd & last if page count is more than four
If pXDoc.CDoc.Pages.Count > 4 Then
Dim j As Long
For j = 2 To pXDoc.CDoc.Pages.Count - 2
pXDoc.CDoc.Pages(j).SuppressOCR = True
Next
End If
End Sub
'***************************************************************************
'*** Name : Document_BeforeProcessXDoc
'*** Purpose: Creates Online Learning Files in the xDoc folder.
'***
'***
'*** Inputs : xDoc, SpecificIndicator, GenericIndicator1, GenericIndicator2, comments
'*** Outputs: None
'***
'*** Return : Nothing.
'**************************************************************************
Private Sub SuppressOCRAdvanced(ByRef pXDoc As CASCADELib.CscXDocument)
LogMessage "WW: Document_BeforeProcessXDoc: Fired"
LogMessage "WW: Batch Name: " & CStr(pXDoc.ParentFolder.XValues("AC_BATCH_NAME"))
LogMessage "WW: Batch Dir.: " & CStr(pXDoc.ParentFolder.XValues("AC_BATCH_DIRECTORY"))
' Should any suppression be performed?
If Not Project.ScriptVariables.ItemByName("OCR_Suppress_Threshold").Value = "0" Then
LogMessage "WW: Suppres OCR enabled"
Dim iSkipOCRThreshold As Integer
Dim iRetainOCRStart As Integer
Dim iRetainOCREnd As Integer
iSkipOCRThreshold = CInt(Project.ScriptVariables.ItemByName("OCR_Suppress_Threshold").Value)
iRetainOCRStart = CInt(Project.ScriptVariables.ItemByName("OCR_Suppress_RetainStartPages").Value)
iRetainOCREnd = CInt(Project.ScriptVariables.ItemByName("OCR_Suppress_RetainEndPages").Value)
' Supress OCR on all pages except first X pages, and last Y pages if page count is more than Z.
If pXDoc.CDoc.Pages.Count > iSkipOCRThreshold Then
LogMessage "WW: Document page count is > Skip OCR Threshold"
LogMessage "WW: Total page count: " & CStr(pXDoc.CDoc.Pages.Count)
LogMessage "WW: Suppress OCR start page: " & CStr((iRetainOCRStart + 1))
LogMessage "WW: Suppress OCR end page: " & CStr((pXDoc.CDoc.Pages.Count - iRetainOCREnd))
Dim j As Long
For j = (iRetainOCRStart + 1) To (pXDoc.CDoc.Pages.Count - iRetainOCREnd) - 1
pXDoc.CDoc.Pages(j).SuppressOCR = True
LogMessage "WW: OCR suppressed for page: " & CStr(j - 1)
Next
End If
End If
End Sub
Private Sub ActivePONumber_Validate(ByVal pValItem As CASCADELib.ICscXDocValidationItem, ByRef ErrDescription As String, ByRef ValidField As Boolean)
On Error GoTo ErrorHandler
Dim asqueryValues(0) As String
Dim asqueryFields(0) As Long
Dim db As CscDatabase
Dim dbResults As CscDatabaseResItems
Dim iRecID As Long
Dim sRecordData() As String
'** First, if the PO number is blank, exit and return valid
If Trim$(pValItem.Text) = "" Then
ValidField = True
Exit Sub
End If
'** Assign PO number value
asqueryValues(0) = Trim$(pValItem.Text)
'** The column within the database
asqueryFields(0) = 0
'** Search the internal database
Set db = Project.Databases.ItemByName(AFR_ACTIVEPO)
Set dbResults = db.Search(asqueryValues, asqueryFields, CscQueryEvalMode.CscEvalMatchQuery, 5)
If dbResults.Count > 0 Then
iRecID = dbResults.Item(0).RecID
sRecordData = db.GetRecordData(iRecID)
If sRecordData(0) = asqueryValues(0) Then
ValidField = True
Else
ValidField = False
ErrDescription = "Invalid PO Number entered"
End If
Else
ValidField = False
ErrDescription = "Invalid PO Number entered"
End If
Exit Sub
ErrorHandler:
General_Error_Handler("SL_VendorByPO_LocateAlternatives", LOG_ERROR, DISPLAY_TO_USER)
End Sub
Public Function GetCountryCode(strSearchText As String) As String
'** Search for the ISO Country Code based on the given country name
Dim dict As CscDictionary
Dim resItems As CscDictionaryResItems
Dim dictResults As CscDatabaseResItem
Dim strData1 As String
Dim strReplaceVal As String
Dim i As Integer
'** Get Dictionary object from Project
Set dict = Project.Dictionaries.ItemByName(AFR_DICT_COUNTRIESCODES)
'** Search text from one field in dictionary
Set resItems = dict.Search(strSearchText, CscEvalMatchQuery, 1)
'** If the text was found in the dictionary, return the country code value
If resItems.Count > 0 Then
For i = 0 To resItems.Count - 1
dict.GetRecordData(resItems(i).RecID, strData1, strReplaceVal)
Next
Else
GetCountryCode = "Unknown"
End If
GetCountryCode = strReplaceVal
End Function
Private Sub RegionalAmountFormatter_FormatField(ByVal FieldText As String, ByRef FormattedText As String, ByRef ErrDescription As String, ByRef ValidFormat As Boolean)
Dim CountryCode As String
CountryCode = Trim$(GetCountryCode(strCacheSupplierCountry))
'MsgBox(CountryCode)
If Trim$(CountryCode) = "" Then CountryCode = AFR_DEFAULTCOUNTRYCODE
'MsgBox(CountryCode)
'** If an amount formatter exists for the current country code, use it
If Project.FieldFormatters.ItemExists("AmountFormatter" & CountryCode) Then
ValidFormat = Project.FieldFormatters.ItemByName("AmountFormatter" & CountryCode).FormatFieldText(FieldText, FormattedText, ErrDescription)
Else
'** Use a generic/default amount formatter
ValidFormat = Project.FieldFormatters.ItemByName("DefaultAmountFormatter").FormatFieldText(FieldText, FormattedText, ErrDescription)
End If
End Sub
Private Function RemoveSpecialCharacters (sString As String)
Dim sFormattedText As String
' remove special characters "^.~:'," from string
sFormattedText = Replace(sString, "^", "")
sFormattedText = Replace(sFormattedText, " ", "")
sFormattedText = Replace(sFormattedText, "~", "")
sFormattedText = Replace(sFormattedText, ":", "")
sFormattedText = Replace(sFormattedText, "'", "")
sFormattedText = Replace(sFormattedText, ".", "")
sFormattedText = Replace(sFormattedText, ",", "")
RemoveSpecialCharacters = sFormattedText
End Function
'*************************************************
' General_Error_Handler
'-------------------------------------------------
' Purpose:
' Inputs:
' sModuleName :Name of the module or function
' bLogError :True: Write it to Log file
' bDisplayToUser :True: Display the message in the msgbox (suppress the msgbox if in server mode)
' Outputs:
' Returns:
' Notes: :The err object is global, so no need to have it as a parameter
'*************************************************
Public Sub General_Error_Handler(sModuleName As String, bLogError As Boolean, bDisplayToUser As Boolean)
displayErrorMessage("Message: " & sModuleName & ". " & Err.Number & ": " & Err.Description, bLogError, bDisplayToUser)
End Sub
Private Sub displayErrorMessage(sMessage As String , bLogError As Boolean, bDisplayToUser As Boolean)
If bLogError Then
'write to error log file
If Not goInvoicePacksTools Is Nothing Then
goInvoicePacksTools.LogMessage(sMessage)
End If
End If
If ((bDisplayToUser) And (Project.ScriptExecutionMode <> CscScriptModeServer)) Then
'If the display to user flag is set then show it in a msgbox
'Suppress msgbox if the server is running
MsgBox(sMessage)
Else
'otherwise, raise an error for quality control module in the Ascent queue
Err.Raise(Err.Number, Err.Source, Err.Description ) 'this sends the batch to the quality control queue
End If
End Sub
Private Sub RegionalDateFormatter_FormatField(ByVal FieldText As String, ByRef FormattedText As String, ByRef ErrDescription As String, ByRef ValidFormat As Boolean)
Dim CountryCode As String
CountryCode = Trim$(GetCountryCode(strCacheSupplierCountry))
'MsgBox(CountryCode)
If Trim$(CountryCode) = "" Then CountryCode = AFR_DEFAULTCOUNTRYCODE
'MsgBox(CountryCode)
'** If a date formatter exists for the current country code, use it
If Project.FieldFormatters.ItemExists("DateFormatter" & CountryCode) Then
ValidFormat = Project.FieldFormatters.ItemByName("DateFormatter" & CountryCode).FormatFieldText(FieldText, FormattedText, ErrDescription)
Else
'** Use a generic/default date formatter
ValidFormat = Project.FieldFormatters.ItemByName("DefaultDateFormatter").FormatFieldText(FieldText, FormattedText, ErrDescription)
End If
End Sub
Private Sub SL_VendorByPO_LocateAlternatives(ByVal pXDoc As CASCADELib.CscXDocument, ByVal pLocator As CASCADELib.CscXDocField)
On Error GoTo ErrorHandler
Dim asqueryValues(0) As String
Dim asqueryFields(0) As Long
Dim db As CscDatabase
Dim dbResults As CscDatabaseResItems
Dim iResCount As Long
Dim iRecID As Long
Dim sRecordData() As String
'** If there are PO number results returned via one of the Regular Expressions, use it for the lookup
If pXDoc.Locators.ItemByName("SE_PONumber_Combined").Alternatives.Count > 0 Then
asqueryValues(0) = Trim$(pXDoc.Locators.ItemByName("SE_PONumber_Combined").Alternatives.ItemByIndex(0).Text)
'MsgBox asqueryValues(0)
End If
'** The column within the database
asqueryFields(0) = 0
'** Search the internal database
Set db = Project.Databases.ItemByName(AFR_ACTIVEPO)
Set dbResults = db.Search(asqueryValues, asqueryFields, CscQueryEvalMode.CscEvalMatchQuery, 5)
For iResCount = 0 To dbResults.Count - 1
iRecID = dbResults.Item(iResCount).RecID
sRecordData = db.GetRecordData(iRecID)
If sRecordData(0) = asqueryValues(0) Then
'MsgBox("Match! - " & sRecordData(1))
pLocator.Alternatives.Create
pLocator.Alternatives.ItemByIndex(0).Text = Trim$(sRecordData(1))
pLocator.Alternatives.ItemByIndex(0).Confidence = 0.9
End If
Next iResCount
Exit Sub
ErrorHandler:
General_Error_Handler("SL_VendorByPO_LocateAlternatives", LOG_ERROR, DISPLAY_TO_USER)
End Sub
Private Sub SL_VendorPOMatch_LocateAlternatives(ByVal pXDoc As CASCADELib.CscXDocument, ByVal pLocator As CASCADELib.CscXDocField)
On Error GoTo ErrorHandler
'** Compare the supplier ID returned from the SL_VendorByPO locator & the Vendor locator
'** If alternatives exists for the two locators
If pXDoc.Locators.ItemByName("SL_VendorByPO").Alternatives.Count > 0 And pXDoc.Locators.ItemByName("VL_AFREN_VENDOR").Alternatives.Count > 0 Then
'** Cache the Supplier Country value for formatting
strCacheSupplierCountry = Trim$(pXDoc.Locators.ItemByName("VL_AFREN_VENDOR").Alternatives(0).SubFields.ItemByName("Country").Text)
'** Compare the first alternative of each locator
If Trim$(pXDoc.Locators.ItemByName("SL_VendorByPO").Alternatives(0).Text) = Trim$(pXDoc.Locators.ItemByName("VL_AFREN_VENDOR").Alternatives(0).SubFields.ItemByName("SupplierCode").Text) Then
'** If they match, set the VL_AFREN_VENDOR SupplierCode subfield as confident (if not already).
If pXDoc.Locators.ItemByName("VL_AFREN_VENDOR").Alternatives(0).SubFields.ItemByName("SupplierCode").ExtractionConfident = False Then
pXDoc.Locators.ItemByName("VL_AFREN_VENDOR").Alternatives(0).SubFields.ItemByName("SupplierCode").ExtractionConfident = True
pXDoc.Locators.ItemByName("VL_AFREN_VENDOR").Alternatives(0).SubFields.ItemByName("SupplierCode").Confidence = 0.99
End If
End If
End If
Exit Sub
ErrorHandler:
General_Error_Handler("SL_VendorPOMatch_LocateAlternatives", LOG_ERROR, DISPLAY_TO_USER)
End Sub
'** Take a reference To the xdoc And the supplier id And populate validation fields With db search
Public Function LoadSupplierDetails(ByRef pXDoc As CASCADELib.CscXDocument, strSupplierID As String) As Boolean
On Error GoTo ErrorHandler
Dim asqueryValues(0) As String
Dim asqueryFields(0) As Long
Dim db As CscDatabase
Dim dbResults As CscDatabaseResItems
Dim iResCount As Long
Dim iRecID As Long
Dim sRecordData() As String
'** The SupplierID value returned from extraction, used tp query the Supplier DB
asqueryValues(0) = strSupplierID
'** The SupplierID column within the database we need to query
asqueryFields(0) = DBFIELD_SUPPLIER_ID
'** Search the internal Supplier database
Set db = Project.Databases.ItemByName(DBNAME_SUPPLIERS)
Set dbResults = db.Search(asqueryValues, asqueryFields, CscQueryEvalMode.CscEvalMatchQuery, 250)
'MsgBox (CStr(dbResults.Count))
For iResCount = 0 To dbResults.Count - 1
iRecID = dbResults.Item(iResCount).RecID
sRecordData = db.GetRecordData(iRecID)
If sRecordData(0) = asqueryValues(0) Then
pXDoc.Fields.ItemByName(FIELD_SUPPLIER_ENTITY).Text = sRecordData(1)
pXDoc.Fields.ItemByName(FIELD_SUPPLIER_NAME).Text = sRecordData(2)
pXDoc.Fields.ItemByName(FIELD_SUPPLIER_ADDRESS1).Text = sRecordData(3)
pXDoc.Fields.ItemByName(FIELD_SUPPLIER_ADDRESS2).Text = sRecordData(4)
pXDoc.Fields.ItemByName(FIELD_SUPPLIER_ADDRESS3).Text = sRecordData(5)
pXDoc.Fields.ItemByName(FIELD_SUPPLIER_ADDRESS4).Text = sRecordData(6)
pXDoc.Fields.ItemByName(FIELD_SUPPLIER_POSTTOWN).Text = sRecordData(7)
pXDoc.Fields.ItemByName(FIELD_SUPPLIER_COUNTY).Text = sRecordData(8)
pXDoc.Fields.ItemByName(FIELD_SUPPLIER_COUNTRY).Text = sRecordData(9)
pXDoc.Fields.ItemByName(FIELD_SUPPLIER_POSTALCODE).Text = sRecordData(10)
pXDoc.Fields.ItemByName(FIELD_SUPPLIER_TELEPHONE).Text = sRecordData(11)
pXDoc.Fields.ItemByName(FIELD_SUPPLIER_FAX).Text = sRecordData(12)
pXDoc.Fields.ItemByName(FIELD_SUPPLIER_EMAIL).Text = sRecordData(13)
pXDoc.Fields.ItemByName(FIELD_SUPPLIER_VAT).Text = sRecordData(14)
LoadSupplierDetails = True
Else
LoadSupplierDetails = False
End If
Next iResCount
Exit Function
ErrorHandler:
General_Error_Handler("LoadSupplierDetails", LOG_ERROR, DISPLAY_TO_USER)
End Function
'old change lable routine
Public Sub ChangeDisplayLabels (sLocale As String, bStaticInterface As Boolean)
On Error GoTo ErrorHandler
Dim fDocumentType As CscValidationField
'Dim asOptions(1) As String
If Not bStaticInterface = True Then
Select Case UCase(sLocale)
Case "DE-DE"
ValidationForm.Groups("grpSupplier").Text = "Lieferantendetails"
ValidationForm.Groups("grpInvoice").Text = "Rechnungsdetails"
ValidationForm.Labels("DocType").Text = "Dokumententype"
ValidationForm.Labels("SupID").Text = "Lieferant"
ValidationForm.Labels("SupName").Text = "Lieferantenadresse"
ValidationForm.Labels("InvNum").Text = "Rechnungsnummer"
ValidationForm.Labels("InvDate").Text = "Rechnungsdatum"
ValidationForm.Labels("PONo").Text = "Bestellnummer"
ValidationForm.Labels("Currency").Text = "W�hrung"
ValidationForm.Labels("NetAmount1").Text ="Nettosumme"
ValidationForm.Labels("TaxAmount1").Text = "Gesamtsteuer"
ValidationForm.Labels("Total").Text ="Gesamtsumme"
sDocumentType = "Rechnung;Gutschrift"
ValidationForm.Buttons("btnAlternatives").Text = "F9 - Alternativen"
ValidationForm.Buttons("btnSearch").Text = "F10 - Suche"
ValidationForm.Buttons("btnNoMatch").Text = "F11 - Nichts gefunden"
ValidationForm.Buttons("btnVersion").Text = "F11 - Versionsinformationen"
Case "EN-GB"
ValidationForm.Groups("grpSupplier").Text = "Supplier Details"
ValidationForm.Groups("grpInvoice").Text = "Invoice Details"
ValidationForm.Labels("DocType").Text = "Document Type"
ValidationForm.Labels("SupID").Text = "Supplier ID"
ValidationForm.Labels("SupName").Text = "Supplier Address"
ValidationForm.Labels("InvNum").Text = "Invoice Number"
ValidationForm.Labels("InvDate").Text = "Invoice Date"
ValidationForm.Labels("PONo").Text = "Purchase Order Number"
ValidationForm.Labels("Currency").Text = "Currency"
ValidationForm.Labels("NetAmount1").Text = "Net Amount"
ValidationForm.Labels("TaxAmount1").Text = "Tax Amount"
ValidationForm.Labels("Total").Text = "Total"
sDocumentType = "Invoice;Credit"
ValidationForm.Buttons("btnVersion").Text = "F11 - Version Information"
End Select
Else
'Set everything to English
ValidationForm.Groups("grpSupplier").Text = "Supplier Details"
ValidationForm.Groups("grpInvoice").Text = "Invoice Details"
ValidationForm.Labels("DocType").Text = "Document Type"
ValidationForm.Labels("SupID").Text = "Supplier ID and VAT"
ValidationForm.Labels("SupName").Text = "Supplier Name and Address"
ValidationForm.Labels("InvNum").Text = "Invoice Number"
ValidationForm.Labels("InvDate").Text = "Invoice Date"
ValidationForm.Labels("PONo").Text = "Purchase Order Number"
ValidationForm.Labels("Currency").Text = "Currency"
ValidationForm.Labels("NetAmount1").Text = "Net Amount"
ValidationForm.Labels("TaxAmount1").Text = "Tax Amount"
ValidationForm.Labels("Total").Text = "Total"
sDocumentType = "Invoice;Credit;Unknown"
'ValidationForm.Buttons("btnAlternatives").Text = "F9 - Alternatives"
'ValidationForm.Buttons("btnSearch").Text = "F10 - Search"
'ValidationForm.Buttons("btnNoMatch").Text = "F11 - No Match"
ValidationForm.Buttons("btnVersion").Text = "F11 - Version Information"
End If
Exit Sub
ErrorHandler:
General_Error_Handler("ChangeDisplayLabels", LOG_ERROR, DISPLAY_TO_USER)
End Sub
' Not needed?
Private Sub SL_Currency_LocateAlternatives(ByVal pXDoc As CASCADELib.CscXDocument, ByVal pLocator As CASCADELib.CscXDocField)
On Error GoTo ErrorHandler
'If no currency was detected, set the currency based upon the locale
Dim sCurrency As String
Dim locFL_Currency As CASCADELib.CscXDocField
Set locFL_Currency = pXDoc.Locators.ItemByName("FL_Currency")
If locFL_Currency.Alternatives.Count = 0 Then
'MsgBox ("NO CURRENCY")
If pXDoc.ExtractionClass = "en-GB" Then
sCurrency = "GBP"
ElseIf pXDoc.ExtractionClass = "da-DK" Then
sCurrency = "DKK"
ElseIf pXDoc.ExtractionClass = "de-DE" Then
sCurrency = "EUR"
ElseIf pXDoc.ExtractionClass = "en-US" Then
sCurrency = "USD"
ElseIf pXDoc.ExtractionClass = "fr-FR" Then
sCurrency = "EUR"
ElseIf pXDoc.ExtractionClass = "en-JP" Then
sCurrency = "JPY"
ElseIf pXDoc.ExtractionClass = "en-SG" Then
sCurrency = "SGD"
ElseIf pXDoc.ExtractionClass = "nb-NO" Then
sCurrency = "NOK"
ElseIf pXDoc.ExtractionClass = "sv-SE" Then
sCurrency = "SEK"
End If
locFL_Currency.Alternatives.Create
locFL_Currency.Alternatives(0).Text = sCurrency
locFL_Currency.Alternatives(0).Confidence = 0.90
End If
Exit Sub
ErrorHandler:
General_Error_Handler("SLDefaultTaxRate_LocateAlternatives", LOG_ERROR, DISPLAY_TO_USER)
End Sub
Private Sub SL_Supplier_RegExp_LocateAlternatives(ByVal pXDoc As CASCADELib.CscXDocument, ByVal pLocator As CASCADELib.CscXDocField)
On Error GoTo ErrorHandler
Dim iPONumberThreshold As Double
Dim iInvoiceNumberThreshold As Double
' Get the threshold values for the supplier po number and invoice number regexes
iInvoiceNumberThreshold = CDbl(Project.ScriptVariables.ItemByName("Threshold_SupplierInvoiceNumberRegex").Value) / 100
iPONumberThreshold = CDbl(Project.ScriptVariables.ItemByName("Threshold_SupplierPONumberRegex").Value) / 100
' First, does the Database Locator contains any alternatives?
If pXDoc.Locators.ItemByName(LOC_SUPPLIERS).Alternatives.Count > 0 Then
' Retrieve the Supplier PO NUMBER Regular Expression from the Database Locator
If pXDoc.Locators.ItemByName(LOC_SUPPLIERS).Alternatives.ItemByIndex(0).Confidence > iPONumberThreshold Then
pXDoc.Fields.ItemByName(FIELD_PO_NUMBER_REGEXP).Text = Trim$(pXDoc.Locators.ItemByName(LOC_SUPPLIERS).Alternatives.ItemByIndex(0).SubFields.ItemByIndex(DBFIELD_SUPPLIER_POREGEX).Text)
End If
' Retrieve the Supplier INVOICE NUMBER Regular Expression from the Database Locator
If pXDoc.Locators.ItemByName(LOC_SUPPLIERS).Alternatives.ItemByIndex(0).Confidence > iInvoiceNumberThreshold Then
pXDoc.Fields.ItemByName(FIELD_INVOICE_NUMBER_REGEXP).Text = Trim$(pXDoc.Locators.ItemByName(LOC_SUPPLIERS).Alternatives.ItemByIndex(0).SubFields.ItemByIndex(DBFIELD_SUPPLIER_INVOICEREGEX).Text)
End If
End If
Exit Sub
ErrorHandler:
General_Error_Handler("SL_Supplier_RegExp_LocateAlternatives", LOG_ERROR, DISPLAY_TO_USER)
End Sub
' used by STDCheckVATRates_Validate
Function DetermineCountrySettingsCountryID (ByVal pXDoc As CASCADELib.CscXDocument) As Long
Dim sCountryString As String
sCountryString = Replace(pXDoc.ExtractionClass,"_Valid","")
Select Case sCountryString
Case "Germany"
DetermineCountrySettingsCountryID = 0
Case "United States"
Case "France"
DetermineCountrySettingsCountryID = 2
Case "Spain"
DetermineCountrySettingsCountryID = 3
Case "United Kingdom"
DetermineCountrySettingsCountryID = 4
Case "Austria"
DetermineCountrySettingsCountryID = 5
Case "Belgium"
DetermineCountrySettingsCountryID = 6
Case "Bulgaria"
DetermineCountrySettingsCountryID = 7
Case "Czech Republic"
DetermineCountrySettingsCountryID = 8
Case "Denmark"
DetermineCountrySettingsCountryID = 9
Case "Estonia"
DetermineCountrySettingsCountryID = 10
Case "Finland"
DetermineCountrySettingsCountryID = 11
Case "Greece"
DetermineCountrySettingsCountryID = 12
Case "Hungary"
DetermineCountrySettingsCountryID = 13
Case "Ireland"
DetermineCountrySettingsCountryID = 14
Case "Italy"
DetermineCountrySettingsCountryID = 15
Case "Latvia"
DetermineCountrySettingsCountryID = 16
Case "Lithuania"
DetermineCountrySettingsCountryID = 17
Case "Luxembourg"
DetermineCountrySettingsCountryID = 18
Case "Malta"
DetermineCountrySettingsCountryID = 19
Case "Netherlands"
DetermineCountrySettingsCountryID = 20
Case "Norway"
DetermineCountrySettingsCountryID = 21
Case "Poland"
DetermineCountrySettingsCountryID = 22
Case "Portugal"
DetermineCountrySettingsCountryID = 23
Case "Romania"
DetermineCountrySettingsCountryID = 24
Case "Slovakia"
DetermineCountrySettingsCountryID = 25
Case "Slovenia"
DetermineCountrySettingsCountryID = 26
Case "Sweden"
DetermineCountrySettingsCountryID = 27
Case "Switzerland"
DetermineCountrySettingsCountryID = 28
Case "Cyprus" ' Zimbabwe used
DetermineCountrySettingsCountryID = 29
End Select
End Function
Private Sub Test_LocateAlternatives(ByVal pXDoc As CASCADELib.CscXDocument, ByVal pLocator As CASCADELib.CscXDocField)
Dim LocDef As CscLocatorDef
Dim LocDefMethod As CscGerAmountExtraction
Set LocDef = Project.ClassByName("Invoice").Locators.ItemByName("KBa")
Set LocDefMethod = LocDef.LocatorMethod
'LocDefMethod.ClearGeoIDs
End Sub
' ** Initial approach for removing alternatives
Private Sub SL_SupplierMatch_Boost_AddressExclusion_LocateAlternatives(ByVal pXDoc As CASCADELib.CscXDocument, ByVal pLocator As CASCADELib.CscXDocField)
On Error GoTo ErrorHandler
Dim iLocAltCounter As Long
Dim sSupplierID As String
Dim asRemoveAlt(10) As String
Dim iRemoveAltCounter As Long
Dim iAltIndex As Long
iRemoveAltCounter = 0
If pXDoc.Locators.ItemByName(LOC_SUPPLIERS).Alternatives.Count > 0 Then
For iLocAltCounter = 0 To pXDoc.Locators.ItemByName(LOC_SUPPLIERS).Alternatives.Count - 1
'If pXDoc.Locators.ItemByName(LOC_SUPPLIERS).Alternatives.ItemByIndex(iLocAltCounter).SubFields.ItemByIndex(DBFIELD_SUPPLIER_ID).Text = "293" Then
If ExcludedSupplier(pXDoc, Trim$(pXDoc.Locators.ItemByName(LOC_SUPPLIERS).Alternatives.ItemByIndex(iLocAltCounter).SubFields.ItemByIndex(DBFIELD_SUPPLIER_ID).Text), DBFIELD_SUPPLIER_ID_EXCLUDE, Project.Databases.ItemByName(DBNAME_SUPPLIERS_EXCLUDE)) = True Then
asRemoveAlt(iRemoveAltCounter) = CStr(iLocAltCounter)
MsgBox CStr(asRemoveAlt(iRemoveAltCounter))
iRemoveAltCounter = iRemoveAltCounter + 1
End If
Next
' Remove the unwanted alternatives
iRemoveAltCounter = 0
For iRemoveAltCounter = UBound(asRemoveAlt) To 0 Step -1
If asRemoveAlt(iRemoveAltCounter) <> "" Then
iAltIndex = iRemoveAltCounter
pXDoc.Locators.ItemByName(LOC_SUPPLIERS).Alternatives.Remove(iAltIndex)
End If
Next
End If
Exit Sub
ErrorHandler:
General_Error_Handler("SL_SupplierMatch_Boost_AddressExclusion_LocateAlternatives", LOG_ERROR, DISPLAY_TO_USER)
End Sub
Private Sub Test_LocateAlternatives(ByVal pXDoc As CASCADELib.CscXDocument, ByVal pLocator As CASCADELib.CscXDocField)
Dim locMethod As CscGerAmountExtraction
Dim LocInstance As CscLocatorDef
Dim j As Long ' Counter for stepping through the locator regex definitions
'Load the regular expression format locator
Set LocInstance = Project.BaseClasses.ItemByName(BASE_CLASS).Locators.ItemByName("KBa")
Set locMethod = LocInstance.LocatorMethod
'locMethod.AddCurrency("ASS","ARSE")
Project.ClassByName(BASE_CLASS).Locators.ItemByName("kba").
For j = 0 To locMethod.GetCurrencyCount - 1
MsgBox locMethod.GetCurrency(j).Result
Next
End Sub
' quick way to check field threshold.
' Check to see if the current supplier match has already passed the minimum confidence levels required by the Supplier ID field.
If pXDoc.Locators.ItemByName(LOC_SUPPLIERS).Alternatives.ItemByIndex(0).Confidence > Project.ClassByName(BASE_CLASS).Fields.ItemByName(FIELD_SUPPLIER_ID).LocatorThreshold Then
Exit Sub
Else
' Interesting for future use
Private Sub SL_Suppliers_LocateAlternatives(ByVal pXDoc As CASCADELib.CscXDocument, ByVal pLocator As CASCADELib.CscXDocField)
On Error GoTo ErrorHandler
' ** Alternatives from the Suppliers Database Locator are copied to new alternatives.
' ** The new alternatives are then interrogated and enhanced where required.
Dim pLocator_DB_Suppliers As CASCADELib.CscXDocField
Set pLocator_DB_Suppliers = pXDoc.Locators.ItemByName("DB_Suppliers")
Dim iAltCount As Integer
Dim iSubfieldCount As Integer
Dim oSubField As CscXDocSubField
If pLocator_DB_Suppliers.Alternatives.Count > 0 Then
For iAltCount = 0 To pLocator_DB_Suppliers.Alternatives.Count -1
' Create a new alternative
pLocator.Alternatives.Create
For iSubfieldCount = 0 To pLocator_DB_Suppliers.Alternatives.ItemByIndex(iAltCount).SubFields.Count - 1
Set oSubField = pLocator_DB_Suppliers.Alternatives.ItemByIndex(iAltCount).SubFields.ItemByIndex(iSubfieldCount)
If pLocator.Alternatives.ItemByIndex(iAltCount).SubFields.Exists(oSubField.Name) = False Then
pLocator.Alternatives.ItemByIndex(iAltCount).SubFields.Create(oSubField.Name)
End If
' Copy subfield properties
CopySubFieldToSubField(oSubField, pLocator.Alternatives.ItemByIndex(iAltCount).SubFields.ItemByName(oSubField.Name))
Next
' Copy the alternative properties
CopyAlternativeToAlternative(pLocator_DB_Suppliers.Alternatives.ItemByIndex(iAltCount), pLocator.Alternatives.ItemByIndex(iAltCount))
Next
End If
Exit Sub
ErrorHandler:
General_Error_Handler("SL_Suppliers_LocateAlternatives", LOG_ERROR, DISPLAY_TO_USER)
End Sub
'old
Private Sub Document_AfterClassifyXDoc(ByRef pXDoc As CASCADELib.CscXDocument)
On Error GoTo ErrorHandler
Dim sInvoiceRegExp As String
Dim sPORegExp As String
Dim oInvoicePacksClassifier As Scansation_InvoiceBase.Classifier
' Set oInvoicePacksClassifier = New Scansation_InvoiceBase.Classifier
' oInvoicePacksClassifier.Initialise(GetProjectFolderPath)
' If Not oInvoicePacksClassifier Is Nothing Then
'This call attempt to classify the document based on results of the db_locator. The DocLocale and Supplier ID field will be set by the classifier
'and the invoice number and po number regular expressions (if present for the supplier), are returned.
' oInvoicePacksClassifier.ClassifyByDBLocator(Project, pXDoc, sInvoiceRegExp, sPORegExp, FIELD_DOC_LOCALE, FIELD_SUPPLIER_ID, "DB_Locator")
'Assign the returned values for sPORegExp and sInvoiceRegExp to project level fields
' pXDoc.Fields.ItemByName(FIELD_INVOICE_NUMBER_REGEXP).Text = sInvoiceRegExp
' pXDoc.Fields.ItemByName(FIELD_PO_NUMBER_REGEXP).Text = sPORegExp
' End If
Exit Sub
ErrorHandler:
General_Error_Handler("Document_AfterClassifyXDoc", LOG_ERROR, DISPLAY_TO_USER)
End Sub
'old document loaded event
Private Sub ValidationForm_DocumentLoaded(ByRef pXDoc As CASCADELib.CscXDocument)
On Error GoTo ErrorHandler
Dim sSupplierID As String
Dim asResult() As String
Dim sDocLocale As String
Dim i As Integer
'TEMP_DOCLOCALE_VENDORDB = ""
CACHE_SUPPLIER_REGION = Trim$(pXDoc.Fields.ItemByName(FIELD_SUPPLIER_REGION).Text)
'set up the tools to be used
'necessary because any earlier instance of Scansation_InvoiceUtils.Tools will be lost when loading the validation module
Set goInvoicePacksClassifier = New Scansation_InvoiceBase.Classifier
goInvoicePacksClassifier.Initialise(GetProjectFolderPath)
Set goInvoicePacksTools = New Scansation_InvoiceUtils.Tools
goInvoicePacksTools.Initialise(GetProjectFolderPath)
'setup the validation form appearance, this should always be first
SetupValidationForm(pXDoc)
'check that a supplier code has been found
sSupplierID = pXDoc.Fields.ItemByName(FIELD_SUPPLIER_ID).Text
If Not goInvoicePacksTools Is Nothing And Not goInvoicePacksClassifier Is Nothing Then
If sSupplierID <> "" Then
asResult = goInvoicePacksClassifier.GetRecordFromCriteria(Project, sSupplierID, DBFIELD_SUPPLIER_ID, DBNAME_SUPPLIERS)'this may return 'nothing' (i.e. null)
'load the details for the given supplier code
If LoadSupplierDetails(pXDoc, asResult) = False Then
pXDoc.Fields.ItemByName(FIELD_SUPPLIER_ID).Valid = True
End If
'Remember the supplier ID for later comparison
TEMP_SUPPLIERID = pXDoc.Fields.ItemByName(FIELD_SUPPLIER_ID).Text
'Remember the DocLocale value for later comparison
'TEMP_DOCLOCALE_EXTRACTIONCLASS = pXDoc.ExtractionClass
'if supplier id has come through unconfident, set error message
If pXDoc.Fields.ItemByName(FIELD_SUPPLIER_ID).ExtractionConfident = False Then
pXDoc.Fields.ItemByName(FIELD_SUPPLIER_ID).ErrorDescription = GetLocalisedMessage("ErrDescription_SupplierID_Unconfident", GetLocalisation)
End If
Else
pXDoc.Fields.ItemByName(FIELD_SUPPLIER_ID).Valid = False
End If
End If
Exit Sub
ErrorHandler:
General_Error_Handler("ValidationForm_DocumentLoaded", LOG_ERROR, DISPLAY_TO_USER)
End Sub
'old
Private Sub ValidationForm_AfterFieldConfirmed(ByRef pXDoc As CASCADELib.CscXDocument, ByRef pField As CASCADELib.CscXDocField)
On Error GoTo ErrorHandler
'check the name of the field thats been confirmed
Select Case pField.Name
Case FIELD_SUPPLIER_ID
'Check if the supplier ID has changed since the document was loaded
If pField.Text <> TEMP_SUPPLIERID Then
'if search shortcut field, do database search with contents (if not blank)
If pField.Text <> "" Then
Dim g_FuzzySearch As New DatabaseDialog.DBLookupFuzzy
Dim asResult() As String
Dim asInitialQuery(0) As String
'set the header of the dialog box
g_FuzzySearch.DialogCaption = "Database Locator - Fuzzy"
g_FuzzySearch.GroupBoxCaption = "Supplier Lookup - Fuzzy Search Results"
asInitialQuery(0) = pField.Text
g_FuzzySearch.InitialQueryVals = asInitialQuery
g_FuzzySearch.SearchImmediately = True
'asResult contains array of all fields for the chosen result
asResult = g_FuzzySearch.ShowDialog (Project.Databases.ItemByName(DBNAME_SUPPLIERS), 10)
'update validation form with the record details
If UBound(asResult) >= 0 Then
If LoadSupplierDetails(pXDoc, asResult) = True Then
pXDoc.Fields.ItemByName(FIELD_SUPPLIER_ID).Valid = True
Else
pXDoc.Fields.ItemByName(FIELD_SUPPLIER_ID).Text = ""
pXDoc.Fields.ItemByName(FIELD_SUPPLIER_ID).Valid = False
End If
Else
pXDoc.Fields.ItemByName(FIELD_SUPPLIER_ID).Text = ""
pXDoc.Fields.ItemByName(FIELD_SUPPLIER_ID).Valid = False
End If
End If
End If
End Select
Exit Sub
ErrorHandler:
General_Error_Handler("ValidationForm_AfterFieldConfirmed", LOG_ERROR, DISPLAY_TO_USER)
End Sub
Private Sub STDDeliveryDateInvoicDateCheck_Validate(ByVal ValItems As CASCADELib.CscXDocValidationItems, ByVal pXDoc As CASCADELib.CscXDocument, ByRef ErrDescription As String, ByRef ValidField As Boolean)
Dim oSTD_InvoiceDate As ICscXDocValidationItem
Dim oSTD_TaxPoint As ICscXDocValidationItem
'you have to assign a date formatter for each field where you want to use the .DateValue property
Set oSTD_InvoiceDate = ValItems.Item("STD_InvoiceDate")
Set oSTD_TaxPoint = ValItems.Item("STD_TaxPoint")
' enter your own validation rule here
If Trim(oSTD_InvoiceDate.Text) <> "" And Trim(oSTD_TaxPoint.Text) <> "" Then
If (oSTD_InvoiceDate.DateValue >= oSTD_TaxPoint.DateValue) Then
ValidField = True
Else
ValidField = False
ErrDescription = Project.ScriptVariables.ItemByName("STDDeliveryDateInvoicDateCheck_Validate").Value
End If
End If
End Sub
Private Sub STDInvoiceDateCheckE04R05_Validate(ByVal ValItems As CASCADELib.CscXDocValidationItems, ByVal pXDoc As CASCADELib.CscXDocument, ByRef ErrDescription As String, ByRef ValidField As Boolean)
Dim oInvDate As ICscXDocValidationItem
Dim dToday As Date
dToday = Format(Now,"ddddd")
'you have to assign a date formatter for each field where you want to use the .DateValue property
Set oInvDate = ValItems.Item("InvDate")
UpdateReasonTable(pXDoc,"EXCEPTION", "E04",False)
UpdateReasonTable(pXDoc,"REJECTION", "R05",False)
' exception E04
If dToday - oInvDate.DateValue > 360 Then
ValidField = False
ErrDescription = Project.ScriptVariables.ItemByName("sExceptionE04").Value & " " & Project.ScriptVariables.ItemByName("STDException").Value
UpdateReasonTable(pXDoc,"EXCEPTION", "E04",True)
' rejection R05
ElseIf dToday - oInvDate.DateValue < 0 Then
ValidField = False
ErrDescription = Project.ScriptVariables.ItemByName("sRejectionR05").Value & " " & Project.ScriptVariables.ItemByName("STDRejection").Value
UpdateReasonTable(pXDoc,"REJECTION", "R05",True)
Else
ValidField = True
End If
End Sub
Private Sub InvoiceAmountsGroup1_Validate(ByVal ValItems As CASCADELib.CscXDocValidationItems, ByVal pXDoc As CASCADELib.CscXDocument, ByRef ErrDescription As String, ByRef ValidField As Boolean)
On Error GoTo ErrorHandler
Dim oNetAmount1 As ICscXDocValidationItem
Dim oTaxAmount1 As ICscXDocValidationItem
Dim oTaxRate1 As ICscXDocValidationItem
Dim dblTaxCalc As Double
Dim dblTolerance As Double
' Fields must be assigned with an amount formatter for each field where you want to use the .DoubleValue property
Set oNetAmount1 = ValItems.Item("NetAmount1")
If oNetAmount1.DoubleFormatted = False Then
ValidField = False
ErrDescription = "NetAmount1 not formatted"
Exit Sub
End If
Set oTaxAmount1 = ValItems.Item("TaxAmount1")
If oTaxAmount1.DoubleFormatted = False Then
ValidField = False
ErrDescription = "TaxAmount1 not formatted"
Exit Sub
End If
Set oTaxRate1 = ValItems.Item("TaxRate1")
If oTaxRate1.DoubleFormatted = False Then
ValidField = False
ErrDescription = "TaxRate1 not formatted"
Exit Sub
End If
dblTaxCalc = Round(oNetAmount1.DoubleValue * (oTaxRate1.DoubleValue/100), 2)
dblTolerance = CDbl(Project.ScriptVariables.ItemByName("Validate_InvoiceAmountsGroup1Tolerance").Value)
' Check NetAmount 1, TaxAmount 1 TaxRate 1 combination
If Abs(Round(dblTaxCalc - oTaxAmount1.DoubleValue, 2)) > dblTolerance Then
ValidField = False
ErrDescription = GetLocalisedMessage("ErrDescription_InvoiceAmountsGroup1_Invalid", GetLocalisation) & " (Tolerance=" & dblTolerance & ")"
Else
ValidField = True
End If
Exit Sub
ErrorHandler:
General_Error_Handler("InvoiceAmountsGroup1_Validate", LOG_ERROR, DISPLAY_TO_USER)
End Sub
Private Sub InvoiceAmountsGroup2_Validate(ByVal ValItems As CASCADELib.CscXDocValidationItems, ByVal pXDoc As CASCADELib.CscXDocument, ByRef ErrDescription As String, ByRef ValidField As Boolean)
On Error GoTo ErrorHandler
Dim oNetAmount2 As ICscXDocValidationItem
Dim oTaxAmount2 As ICscXDocValidationItem
Dim oTaxRate2 As ICscXDocValidationItem
Dim dblTaxCalc As Double
Dim dblTolerance As Double
' Fields must be assigned with an amount formatter for each field where you want to use the .DoubleValue property
Set oNetAmount2 = ValItems.Item("NetAmount2")
If oNetAmount2.DoubleFormatted = False Then
ValidField = False
ErrDescription = "NetAmount2 not formatted"
Exit Sub
End If
Set oTaxAmount2 = ValItems.Item("TaxAmount2")
If oTaxAmount2.DoubleFormatted = False Then
ValidField = False
ErrDescription = "TaxAmount2 not formatted"
Exit Sub
End If
Set oTaxRate2 = ValItems.Item("TaxRate2")
If oTaxRate2.DoubleFormatted = False Then
ValidField = False
ErrDescription = "TaxRate2 not formatted"
Exit Sub
End If
' Check NetAmount 2, TaxAmount 2 TaxRate 2 combination
dblTaxCalc = Round(oNetAmount2.DoubleValue * (oTaxRate2.DoubleValue/100), 2)
dblTolerance = CDbl(Project.ScriptVariables.ItemByName("Validate_InvoiceAmountsGroup2Tolerance").Value)
If Abs(Round(dblTaxCalc - oTaxAmount2.DoubleValue, 2)) > dblTolerance Then
ValidField = False
ErrDescription = GetLocalisedMessage("ErrDescription_InvoiceAmountsGroup2_Invalid", GetLocalisation) & " (Tolerance=" & dblTolerance & ")"
Else
ValidField = True
End If
Exit Sub
ErrorHandler:
General_Error_Handler("InvoiceAmountsGroup2_Validate", LOG_ERROR, DISPLAY_TO_USER)
End Sub
Private Sub InvoiceAmountsTotals_Validate(ByVal ValItems As CASCADELib.CscXDocValidationItems, ByVal pXDoc As CASCADELib.CscXDocument, ByRef ErrDescription As String, ByRef ValidField As Boolean)
On Error GoTo ErrorHandler
Dim oNetAmount1 As ICscXDocValidationItem
Dim oTaxAmount1 As ICscXDocValidationItem
Dim oNetAmount2 As ICscXDocValidationItem
Dim oTaxAmount2 As ICscXDocValidationItem
Dim oTotal As ICscXDocValidationItem
'you have to assign an amount formatter for each field where you want to use the .DoubleValue property
Set oNetAmount1 = ValItems.Item("NetAmount1")
If oNetAmount1.DoubleFormatted = False Then
ValidField = False
ErrDescription = "NetAmount1 not formatted"
Exit Sub
End If
Set oTaxAmount1 = ValItems.Item("TaxAmount1")
If oTaxAmount1.DoubleFormatted = False Then
ValidField = False
ErrDescription = "TaxAmount1 not formatted"
Exit Sub
End If
Set oNetAmount2 = ValItems.Item("NetAmount2")
If oNetAmount2.DoubleFormatted = False Then
ValidField = False
ErrDescription = "NetAmount2 not formatted"
Exit Sub
End If
Set oTaxAmount2 = ValItems.Item("TaxAmount2")
If oTaxAmount2.DoubleFormatted = False Then
ValidField = False
ErrDescription = "TaxAmount2 not formatted"
Exit Sub
End If
Set oTotal = ValItems.Item("Total")
If oTotal.DoubleFormatted = False Then
ValidField = False
ErrDescription = "Total not formatted"
Exit Sub
End If
' Check that all net amounts + vat amounts = Total amount
If (oNetAmount1.DoubleValue + oTaxAmount1.DoubleValue + oNetAmount2.DoubleValue + oTaxAmount2.DoubleValue = oTotal.DoubleValue) Then
ValidField = True
Else
ValidField = False
ErrDescription = GetLocalisedMessage("ErrDescription_InvoiceAmountsTotals_Invalid", GetLocalisation)
End If
Exit Sub
ErrorHandler:
General_Error_Handler("InvoiceAmountsTotals_Validate", LOG_ERROR, DISPLAY_TO_USER)
End Sub
' old vat number locator regex update routine
'Loop through available EU VAT Number regular Expressions, and disable those that are not relavent to the current supplier region
Public Sub doEUvatNumUpdate(sRegion As String)
On Error GoTo ErrorHandler
'Loop through the Regular Expressions
Dim Loc As CscLocatorDef
Dim locft As CscRegExpLib.CscRegExpLocator
Dim iRegexCounter As Integer
Set Loc = Project.BaseClasses.ItemByName(BASE_CLASS).Locators.ItemByName(LOC_EU_VATNUMBER)
Set locft = Loc.LocatorMethod
For iRegexCounter = 0 To locft.RegularExpressions.Count - 1
If Trim$(locft.RegularExpressions.ItemByIndex(iRegexCounter).Description) = sRegion Then
locft.RegularExpressions.ItemByIndex(iRegexCounter).Enabled = True
Else
locft.RegularExpressions.ItemByIndex(iRegexCounter).Enabled = False
End If
Next
Exit Sub
ErrorHandler:
General_Error_Handler("doEUvatNumUpdate", LOG_ERROR, DISPLAY_TO_USER)
End Sub
'old copy routines
Private Sub CopySubFieldToSubField(ByVal oSubFieldSource As ICscXDocSubField, ByVal oSubFieldTarget As ICscXDocSubField)
On Error GoTo ErrorHandler
oSubFieldTarget.Confidence = oSubFieldSource.Confidence
oSubFieldTarget.Height = oSubFieldSource.Height
oSubFieldTarget.Left = oSubFieldSource.Left
oSubFieldTarget.LongTag = oSubFieldSource.LongTag
oSubFieldTarget.PageIndex = oSubFieldSource.PageIndex
oSubFieldTarget.StringTag = oSubFieldSource.StringTag
oSubFieldTarget.Text = oSubFieldSource.Text
oSubFieldTarget.Top = oSubFieldSource.Top
oSubFieldTarget.Width = oSubFieldSource.Width
Exit Sub
ErrorHandler:
General_Error_Handler("CopySubFieldToSubField", LOG_ERROR, DISPLAY_TO_USER)
End Sub
Private Sub CopyAlternativeToAlternative(ByVal oAlternativeSource As ICscXDocFieldAlternative, ByVal oAlternativeTarget As ICscXDocFieldAlternative)
On Error GoTo ErrorHandler
oAlternativeTarget.Confidence = oAlternativeSource.Confidence
oAlternativeTarget.Height = oAlternativeSource.Height
oAlternativeTarget.Left = oAlternativeSource.Left
oAlternativeTarget.LongTag = oAlternativeSource.LongTag
oAlternativeTarget.PageIndex = oAlternativeSource.PageIndex
oAlternativeTarget.StringTag = oAlternativeSource.StringTag
oAlternativeTarget.Text = oAlternativeSource.Text
oAlternativeTarget.Top = oAlternativeSource.Top
oAlternativeTarget.Width = oAlternativeSource.Width
Exit Sub
ErrorHandler:
General_Error_Handler("CopyAlternativeToField", LOG_ERROR, DISPLAY_TO_USER)
End Sub
'Batch Open Example
Private Sub Batch_Open(ByVal pXRootFolder As CASCADELib.CscXFolder)
Select Case Project.ScriptExecutionMode
Case CscScriptModeServer, CscScriptModeServerDesign
Dim LocDef As CscLocatorDef
Dim LocDefMethod As CscGerAmountExtraction
Set LocDef = Project.ClassByName(BASE_CLASS).Locators.ItemByName("KBa")
Set LocDefMethod = LocDef.LocatorMethod
MsgBox CStr(LocDefMethod.GetCurrencyCount)
' Dim asSupportedCurrencies() As String
' Dim i As Integer
' Dim sCurrency As String
' asSupportedCurrencies = Split(Project.ScriptVariables.ItemByName("Extraction_Currency_SupportedValues").Value, ";")
' For i = 0 To UBound(asSupportedCurrencies)
' sCurrency = UCase(asSupportedCurrencies(i))
' MsgBox sCurrency
' Next
End Select
End Sub
'old currency code formatter (when i thought there was a bug with KBa)
Private Sub CurrencyFormatter_FormatField(ByVal FieldText As String, ByRef FormattedText As String, ByRef ErrDescription As String, ByRef ValidFormat As Boolean)
On Error GoTo ErrorHandler
'** Search for the currency abbreviation using field text
'** Return the replace text as formatted value
'** This formatter is required to overcome a problem with the KBa as well as a problem with the dictionary use within the FL_Currency locator
'** Abbreviations are retuned instead of the Result (in the case of the KBa) and the search text is returned instead of the replace text (in the case of the format locator)
Dim dict As CscDictionary
Dim resItems As CscDictionaryResItems
Dim strData1 As String
Dim strReplaceVal As String
FieldText = RemoveSpecialCharacters(FieldText)
'** Get Dictionary object from Project
Set dict = Project.Dictionaries.ItemByName("CurrencyCodesAbbreviations")
'** Search text from one field in dictionary
Set resItems = dict.Search(FieldText, CscEvalMatchQuery, 1)
'** If the text was found in the dictionary, return the replace text
If resItems.Count > 0 Then
dict.GetRecordData(resItems(0).RecID, strData1, strReplaceVal)
FormattedText = strReplaceVal
Else
FormattedText = FieldText
End If
Exit Sub
ErrorHandler:
General_Error_Handler("CurrencyFormatter_FormatField", LOG_ERROR, DISPLAY_TO_USER)
End Sub
Dim country As IronMountain_Ktm50_InvoicePack10.CountryData
Set country = IMTools.GetCountryByIso2("FR")
MsgBox "Friendly Name: " & country.friendlyName
MsgBox "GeoID: " & country.GeoID
MsgBox "ISO2: " & country.iso2
MsgBox "ISO3: " & country.iso3
MsgBox "Official Name: " & country.OfficialName
MsgBox CStr(Project.CountrySettings.ItemByGeoID(country.GeoID).TaxCount)
MsgBox CStr(Project.CountrySettings.ItemByGeoID(country.GeoID).GetTax(0))
MsgBox CStr(Project.CountrySettings.ItemByGeoID(country.GeoID).GetTax(1))
MsgBox CStr(Project.CountrySettings.ItemByGeoID(country.GeoID).GetTax(2))
Case "SupplierVAT"
Dim g_FuzzySearch As New DatabaseDialog.DBLookupFuzzy
Dim asResult() As String
Dim asInitialQuery(49) As String
g_FuzzySearch.DialogCaption = "Quick Search"
g_FuzzySearch.GroupBoxCaption = "Provider Information"
asInitialQuery(0) = Trim$(pField.Text)
g_FuzzySearch.InitialQueryVals = asInitialQuery
'g_FuzzySearch.SearchImmediately = True
g_FuzzySearch.StartColumn = 2
asResult = g_FuzzySearch.ShowDialog(Project.Databases.ItemByName(DBNAME_SUPPLIERS), 50)
MsgBox CStr(pXDoc.Fields.ItemByName("EUROVIA_LineItemData").Table.GetColumnSumByName("Total Price", True))
Dim vNetAmount1 As Variant
vNetAmount1 = CDec(ValItems.ItemByName("NetAmount1").Text)
MsgBox CStr(vNetAmount1)
MsgBox CStr(pXDoc.Fields.ItemByName("EUROVIA_LineItemData").Table.GetColumnSumByName("Total Price", True))
Private Sub ValidationForm_DocumentLoaded(ByRef pXDoc As CASCADELib.CscXDocument)
On Error GoTo ErrorHandler
Dim sSupplierID As String
Dim asResult() As String
Dim sDocLocale As String
Dim i As Integer
TEMP_DOCLOCALE_VENDORDB = ""
'set up the tools to be used
'necessary because any earlier instance of Scansation_InvoiceUtils.Tools will be lost when loading the validation module
Set goInvoicePacksClassifier = New Scansation_InvoiceBase.Classifier
goInvoicePacksClassifier.Initialise(GetProjectFolderPath)
Set goInvoicePacksTools = New Scansation_InvoiceUtils.Tools
goInvoicePacksTools.Initialise(GetProjectFolderPath)
'setup the validation form appearance, this should always be first
SetupValidationForm(pXDoc)
'check that a supplier code has been found
sSupplierID = pXDoc.Fields.ItemByName(FIELD_SUPPLIER_ID).Text
If Not goInvoicePacksTools Is Nothing And Not goInvoicePacksClassifier Is Nothing Then
If sSupplierID <> "" Then
asResult = goInvoicePacksClassifier.GetRecordFromCriteria(Project, sSupplierID, WPA_DBFIELD_SUPPLIER_ID, WPA_DBNAME_SUPPLIERS)'this may return 'nothing' (i.e. null)
'load the details for the given supplier code
If LoadSupplierDetails(pXDoc, asResult) = False Then
pXDoc.Fields.ItemByName(FIELD_SUPPLIER_ID).Valid = True
End If
'Remember the supplier ID for later comparison
TEMP_SUPPLIERID = pXDoc.Fields.ItemByName(FIELD_SUPPLIER_ID).Text
'Remember the DocLocale value for later comparison
TEMP_DOCLOCALE_EXTRACTIONCLASS = pXDoc.ExtractionClass
'if supplier id has come through unconfident, set error message
If pXDoc.Fields.ItemByName(FIELD_SUPPLIER_ID).ExtractionConfident = False Then
pXDoc.Fields.ItemByName(FIELD_SUPPLIER_ID).ErrorDescription = goInvoicePacksTools.GetLocalisedMessage("Supplier recognition not confident")
End If
Else
pXDoc.Fields.ItemByName(FIELD_SUPPLIER_ID).Valid = False
End If
End If
Exit Sub
ErrorHandler:
General_Error_Handler("ValidationForm_DocumentLoaded", LOG_ERROR, DISPLAY_TO_USER)
End Sub
'take a reference to the xdoc and the supplier id and populate validation fields with db search
Public Function LoadSupplierDetails(ByRef pXDoc As CASCADELib.CscXDocument, ByVal asRecord() As String) As Boolean
On Error GoTo ErrorHandler
If Not IsEmpty(asRecord) Then
'set the field to its associated value in the given array
'WPA Data Fields
pXDoc.Fields.ItemByName(FIELD_SUPPLIER_ID).Text = asRecord(WPA_DBFIELD_SUPPLIER_ID)
pXDoc.Fields.ItemByName(FIELD_SUPPLIER_NAME).Text = asRecord(WPA_DBFIELD_NAME)
pXDoc.Fields.ItemByName(FIELD_SUPPLIER_SURNAME).Text = asRecord(WPA_DBFIELD_SURNAME)
pXDoc.Fields.ItemByName(FIELD_SUPPLIER_ADDRESS1).Text = asRecord(WPA_DBFIELD_ADDRESS_1)
pXDoc.Fields.ItemByName(FIELD_SUPPLIER_ADDRESS2).Text = asRecord(WPA_DBFIELD_ADDRESS_2)
pXDoc.Fields.ItemByName(FIELD_SUPPLIER_POSTALCODE).Text = asRecord(WPA_DBFIELD_POSTAL_CODE)
TEMP_DOCLOCALE_VENDORDB = asRecord(STD_DBFIELD_LOCALE)
LoadSupplierDetails = True
Else
LoadSupplierDetails = False
End If
Exit Function
ErrorHandler:
General_Error_Handler("LoadSupplierDetails", LOG_ERROR, DISPLAY_TO_USER)
End Function
' ** Valid document routing
' ** Documents that have been rejected or have rejected pages will be routed go to QC.
' ** Valid documents in the batch will be routed to a bew batch to advance in the workflow as normal (and not be held up).
' ** Optionally use this over KC Partial Batch Export. Enabling both will cause unexpected behaviour.
If CloseMode = CscBatchCloseError And (Project.ScriptExecutionMode = CscScriptModeValidation Or Project.ScriptExecutionMode = CscScriptModeValidationDesign) Then
LogMessage "WW: CloseMode=Error & SciptExecution=Validation/ValidationDesign"
' If you want to advance valid documents where the batch is not entirely valid (one or more documents are invalid) then...
If Project.ScriptVariables.ItemByName("Project_AdvanceValidDocuments").Value = "True" And IsBatchValid(pXRootFolder) = False Then
LogMessage "WW: Post validation document routing enabled"
Dim lTotalDocuments As Long
Dim i As Long
lTotalDocuments = pXRootFolder.GetTotalDocumentCount
For i = 0 To lTotalDocuments - 1
Dim oXDocInfo As CASCADELib.CscXDocInfo
Set oXDocInfo = pXRootFolder.GetDocInfoByGlobalIndex(i)
'If Not IsDocumentRejected(oXDocInfo) = True Then
If IsDocumentValid(oXDocInfo) = True Then
' Get the batch name.
Dim strValidBatchName As String
strValidBatchName = pXRootFolder.XValues("AC_BATCH_NAME") & " - Advance Valid Documents"
' Route the document to a new batch
oXDocInfo.XValues.Set("KTM_DOCUMENTROUTING", "Valid")
' Assign a batch name for the new batch
pXRootFolder.XValues.Set("KTM_DOCUMENTROUTING_BATCHNAME_" & "Valid", strValidBatchName)
' Assign the batch to the KTM Learning Server Queue (the next logical queue for valid documents)
pXRootFolder.XValues.Set("KTM_DOCUMENTROUTING_QUEUE_" & "Valid", "KTM.KBLearningServer")
' Record that this document is a member of a child batch created at Validation
DocXValueSet(oXDocInfo.XDocument, "KTMValidation_SplitBatchMember", "True")
'MsgBox DocXValueGet(oXDocInfo.XDocument, "KTMValidation_SplitBatchMember")
End If
Next
End If
End If
Exit Sub
ErrorHandler:
General_Error_Handler("Batch_Close", LOG_ERROR, DISPLAY_TO_USER)
End Sub
Private Function IsDocumentRejected(oXDocInfo As CASCADELib.CscXDocInfo) As Boolean
LogMessage "WW: IsDocumentRejected: Fired"
IsDocumentRejected = False
If oXDocInfo.XValues.ItemExists("AC_REJECTED_DOCUMENT") Then
IsDocumentRejected = True
LogMessage "WW: Document rejection located"
Else
Dim nPageIndex As Long
For nPageIndex = 0 To oXDocInfo.PageCount - 1
If oXDocInfo.XValues.ItemExists("AC_REJECTED_PAGE" & CStr(nPageIndex + 1)) Then
IsDocumentRejected = True
LogMessage "WW: Page rejection located on page " & CStr(nPageIndex + 1)
End If
Next
End If
End Function
Private Function IsBatchValid(pXRootFolder As CASCADELib.CscXFolder) As Boolean
LogMessage "WW: IsBatchValid: Fired"
' Should the batch be treated as valid or invalid
' If any document is invalid then the batch must be invalid
IsBatchValid = True
Dim oXDocInfo As CASCADELib.CscXDocInfo
Dim lTotalDocuments As Long
Dim i As Long
lTotalDocuments = pXRootFolder.GetTotalDocumentCount
For i = 0 To lTotalDocuments - 1
Set oXDocInfo = pXRootFolder.GetDocInfoByGlobalIndex(i)
If IsDocumentValid(oXDocInfo) = False Then
IsBatchValid = False
End If
Next
LogMessage "WW: IsBatchValid: " & CStr(IsBatchValid)
End Function
Private Function IsDocumentValid(oXDocInfo As CASCADELib.CscXDocInfo) As Boolean
LogMessage "WW: IsDocumentValid: Fired"
IsDocumentValid = False
If oXDocInfo.XDocument.Valid = True Then
IsDocumentValid = True
LogMessage "WW: Document is Valid"
End If
End Function
Public Sub DocXValueSet(ByVal pXDoc As CASCADELib.CscXDocument, sKey As String, sValue As String)
LogMessage "WW: DocXValueSet: Fired"
pXDoc.XValues.Set(sKey, sValue)
LogMessage "WW: DocXValueSet: sKey=" & sKey & ", sValue=" & sValue
End Sub
Public Function DocXValueGet(ByVal pXDoc As CASCADELib.CscXDocument, sKey As String) As String
LogMessage "WW: DocXValueGet: Fired"
If pXDoc.XValues.ItemExists(sKey) Then
DocXValueGet = pXDoc.XValues.ItemByName(sKey).Value
End If
LogMessage "WW: DocXValueGet: Value=" & pXDoc.XValues.ItemByName(sKey).Value
End Function
Private Sub SL_SupplierMatch_Boost_OLL_LocateAlternatives(ByVal pXDoc As CASCADELib.CscXDocument, ByVal pLocator As CASCADELib.CscXDocField)
On Error GoTo ErrorHandler
LogMessage "WW: SL_SupplierMatch_Boost_OLL_LocateAlternatives: Fired"
If Project.ScriptVariables.ItemByName("SL_SupplierMatch_Boost_OLL").Value = "False" Then
' Indicate that the supplier ID confidence was NOT boosted by a Supplier ID match via the KBi group locator
CreateAlternative(pXDoc, pLocator, "0", 1)
Exit Sub
End If
' ** If the extracted supplier ID number (from the invoice group locator) matches the current supplier ID (DB Locator)
' ** If so, then the confidence of the current supplier match is increased by x%.
Dim bValidFormat As Boolean
Dim ErrDescription As String
Dim oSubField As CscXDocSubField
Dim oAlternative As CscXDocFieldAlternative
Dim iAltCounter As Integer
Dim iSubFieldCounter As Integer
Dim sKBi_SupplierID As String
Dim dblSupplierMatchConfidence As Double
Dim sCurrentSupplierID As String
Dim dblOLLBoost As Double
Dim sSupplierIDColumn As String
Dim bBoosted As Boolean
' If there are no alternatives to use, do nothing
If pXDoc.Locators.ItemByName(LOC_SUPPLIERS).Alternatives.Count = 0 Or pXDoc.Locators.ItemByName(LOC_KBI).Alternatives.Count = 0 Then
CreateAlternative(pXDoc, pLocator, "0", 1)
Exit Sub
End If
' Loop through all alternatives of the DB Locator
For iAltCounter = 0 To pXDoc.Locators.ItemByName(LOC_SUPPLIERS).Alternatives.Count - 1
Set oAlternative = pXDoc.Locators.ItemByName(LOC_SUPPLIERS).Alternatives.ItemByIndex(iAltCounter)
' Loop through all subfields of the DB Locator alternative
For iSubFieldCounter = 0 To oAlternative.SubFields.Count - 1
Set oSubField = oAlternative.SubFields.ItemByIndex(iSubFieldCounter)
' Get the database column index as defined in the PSV and compare to the current subfield (DB column) index
sSupplierIDColumn = Trim$(Project.ScriptVariables.ItemByName("DBFIELD_ColumnIndex_SupplierID").Value)
If oSubField.Index = CInt(sSupplierIDColumn) Then
' The correct column has been located so....
' Get extracted Supplier ID from the Invoice Group Locator and apply formatter
bValidFormat = Project.FieldFormatters.ItemByName("SupplierIDFormatter").FormatFieldText(Trim$(pXDoc.Locators.ItemByName(LOC_KBI).Alternatives.ItemByIndex(0).SubFields.ItemByName("VendorID").Text), sKBi_SupplierID, ErrDescription)
If bValidFormat = False Then GoTo ErrorHandler
' Get the current Supplier ID value and compare with SupplierID returned from the KBi
' If everything matches, increase the supplier match confidence
sCurrentSupplierID = oSubField.Text ' This value should already be formatted correctly
' RJA: 21/11/2012 - Added extra routine to cater for multiple supplier ID's in KB entry
' We need to check if the the KBi vendor ID value contains multiple ID's
' If a suppliers invoice is marked for OLL on multiple occasions with difference supplier ID's, these end up concatenated together in the KB entry
' In other scenarios two suppliers may share the same invoice template with little difference between them. This could also cause multiple supplier ID's for one KB entry
Dim asSupplierIDs() As String
Dim i As Integer
asSupplierIDs = Split(sKBi_SupplierID, ";") ' semi-colon denotes separation between supplier ID's
For i = 0 To UBound(asSupplierIDs)
If sCurrentSupplierID = Trim$(asSupplierIDs(i)) Then
' Get current supplier confidence and boost values
dblSupplierMatchConfidence = pXDoc.Locators.ItemByName(LOC_SUPPLIERS).Alternatives.ItemByIndex(0).Confidence
dblOLLBoost = CDbl(Project.ScriptVariables.ItemByName("Extraction_SupplierMatchBoost_OLL_SupplierID").Value) / 100
If dblOLLBoost + dblSupplierMatchConfidence > 1 Then
UpdateAlternativeConfidence(pXDoc, oAlternative, 1)
Else
UpdateAlternativeConfidence(pXDoc, oAlternative, dblSupplierMatchConfidence + dblOLLBoost)
End If
' Indicate that the supplier ID confidence was boosted by a Supplier ID match via the KBi group locator
bBoosted = True
End If
Next
' If sCurrentSupplierID = sKBi_SupplierID Then
' ' Get current supplier confidence and boost values
' dblSupplierMatchConfidence = pXDoc.Locators.ItemByName(LOC_SUPPLIERS).Alternatives.ItemByIndex(0).Confidence
' dblOLLBoost = CDbl(Project.ScriptVariables.ItemByName("Extraction_SupplierMatchBoost_OLL_SupplierID").Value) / 100
' If dblOLLBoost + dblSupplierMatchConfidence > 1 Then
' UpdateAlternativeConfidence(pXDoc, oAlternative, 1)
' Else
' UpdateAlternativeConfidence(pXDoc, oAlternative, dblSupplierMatchConfidence + dblOLLBoost)
' End If
' Indicate that the supplier ID confidence was boosted by a Supplier ID match via the KBi group locator
' bBoosted = True
' End If
End If
Next iSubFieldCounter
Next iAltCounter
If bBoosted = True Then
CreateAlternative(pXDoc, pLocator, "1", 1)
SUPPLIER_BOOST = True
Else
CreateAlternative(pXDoc, pLocator, "0", 1)
End If
Exit Sub
ErrorHandler:
General_Error_Handler("SL_SupplierMatch_Boost_OLL_LocateAlternatives", LOG_ERROR, DISPLAY_TO_USER)
End Sub
Private Sub VATNumberInvoiceNumberCheck_Validate(ByVal ValItems As CASCADELib.CscXDocValidationItems, ByVal pXDoc As CASCADELib.CscXDocument, ByRef ErrDescription As String, ByRef ValidField As Boolean)
On Error GoTo ErrorHandler
' ** MOY PARK Specific
If Trim$(ValItems.ItemByName("InvoiceNumber").Text) = "" And Trim$(ValItems.ItemByName("VATNumber").Text) = "" Then
ValidField = True
Exit Sub
End If
If Trim$(ValItems.ItemByName("InvoiceNumber").Text) = Trim$(ValItems.ItemByName("VATNumber").Text) Then
ValidField = False
ErrDescription = "The Invoice Number cannot match the VAT Number"
Else
ValidField = True
End If
Exit Sub
ErrorHandler:
General_Error_Handler("OrderNumberInvoiceNumberCheck_Validate", LOG_ERROR, DISPLAY_TO_USER)
End Sub
MOYInvoiceDater&InvoiceNumberCheck
Private Sub InvoiceDateInvoiceNumberCheck_Validate(ByVal ValItems As CASCADELib.CscXDocValidationItems, ByVal pXDoc As CASCADELib.CscXDocument, ByRef ErrDescription As String, ByRef ValidField As Boolean)
On Error GoTo ErrorHandler
' ** MOY PARK Specific
If Trim$(ValItems.ItemByName("InvoiceNumber").Text) <> "" And Trim$(ValItems.ItemByName("InvoiceDate").Text) <> "" Then
If Trim$(ValItems.ItemByName("InvoiceNumber").Text) = Trim$(ValItems.ItemByName("InvoiceDate").Text) Then
ValidField = False
ErrDescription = "The Invoice Number cannot match the Invoice Date"
Else
ValidField = True
End If
End If
Exit Sub
ErrorHandler:
General_Error_Handler("InvoiceDateInvoiceNumberCheck_Validate", LOG_ERROR, DISPLAY_TO_USER)
End Sub
Private Sub TESTVal_Validate(ByVal ValItems As CASCADELib.CscXDocValidationItems, ByVal pXDoc As CASCADELib.CscXDocument, ByRef ErrDescription As String, ByRef ValidField As Boolean)
Dim bValidFields As Boolean
bValidFields = True
Dim lField As Long
Dim asFields(5) As String
asFields(0) = FIELD_INVOICE_DATE
asFields(1) = FIELD_KTM_DOCUMENTID
asFields(2) = FIELD_INVOICE_NUMBER
asFields(3) = FIELD_DOCUMENT_TYPE
asFields(4) = FIELD_SUPPLIER_ID
asFields(5) = FIELD_TOTAL
For lField = 0 To UBound(asFields)
If pXDoc.Fields.ItemByName(asFields(lField)).Valid = False Then
bValidFields = False
End If
Next
If bValidFields = True Then
MsgBox "Perform QA check on Invoice Number"
If pXDoc.Fields.ItemByName(FIELD_INVOICE_NUMBER).Text = "" Then
Dim bQAResult As Boolean
MsgBox "Failed QA"
bQAResult = False
Else
bQAResult = True
End If
End If
If bQAResult = True Then
ValidField = True
Else
ValidField = False
pXDoc.Fields.ItemByName(FIELD_INVOICE_NUMBER).ErrorDescription = "TEST"
End If
End Sub
Private Sub TESTDiscount_Validate(ByVal ValItems As CASCADELib.CscXDocValidationItems, ByVal pXDoc As CASCADELib.CscXDocument, ByRef ErrDescription As String, ByRef ValidField As Boolean)
If ValItems.ItemByIndex(0).Text <> "" Then
MsgBox "Percentage: " & ValItems.ItemByIndex(0).Text
Dim vPercentage As Variant
vPercentage = CDec(ValItems.ItemByIndex(0).Text)
MsgBox "Value to reduce: " & pXDoc.Fields.ItemByName("CustomFormatter").Text
Dim vOriginalValue As Variant
vOriginalValue = CDec(pXDoc.Fields.ItemByName("CustomFormatter").Text)
MsgBox "Reduction of: " & CStr((vOriginalValue / 100) * vPercentage)
Dim vReduction As Variant
vReduction = (vOriginalValue / 100) * vPercentage
MsgBox "New Value: " & CStr(vOriginalValue - vReduction)
Dim vNewValue As Variant
vNewValue = GetFormattedAmount((vOriginalValue - vReduction), ErrDescription)
MsgBox "New Formatted Value: " & CStr(vNewValue)
pXDoc.Fields.ItemByName("CustomFormatter").Text = CStr(vNewValue)
End If
End Sub
Public Sub CopyAlternative(ByVal source As Kofax.Cascade.XDoc.CscXDocFieldAlternative,
ByVal destination As Kofax.Cascade.XDoc.CscXDocFieldAlternative)
If source Is Nothing Then Throw New ArgumentNullException("source")
If destination Is Nothing Then Throw New ArgumentNullException("destination")
' Copy basic properties.
destination.Confidence = source.Confidence
destination.Height = source.Height
destination.KeywordState = source.KeywordState
destination.Left = source.Left
destination.LongTag = source.LongTag
destination.PageIndex = source.PageIndex
destination.Source = source.Source
destination.StringTag = source.StringTag
destination.Text = source.Text
destination.Top = source.Top
destination.Width = source.Width
' Copy keywords into the new Keywords collection.
CopyKeywords(source.Keywords, destination.Keywords)
' Copy the sub-fields.
CopySubFields(source.SubFields, destination.SubFields)
' Copy words into the new words collection.
CopyWords(source.Words, destination.Words)
End Sub
'How to find the classification result in the XDoc:
If Not pXDoc.ClassificationResult Is Nothing Then
If pXDoc.ClassificationResult.FinalClassId(0) <> 0 Then
Name = Project.ClassByID(pXDoc.ClassificationResult.FinalClassId(0)).Name
End If
End If
Private Sub ImportDatabase()
Project.Databases.ItemByName(�yourdatabasename�). ImportDatabase(True)
End Sub
Project.ClassByName("MyClass").ValidateField pXDoc, pXDoc.Fields.ItemByName("MyField").Index
Private Sub Document_BeforeSeparatePages(ByVal pXDoc As CASCADELib.CscXDocument, ByRef bSkip As Boolean)
OutputDebugString "KfxKTM_Document_BeforeSeparatePages: Fired"
' SKIP IF YOU WANT TO PERFORM SEPARATION IN Document_AfterSeparatePages
' DO NOT SKIP IF YOU WANT TO PERFORM SEPARATION IN Document_SeparateCurrentPage
bSkip = True
' Optional Code
' Nothing
' Skip Check
If bSkip = True Then
OutputDebugString "KfxKTM_Document_BeforeSeparatePages: Core separation tasks (Layout and content based) will be skipped"
OutputDebugString "KfxKTM_Document_BeforeSeparatePages: Document_SeparateCurrentPage will not fire"
End If
End Sub
Private Sub Document_SeparateCurrentPage(ByVal pXDoc As CASCADELib.CscXDocument, ByVal PageNr As Long, ByRef bSplitPage As Boolean, ByRef RemainingPages As Long)
OutputDebugString "KfxKTM_Document_SeparateCurrentPage: Fired"
' THIS EVENT WILL NOT FIRE IF SEPARATION IS SKIPPED IN Document_BeforeSeparatePages
' THIS EVENT FIRES AFTER THE IMAGE CLASSIFIER, OCR AND CONTENT CLASSIFIER FUNCTIONS HAVE EXECUTED
' This routine should be skipped
'MsgBox "Document_SeparateCurrentPage"
' THIS APPROACH CAN BE USED TO SEPERATE BASED ON THE CONTENT OF THE IMAGE
' THIS APPROACH COPIES THE XDOC AND RUNS EXTRACTION ON A SPECIFIC CLASS
' Create a temporary document with a single page...
Dim SinglePageDoc As CscXDocument
Set SinglePageDoc = New CscXDocument
OutputDebugString "KfxKTM_Document_SeparateCurrentPage: Temporary xdocument created"
SinglePageDoc.CopyPages(pXDoc, PageNr, 1)
OutputDebugString "KfxKTM_Document_SeparateCurrentPage: Page " & CStr(PageNr) & " from source xdocument copied to temporary xdocument"
Project.ClassByName("DocSep").Extract SinglePageDoc
OutputDebugString "KfxKTM_Document_SeparateCurrentPage: Manual extraction executed on temporary xdocument using class 'DocSep'"
If SinglePageDoc.Fields.ItemByName("SEP_VALUE").Alternatives.Count > 0 Then
OutputDebugString "KfxKTM_Document_SeparateCurrentPage: Alternative for separation locator exists"
If DoesRegexPatternMatchString(Project.ScriptVariables.ItemByName("Project_Separation_Regex").Value, SinglePageDoc.Fields.ItemByName("SEP_VALUE").Alternatives.ItemByIndex(0).Text) = True Then
bSplitPage = True
OutputDebugString "KfxKTM_Document_SeparateCurrentPage: SplitOnPage " & CStr(PageNr)
End If
End If
End Sub
Private Sub Document_AfterSeparatePages(ByVal pXDoc As CASCADELib.CscXDocument)
OutputDebugString "KfxKTM_Document_AfterSeparatePages: Fired"
' THIS APPROACH CAN BE USED TO SEPARATE WITHOUT THE NEED OF THE IMAGE CLASSIFIER, OCR AND CONTENT CLASSIFIER FUNCTIONS
'OPTION 1
' pXDoc.CDoc.Pages(2).SplitPage = True
' pXDoc.CDoc.Pages(4).SplitPage = True
' pXDoc.CDoc.Pages(6).SplitPage = True
' pXDoc.CDoc.Pages(8).SplitPage = True
' pXDoc.CDoc.Pages(10).SplitPage = True
'OPTION2
' Dim i As Long
' For i = 0 To oLocator.Alternatives.Count - 1
' pXDoc.CDoc.Pages(i).SplitPage = True
' Next
'OPTION3
' THIS APPROACH CAN BE USED TO SEPARATE WITHOUT THE NEED OF OCR DATA (USING AZL)
'Create a temporary document with a single page...
Dim SinglePageDoc As CscXDocument
Set SinglePageDoc = New CscXDocument
OutputDebugString "KfxKTM_Document_AfterSeparatePages: Temporary xdocument created"
Dim i As Long
For i = 0 To pXDoc.CDoc.Pages.Count - 1
SinglePageDoc.CopyPages(pXDoc, i, 1)
OutputDebugString "KfxKTM_Document_AfterSeparatePages: Page " & CStr(i) & " from source xdocument copied to temporary xdocument"
Project.ClassByName("DocSep").Extract SinglePageDoc
OutputDebugString "KfxKTM_Document_AfterSeparatePages: Manual extraction executed on temporary xdocument using class 'DocSep'"
If SinglePageDoc.Fields.ItemByName("SEP_VALUE").Alternatives.Count > 0 Then
If DoesRegexPatternMatchString(Project.ScriptVariables.ItemByName("Project_Separation_Regex").Value, SinglePageDoc.Fields.ItemByName("SEP_VALUE").Alternatives.ItemByIndex(0).Text) = True Then
pXDoc.CDoc.Pages.ItemByIndex(i).SplitPage = True
OutputDebugString "KfxKTM_Document_AfterSeparatePages: SplitOnPage " & CStr(i)
End If
End If
Next
End Sub'Company Code
Private Sub SL_CompanyCode_LocateAlternatives(ByVal pXDoc As CASCADELib.CscXDocument, ByVal pLocator As CASCADELib.CscXDocField)
Select Case Project.ScriptExecutionMode
Case CscScriptModeServerDesign
pLocator.Alternatives.Create
pLocator.Alternatives.ItemByIndex(0).Text = "AFR025"
pLocator.Alternatives.ItemByIndex(0).Confidence = 1
' MsgBox pLocator.Alternatives.ItemByIndex(0).Text
Case CscScriptModeServer
pLocator.Alternatives.Create
pLocator.Alternatives.ItemByIndex(0).Text = Trim$(pXDoc.ParentFolder.XValues.ItemByName("AC_FIELD_Entity").Value)
pLocator.Alternatives.ItemByIndex(0).Confidence = 1
End Select
End Sub
Private Sub SL_LineItemCleanse_LocateAlternatives(ByVal pXDoc As CASCADELib.CscXDocument, ByVal pLocator As CASCADELib.CscXDocField)
On Error GoTo ErrorHandler
' ** EUROVIA Specific
Dim oLineItemsLocAlt As CscXDocFieldAlternative ' The table locator will only ever have one alternative
Dim oSuppDocIndex As CscXDocField ' The project field holding the supporting page start index
Dim oRow As CscXDocTableRow
Dim lRowCounter As Long
Dim lColumnCounter As Long
Set oLineItemsLocAlt = pXDoc.Locators.ItemByName(LOC_LINEITEMS).Alternatives.ItemByIndex(0)
Set oSuppDocIndex = pXDoc.Fields.ItemByName(FIELD_SUPPDOC_INDEX)
lRowCounter = 0
' ** If the supporting document page index value is greater than zero(supporting pages present in Xdocument) AND rows exists,
' ** we must check each row and remove any which fall on a supporting page
If CInt(oSuppDocIndex.Text) > 0 And oLineItemsLocAlt.Table.Rows.Count > 0 Then
While lRowCounter < oLineItemsLocAlt.Table.Rows.Count
Set oRow = oLineItemsLocAlt.Table.Rows.ItemByIndex(lRowCounter)
For lColumnCounter = 0 To oRow.Cells.Count - 1
' Does the cell have a valid page index?
If oRow.Cells.ItemByIndex(lColumnCounter).PageIndex <> -1 Then
If oRow.Cells.ItemByIndex(lColumnCounter).PageIndex >= CInt(oSuppDocIndex.Text) Then
oLineItemsLocAlt.Table.Rows.Remove(oRow.IndexInTable)
Exit For
End If
End If
Next
lRowCounter = lRowCounter + 1
Wend
End If
Exit Sub
ErrorHandler:
General_Error_Handler("SL_LineItemCleanse_LocateAlternatives", LOG_ERROR, DISPLAY_TO_USER)
End Sub
Private Sub SLTableChecker_LocateAlternatives(ByRef pXDoc As CASCADELib.CscXDocument, ByRef pLocator As CASCADELib.CscXDocField)
'Ensure that no table lines have been missed out; if they have, add an unconfident line where we think one might be missing.
Dim pTableLocator As CscXDocField
Set pTableLocator = pXDoc.Locators.ItemByName("LineItemData")
Call FlagMissingTableLines(pTableLocator)
End Sub
'*****************************************************************************************
'Sub FlagMissingTableLines
'*****************************************************************************************
'This function detects lines which may be missing from a table, adding blank (unconfident)
'lines to the table at the positions where it thinks a line may be missing.
'
'It does this by performing the following steps:
'1. Calculate the mean of the distances between table rows
'2. Calculate the standard deviation of the distances between table rows
'3. Any distances between table rows which are more than 2 standard deviations
' from the mean may indicate one or more missing rows.
'
'NOTE: This function should only be used with tables in which the lines are a
' constant height - tables with mixed-height lines cannot be evaluated using
' this method, since it's based on calculating the average line height.
'
' author: Stephen Bottomley 15-Aug-2008
'*****************************************************************************************
Sub FlagMissingTableLines(ByRef pTableLocator As CASCADELib.CscXDocField)
Dim pTable As CscXDocTable
Dim lInitialTableRowCount As Long
Dim lLine As Long, lPreviousPage As Long, lThisPage As Long, lPreviousLineY As Long
Dim lDistanceFromPreviousLine As Long
Dim lTotalLineDistance As Long, lLinesWithDistance As Long, dLineDistanceMean As Double
Dim dTotalLineDistanceDifferenceSquaredFromMean As Double, dLineDistanceStdDev As Double
Dim lLineOffsetDueToAddedRows As Long
'If there is no table, there is no work to do.
If pTableLocator.Alternatives.Count = 0 Then Exit Sub
Set pTable = pTableLocator.Alternatives(0).Table
lInitialTableRowCount = pTable.Rows.Count
'If there are no lines in the table, there is no work to do.
If lInitialTableRowCount = 0 Then Exit Sub
'Create a collection which contains information about table lines. The information
'stored in the "LineInfo" type is its page, whether it is the first line on a page
'and its distance from the previous line (if not the first line on a page)
ReDim aoLines(lInitialTableRowCount-1) As LineInfo
'Start by getting the page number and top Y coordinate of the first line of the table.
lPreviousPage = pTable.Rows.ItemByIndex(0).StartPage
lPreviousLineY = pTable.Rows.ItemByIndex(0).Top(lPreviousPage)
aoLines(0).IsFirstLineOnPage = True
aoLines(0).Page = lPreviousPage
'Store the distance of each line from its previous line -
'we'll later use this to calculate means and standard deviations.
For lLine = 1 To lInitialTableRowCount-1
lThisPage = pTable.Rows.ItemByIndex(lLine).StartPage
If lThisPage = lPreviousPage Then
'If we're still on the same page as the previous line, store our distance from that line.
lDistanceFromPreviousLine = pTable.Rows.ItemByIndex(lLine).Top(lThisPage) - lPreviousLineY
aoLines(lLine).IsFirstLineOnPage = False
aoLines(lLine).Page = lThisPage
aoLines(lLine).DistanceFromPreviousLine = lDistanceFromPreviousLine
Else
'If we've just crossed onto a new page, start calculating distance afresh.
lPreviousPage = lThisPage
aoLines(lLine).IsFirstLineOnPage = True
aoLines(lLine).Page = lThisPage
End If
'Update "previous line Y" measurement to refer to this line.
lPreviousLineY = pTable.Rows.ItemByIndex(lLine).Top(lPreviousPage)
Next 'Line
'Calculate the mean of the line distances.
lTotalLineDistance = 0
lLinesWithDistance = 0
For lLine = 1 To lInitialTableRowCount-1
If Not aoLines(lLine).IsFirstLineOnPage Then
lTotalLineDistance = lTotalLineDistance + aoLines(lLine).DistanceFromPreviousLine
lLinesWithDistance = lLinesWithDistance + 1
End If
Next 'Line
'We need at least 2 lines on at least 1 page in order to calculate an average line distance.
If lLinesWithDistance = 0 Then Exit Sub
dLineDistanceMean = lTotalLineDistance / lLinesWithDistance
'Calculate the standard deviation of the line distances.
For lLine = 1 To lInitialTableRowCount-1
If Not aoLines(lLine).IsFirstLineOnPage Then
dTotalLineDistanceDifferenceSquaredFromMean = dTotalLineDistanceDifferenceSquaredFromMean + _
((dLineDistanceMean - aoLines(lLine).DistanceFromPreviousLine) ^ 2)
End If
Next 'Line
'Standard deviation is defined as the square root of the average squared difference from the mean.
dLineDistanceStdDev = (dTotalLineDistanceDifferenceSquaredFromMean / lLinesWithDistance) ^ 0.5
'As we add dummy rows to the table, the 'real' table row will begin to drift from its
'previous index - keep a record of how many rows we've added so we can account for this.
lLineOffsetDueToAddedRows = 0
'Identify lines which have a distance from the previous line significantly greater than the standard deviation.
For lLine = 1 To lInitialTableRowCount-1
If Not aoLines(lLine).IsFirstLineOnPage Then
'If the distance between this line and the previous line is greater than two standard deviations
'from the average line distance, then we may have missed a line of the table here. Insert a
'dummy line into the table and update the line offset.
If (aoLines(lLine).DistanceFromPreviousLine - dLineDistanceMean) > (2 * dLineDistanceStdDev) Then
Call CreateDummyTableRow(pTable, lLine+lLineOffsetDueToAddedRows, aoLines(lLine).Page, dLineDistanceMean)
lLineOffsetDueToAddedRows = lLineOffsetDueToAddedRows + 1
End If
End If
Next 'Line
End Sub
Sub CreateDummyTableRow(ByRef pTable As CscXDocTable, ByVal lLine As Long, ByVal lPage As Long, ByVal lHeight As Long)
Dim lCell As Long, pRow As CscXDocTableRow
Dim lPreviousWidth As Long, lPreviousTop As Long, lPreviousLeft As Long
'Get measurements from the row below the one we'll be inserting.
With pTable.Rows.ItemByIndex(lLine)
lPreviousWidth = .Width(lPage)
lPreviousTop = .Top(lPage)
lPreviousLeft = .Left(lPage)
End With
pTable.Rows.Insert(lLine)
Set pRow = pTable.Rows.ItemByIndex(lLine)
pRow.ErrorDescription = "One or more rows may be missing from the table results at this position"
pRow.Valid = False
For lCell = 0 To pRow.Cells.Count-1
With pRow.Cells.ItemByIndex(lCell)
.PageIndex = lPage
.Left = lPreviousLeft
.Top = lPreviousTop - lHeight
.Height = lHeight
.Width = lPreviousWidth
.Valid = False
End With
Next
End Sub
'Small datatype used to record information about a line.
Type LineInfo
IsFirstLineOnPage As Boolean
Page As Long
DistanceFromPreviousLine As Long
End Type
'***************************************************************************
'*** Name : SL_OVE_FixConfidence_LocateAlternatives
'*** Purpose: Provides a workaround for alternatives created by the OCR Voting Evaluator
'***
'***
'*** Inputs : Standard for _LocateAlternatives
'*** Outputs: None
'***
'*** Return : Nothing.
'**************************************************************************
Private Sub SL_OVE_FixConfidence_LocateAlternatives(ByVal pXDoc As CASCADELib.CscXDocument, ByVal pLocator As CASCADELib.CscXDocField)
On Error GoTo ErrorHandler
OutputDebugString "KfxKTM_Name: " & CStr(pXDoc.Locators.ItemByName("AZL_CTSAppealData_RS").Alternatives.ItemByIndex(0).SubFields.ItemByName("SF_3_Reference").Name)
OutputDebugString "KfxKTM_Confidence: " & CStr(pXDoc.Locators.ItemByName("AZL_CTSAppealData_RS").Alternatives.ItemByIndex(0).SubFields.ItemByName("SF_3_Reference").Confidence)
OutputDebugString "KfxKTM_ConfAvg: " & CStr(pXDoc.Locators.ItemByName("AZL_CTSAppealData_RS").Alternatives.ItemByIndex(0).SubFields.ItemByName("SF_3_Reference").Chars.ConfAvg)
OutputDebugString "KfxKTM_ConfMin: " & CStr(pXDoc.Locators.ItemByName("AZL_CTSAppealData_RS").Alternatives.ItemByIndex(0).SubFields.ItemByName("SF_3_Reference").Chars.ConfMin)
' This script locator is required to resolve an issue whereby OVE subfields do not specify an minimum confidence value for the field/chars.
' The AZL provides a ConfMin value for the subfield (based on the char with the lowest conf) which is past to the xDoc Field alternative. Unfortunately, the OVE does not do this.
' The OVE generate a new ConfAvg result for it's subfield but leaves the ConfMin at zero (unless it's 100%).
' Here, we loop through each OVE subfield and obtain ConfAvg value and populate the confidence of the subfield itself.
Dim oLocator As CscXDocField
Set oLocator = pXDoc.Locators.ItemByName("OVE_AppealData")
Dim i As Long
Dim oSubField As CscXDocSubField
Dim oChars As CscXDocChars
' Loop through each OVE subfield
For i = 0 To oLocator.Alternatives.ItemByIndex(0).SubFields.Count - 1
Set oSubField = oLocator.Alternatives.ItemByIndex(0).SubFields.ItemByIndex(i)
Set oChars = oSubField.Chars
OutputDebugString "KfxKTM_SubField Name: " & CStr(oSubField.Name)
OutputDebugString "KfxKTM_ConfAvg: " & CStr(oChars.ConfAvg)
OutputDebugString "KfxKTM_ConfMin: " & CStr(oChars.ConfMin)
OutputDebugString "KfxKTM_Count: " & CStr(oChars.Count)
OutputDebugString "KfxKTM_HasRejected: " & CStr(oChars.HasRejected)
OutputDebugString "KfxKTM_Text: " & CStr(oChars.Text)
' Get the average char confidence and update the subfield confidence
oLocator.Alternatives.ItemByIndex(0).SubFields.ItemByIndex(i).Confidence = oChars.ConfAvg
Next
Exit Sub
ErrorHandler:
General_Error_Handler("SL_OVE_FixConfidence_LocateAlternatives", LOG_ERROR, DISPLAY_TO_USER)
End Sub
Public Function GetInternalLookupResults(ByVal tableName As String, ByVal columnName As String, _
ByVal columnValue As String) As ADODB.Recordset
On Error GoTo ErrorHandler
Dim FSO As Object
Dim oFile As Object
Dim sProjectDirectoryPath As String
Dim sCustomizationDirectoryPath As String
Dim sDatabaseFilePath As String
Dim sDatabaseName As String
Dim sConnectionString As String
Dim oConnection As ADODB.Connection
Dim oCommand As New ADODB.Command
Dim oParam As ADODB.Parameter
sDatabaseName = Project.ScriptVariables.ItemByName("InternalLookups_ADODB_DatabaseName").Value
Set FSO = CreateObject("Scripting.FileSystemObject")
Set oFile = FSO.GetFile(Project.FileName)
sProjectDirectoryPath = oFile.ParentFolder.Path
sCustomizationDirectoryPath = FSO.BuildPath(sProjectDirectoryPath, "Customization")
sDatabaseFilePath = FSO.BuildPath(sCustomizationDirectoryPath, sDatabaseName)
sConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sDatabaseFilePath & ";Persist Security Info=False"
Set oConnection = GetAccessDbConnection(sConnectionString)
Set oCommand.ActiveConnection = oConnection
oCommand.CommandText = "SELECT * FROM [" & tableName & "] WHERE [" & columnName & "] LIKE @" & columnName
Set oParam = oCommand.CreateParameter(Name:="@" & columnName, Type:=adVarChar, Direction:=adParamInput, _
Size:=255, Value:=columnValue)
oCommand.Parameters.Append oParam
Set GetInternalLookupResults = oCommand.Execute
Exit Function
ErrorHandler:
General_Error_Handler("GetInternalLookupResults", LOG_ERROR, DISPLAY_TO_USER)
End Function
Public Function GetInternalLookupResultsArray(ByVal tableName As String, ByVal columnName As String, _
ByVal columnValue As String) As Variant
On Error GoTo ErrorHandler
Dim oRecordSet As ADODB.Recordset
Set oRecordSet = GetInternalLookupResults(tableName, columnName, columnValue)
GetInternalLookupResultsArray = oRecordSet.GetRows
Exit Function
ErrorHandler:
General_Error_Handler("GetInternalLookupResultsArray", LOG_ERROR, DISPLAY_TO_USER)
End Function
Public Function GetAccessDbConnection(ByVal connectionString As String) As Object
On Error GoTo ErrorHandler
Dim oConnection As New ADODB.Connection
oConnection.ConnectionString = connectionString
oConnection.Open
Set GetAccessDbConnection = oConnection
Exit Function
ErrorHandler:
General_Error_Handler("GetAccessDbConnection", LOG_ERROR, DISPLAY_TO_USER)
End Function
Public Function GetInternalLookupResultsSpecifiedColArray(ByVal tableName As String, _
ByVal columnName As String, _
ByVal columnValue As String, _
ByVal columnToRetrieve As Variant) As Variant
Dim oRecordSet As Object
Dim vMultiArray As Variant
Dim arrSingleArray() As String
Dim lIndex As Long
On Error GoTo ErrorHandler
Set oRecordSet = GetInternalLookupResults(tableName, columnName, columnValue)
vMultiArray = oRecordSet.GetRows(, , columnToRetrieve)
ReDim arrSingleArray(UBound(vMultiArray, 2))
For lIndex = LBound(arrSingleArray) To UBound(arrSingleArray)
arrSingleArray(lIndex) = vMultiArray(0, lIndex)
Next
GetInternalLookupResultsSpecifiedColArray = arrSingleArray
Exit Function
ErrorHandler:
General_Error_Handler("GetInternalLookupResultsSpecifiedColArray", LOG_ERROR, DISPLAY_TO_USER)
End Function
Private Sub FmtCurrency_FormatField(ByVal FieldText As String, ByRef FormattedText As String, ByRef ErrDescription As String, ByRef ValidFormat As Boolean)
On Error GoTo ErrorHandler
Dim oRecordSet As ADODB.Recordset
Dim oFields As ADODB.Fields
Set oRecordSet = GetInternalLookupResults("CurrencyData", "Abv_Symbol", FieldText)
Do While Not oRecordSet.EOF
Set oFields = oRecordSet.Fields
FormattedText = oFields.Item(1).Value
' OR:
' FormattedText = oFields.Item("Code").Value
oRecordSet.MoveNext
Loop
Exit Sub
ErrorHandler:
General_Error_Handler("FmtCurrency_FormatField", LOG_ERROR, DISPLAY_TO_USER)
End Sub
Option Explicit
' Class script: 5007 10 12
Private Sub Document_AfterExtract(ByVal pXDoc As CASCADELib.CscXDocument)
'Set oImage = pXDoc.CDoc.Pages(0).GetImage()
'Set oImage = pXDoc.CDoc.Pages(0)
' Set oImage = pXDoc.CDoc.Pages(0).GetDisplayImage
' oImage.Redact(Left:=0, Top:=0, Width:=500, Height:=500)
' oImage.DrawRectangle(0,0,25,25,255)
Dim oImage As CscImage
' Get image of the page where current alternative is located
Set oImage = pXDoc.CDoc.Pages(0).GetImage()
' Redact the image (Version 3.1+)
'oImage.Redact(oAlt.Left, oAlt.Top, oAlt.Width, oAlt.Height)
oImage.Redact(1780, 1870, 1664, 535)
' Save the image
If Project.ScriptExecutionMode = CscScriptModeServerDesign Then
'Do not save redaction
'oImage.BinarizeWithVRS
'oImage.VRS_Filter(CscVRSFilterDilate2x2)
oImage.VRS_Filter(CscVRSFilterOpening)
oImage.VRS_Despeckle(1, 1)
oImage.Save("C:\Temp\VRS_out.tiff", CscImgFileFormatTIFFFaxG4)
Dim ImageDestination As CscImage
Set ImageDestination = New CscImage
ImageDestination.CreateImage(CscImageColorFormat.CscImgColFormatBinary, 500, 500, oImage.XResolution, oImage.YResolution)
'Dim strSnippetLoc As String
'strSnippetLoc = "\\SERVER\Share\Folder"
'ImageBox.CopyRect(ImageOrig, Box.Left, Box.Top, 0, 0, Box.Width, Box.Height)
ImageDestination.CopyRect(oImage, 100, 100, 0, 0, 500, 500)
'ImageBox.Save( "C:\Temp\" + Prefix + "_" + CStr(i) + "_(" + CStr(Box.Left) + "," + CStr(Box.Top) + ")_[" + CStr(Box.Width) + "," + CStr(Box.Height) + "]_Type" + CStr(Box.LongTag) + ".tif")
ImageDestination.Save("\Temp\Snippet.png", CscImgFileFormatPNG)
'pXDoc.Fields.ItemByName("SnippetLocation").Text = strSnippetLoc & "\Temp\Snippet.tif"
Else
'oImage.Save(oImage.FileName, CscImgFileFormatTIFFFaxG4)
oImage.Save(oImage.FileName, CscImgFileFormatTIFFFaxG4)
End If
End Sub
Private Sub Document_BeforeExtract(ByVal pXDoc As CASCADELib.CscXDocument)
'MsgBox pXDoc.FileName
End Sub
Private Sub ValidationForm_AfterFieldChanged(ByVal pXDoc As CASCADELib.CscXDocument, ByVal pField As CASCADELib.CscXDocField)
'pField.Valid = False
End Sub
Private Sub ValidationForm_AfterViewerLassoDrawn(ByVal pXDoc As CASCADELib.CscXDocument, ByVal PageIndex As Long, ByVal pField As CASCADELib.CscXDocField, ByVal TopPos As Long, ByVal LeftPos As Long, ByVal Width As Long, ByVal Height As Long, ByRef bCancel As Boolean)
'MsgBox "TopPos:" & CStr(TopPos)
'MsgBox "LeftPos:" & CStr(LeftPos)
'MsgBox "WidthPos:" & CStr(Width)
'MsgBox "HeightPos:" & CStr(Height)
End Sub
Private Sub Document_AfterExtract(ByVal pXDoc As CASCADELib.CscXDocument)
'pXDoc.Fields.ItemByIndex(99).Text
' Manipulate the Validation Image
Dim imgOriginal As CscImage
Dim imgTemp As CscImage
Dim oICP As IMpsImageCleanupProfile
' Save a copy of the Extraction Image
Set imgOriginal = pXDoc.CDoc.Pages(0).GetImage ' Page 1 only!!!!!!
'imgOriginal.Save(imgOriginal.FileName & "_Extraction", imgOriginal.FileFormat)
FileCopy imgOriginal.FileName, imgOriginal.FileName & "_Extraction"
' Assign a specific Image Cleanup Profile
Set oICP = Project.ImageCleanupProfiles.ItemByName("RemoveBoxes")
' Execute ICP on temp image
Set imgTemp = oICP.IPP.Preprocess(imgOriginal)
' Save the temp image over the original image
imgTemp.Save(imgOriginal.FileName, imgOriginal.FileFormat)
End Sub
Private Sub Batch_Close(ByVal pXRootFolder As CASCADELib.CscXFolder, ByVal CloseMode As CASCADELib.CscBatchCloseMode)
OutputDebugString "KfxKTM_Batch_Close: " & GetScriptExecutionName(Project.ScriptExecutionMode) & " | " & CStr(Project.ScriptExecutionInstance) & " | " & CStr(CloseMode)
OutputDebugString "KfxKTM_Batch Name/Dir: " & GetBatchName(pXRootFolder) & " | " & GetBatchDir(pXRootFolder)
Select Case Project.ScriptExecutionMode
Case 2, 4
Dim lTotalDocs As Long
Dim k As Long
lTotalDocs = pXRootFolder.GetTotalDocumentCount
For k = 0 To lTotalDocs - 1
Dim oXDoc As CASCADELib.CscXDocument
Set oXDoc = pXRootFolder.GetDocInfoByGlobalIndex(k).XDocument
Dim imgOriginal As CscImage
Set imgOriginal = oXDoc.CDoc.Pages(0).GetImage ' Page 1 only!!!!!!
FileCopy imgOriginal.FileName & "_Extraction", imgOriginal.FileName
Kill imgOriginal.FileName & "_Extraction"
Next
End Select
End Sub
'***************************************************************************
'*** Name : FuzzyDBQuery
'*** Purpose: Search Fuzzy databases (Local & Remote) and return all results
'*** above x%. Handles Remote fuzzy DB where specific column
'*** addressing does not feature at present
'*** Inputs : xDoc, QueryValue, QueryField, DB, Minimum Confidence.
'*** Outputs: None
'*** Return : KTM Field object
'*** Supports: KTM 5.5 R2 +SP3 & KTM 6.0
'**************************************************************************
Public Function FuzzyDBQuery(ByRef pXDoc As CASCADELib.CscXDocument, sQueryValue As String, sQueryField As Long, db As CscDatabase, MinConf As Double) As CscXDocField
On Error GoTo ErrorHandler
' Local Fuzzy DB
' Column addressing not zero based
' Column ID zero will search all Columns
' Remote Fuzzy DB
' Column addressing not possible
' Any column ID will search all Columns - additional validation of results required to filter unwanted results.
Dim Fields(0) As String
Dim FieldIDs(0) As Long
Dim Hits As CscDatabaseResItems
Dim Results As CscXDocField
Set Results = New CscXDocField
Dim alt As CscXDocFieldAlternative
Dim arr() As String ' For DB result item
Dim i As Long
Dim c As Integer
Dim iRecID As Long
Fields(0) = sQueryValue
FieldIDs(0) = sQueryField
Set Hits = db.Search(Fields, FieldIDs, CscEvalMatchQuery, 50)
If Hits.Count > 0 Then
For i = 0 To Hits.Count - 1
' Ignore any DB hits that fall below the minimum confidence value supplied
If Hits(i).Score >= MinConf Then
iRecID = Hits.Item(i).RecID
' Results must be handled differently, due to limitations in Remote Fuzzy Queries
Select Case db.DatabaseType
Case 0 ' Local Fuzzy
Set alt = Results.Alternatives.Create()
alt.Confidence = Hits(i).Score
For c = 0 To db.FieldCount - 1
alt.SubFields.Create(db.FieldName(c))
alt.SubFields(c).Index = c
alt.SubFields(c).Text = db.GetRecordData(Hits(i).RecID)(c)
alt.SubFields(c).Confidence = Hits(i).Score
Next
alt.Text = ""
Case 1 ' Relational/SQL
Case 2 ' Remote Fuzzy
' Before assigned alternatives, the QueryField column must be checked to ensure it matches the QueryValue. Non-matches are skipped.
arr = db.GetRecordData(iRecID)
If arr(sQueryField - 1) = sQueryValue Then
Set alt = Results.Alternatives.Create()
alt.Confidence = Hits(i).Score
For c = 0 To db.FieldCount - 1
alt.SubFields.Create(db.FieldName(c))
alt.SubFields(c).Index = c
alt.SubFields(c).Text = db.GetRecordData(Hits(i).RecID)(c)
alt.SubFields(c).Confidence = Hits(i).Score
Next
alt.Text = ""
End If
End Select
End If
Next i
End If
Set FuzzyDBQuery = Results
Exit Function
ErrorHandler:
General_Error_Handler("FuzzyDBQuery", LOG_ERROR, DISPLAY_TO_USER)
End Function
'***************************************************************************
'*** Name : FuzzyDBSearch
'*** Purpose: Clear the tInvoice member variable.
'*** Inputs : None.
'*** Outputs: None.
'***
'*** Return : Nothing.
'**************************************************************************
' Fuzzy Database Search for KTM 5.5 upwards
' Older versions are only capable of querying all DB columns
' http://knowledgebase.kofax.com/faqsearch/results.aspx?QAID=17223
Public Sub FuzzyDBSearch(ByRef pXDoc As CASCADELib.CscXDocument, ByRef pField As CASCADELib.CscXDocField)
Select Case pField.Name
Case "PostCode"
Dim Fields() As String
ReDim Fields(0)
' The Fields() array are the fields you want to parse into the fuzzy query
' ReDim to define the number of different fields you are using
' So, to parse in 2 difference values, ReDim(1)
Dim FieldIDs() As Long
ReDim FieldIDs(0)
' The FieldID's array allows you to specify which database columns to target, for EACH of the Fields being parsed into the array
' ReDim to define the number of different fields you are using. This should match the Fields() array
Dim DB As CscDatabase
Dim DBResItems As CscDatabaseResItems
Dim arr() As String
' Assign query values to the array
Fields(0) = pField.Text
'Fields(1) = pField.Text
'Fields(2) = "ME3 7SZ"
' For each of the index values parsed in, define which target columns should be used.
' 0 = Search all columns
' 1 = Search column 1
' 2 = Search column 2
' The column ID's are only those that are ENABLED in the DB settings, and the ID's are NOT zero based. If you have 5 enabled columns, use 1-5.
' The Suppliers DB has 4 columns, as follows:
' 0 = Postcode > 1
' 1 = Lat > 2
' 2 = Long > 3
' 3 = Easting > 4
' 4 = Northing > 5
' etc...
FieldIDs(0) = 1
'FieldIDs(1) = 1
'FieldIDs(2) = 1
'Set DB = Project.Databases.ItemByName("UKPostcodes")
Set DB = Project.Databases.ItemByName("UKPostcodesSMALL")
Set DBResItems = DB.Search(Fields, FieldIDs, CscQueryEvalMode.CscEvalMatchQuery, 5)
'Set DBResItems = DB.Search2(Fields, FieldIDs, CscQueryEvalMode.CscEvalMatchQuery, CscWeightEvalDatabase 5)
If DBResItems.Count > 0 Then
Dim lResCount As Long
For lResCount = 0 To DBResItems.Count - 1
arr = DB.GetRecordData(DBResItems(lResCount).RecID)
MsgBox CStr(DBResItems(lResCount).Score) & vbCrLf & arr(0) & " | " & arr(1) & " | " & arr(2)
Next lResCount
End If
End Select
End Sub
'***************************************************************************
'*** Name : Database_Search
'*** Purpose: Searches inside a fuzzy database for the searchstring and returns the results as a new CSCField Object
'*** Inputs : dbname (project DB), column (name in DB), searchstring, numberHits (max hits), score (minimum hit score).
'*** Outputs: None.
'***
'*** Return : CscXDocField
'**************************************************************************
Public Function Database_Search(dbname As String, column As String, searchstring As String,numberHits As Integer,score As Double) As CscXDocField
'if column i="" then all columns are returned as subfields
'Set score=1.0 for exact match
Dim DB As CscDatabase
Set DB=Project.Databases.ItemByName(dbname)
Dim Fields() As String
Dim FieldIDs() As Long
ReDim Fields(DB.FieldCount)
ReDim FieldIDs(DB.FieldCount)
Fields(0) = searchstring
FieldIDs(0) = 0
'Find the column we are looking for
Dim col As Integer
col=-1
Dim i As Integer
For i =0 To DB.FieldCount-1
If DB.FieldName(i)=column Then col=i
Next
If col=-1 And column<>"" Then Err.Raise 34589,,"Column '" & column & "' does not exist in database '" & dbname & "'."
Dim hits As CscDatabaseResItems
Set hits = DB.Search(Fields, FieldIDs, CscEvalMatchQuery, numberHits)
Dim Results As CscXDocField
Set Results = New CscXDocField 'You are allowed to create a standalone field
For i = 0 To hits.Count-1
If hits(i).Score>= score Then
Dim alt As CscXDocFieldAlternative
Set alt= Results.Alternatives.Create()
alt.Confidence=hits(i).Score
If col=-1 Then 'the column is "", so we return all fields
Dim c As Integer
For c = 0 To DB.FieldCount-1
alt.SubFields.Create(DB.FieldName(c))
alt.SubFields(c).Index=c
alt.SubFields(c).Text=DB.GetRecordData(hits(i).RecID)(c)
alt.SubFields(c).Confidence=hits(i).Score
Next
alt.Text=""
Else
alt.Text=DB.GetRecordData(hits(i).RecID)(col)
End If
End If
Next
Set Database_Search=Results
End Function
' sample formatter to accompany function Database_Search
Private Sub unitmeasure_FormatField(ByVal FieldText As String, ByRef FormattedText As String, ErrDescription As String, ValidFormat As Boolean)
If Len(FieldText) = 0 Then
ValidFormat = False
ErrDescription = "Field must not be empty"
Else
' format text in single word
FormattedText = Trim(Split(FieldText)(0))
' Database Search
Dim Results As New CscXDocField
Set Results = Database_Search("unitmeasure", "Unit", FormattedText, 2, 0.2)
Select Case Results.Alternatives.Count
Case 0
ValidFormat=False
ErrDescription = FormattedText & " is not a known unit measure"
Case 1
If Results.Alternatives(0).Confidence>0.65 Then
FormattedText=Results.Alternatives(0).Text
ValidFormat=True
End If
Case Else
Dim conf1 As Double, conf2 As Double
conf1=Results.Alternatives(0).Confidence
conf2=Results.Alternatives(1).Confidence
If conf1>0.65 And conf1-conf2>0.2 Then
FormattedText=Results.Alternatives(0).Text
ValidFormat=True
Else
ValidFormat=False
ErrDescription ="There are two possibilities: " & Results.Alternatives(0).Text & ", " & Results.Alternatives(1).Text
End If
End Select
End If
End Sub
Public Function FuzzyDBItemExists(sQueryValue As String, sQueryField As Long, db As CscDatabase) As Boolean
On Error GoTo ErrorHandler
FuzzyDBItemExists = False
Dim asQueryValues(0) As String
Dim asQueryFields(0) As Long
Dim dbResults As CscDatabaseResItems
Dim sRecordData() As String
Dim iRecID As Long
Dim iResCount As Long
' Set search Parameters
asQueryValues(0) = sQueryValue
asQueryFields(0) = sQueryField
' Execute Search
Set dbResults = db.Search(asQueryValues, asQueryFields, CscQueryEvalMode.CscEvalMatchQuery, 50)
' If there are results for this query, then we check the first record to see if this matches the query value
If dbResults.Count > 0 Then
' Check results (need to double check the result to ensure the query field matches the query value)
For iResCount = 0 To dbResults.Count - 1
If dbResults.Item(iResCount).Score = 1 Then ' Must be 100% match
iRecID = dbResults.Item(iResCount).RecID
sRecordData = db.GetRecordData(iRecID)
If sRecordData(sQueryField) = sQueryValue Then
FuzzyDBItemExists = True
Exit Function
Else
FuzzyDBItemExists = False
End If
End If
Next iResCount
Else
FuzzyDBItemExists = False
End If
Exit Function
ErrorHandler:
General_Error_Handler("FuzzyDBItemExists", LOG_ERROR, DISPLAY_TO_USER)
End Function
Option Explicit
' Project Script
' Folder Fields
Public Const FFIELD_ACCOUNT = "ACCOUNT"
Public Const FFIELD_CLASS = "CLASS"
Public Const FFIELD_GUID = "GUID"
' Document Fields
Public Const DFIELD_ACCOUNT As String = "ACCOUNT"
Public Const DFIELD_CLASS As String = "CLASS"
Public Const DFIELD_GUID As String = "GUID"
Global sValidFolderACCOUNT As Boolean
Global sValidFolderCLASS As Boolean
Global sValidFolderGUID As Boolean
Public Function GetRootFolder(pXFolder As CASCADELib.CscXFolder) As CASCADELib.CscXFolder
If pXFolder.IsRootFolder Then
Set GetRootFolder = pXFolder
Else
Set GetRootFolder = GetRootFolder(pXFolder.ParentFolder)
End If
End Function
Private Sub AccountFormatter_FormatField(ByVal FieldText As String, ByRef FormattedText As String, ByRef ErrDescription As String, ByRef ValidFormat As Boolean)
FormattedText = Replace(FieldText, " ", "")
ValidFormat = True
End Sub
Private Sub PackANDPackQuantityVal_Validate(ByVal ValItems As CASCADELib.CscXDocValidationItems, ByVal pXDoc As CASCADELib.CscXDocument, ByRef ErrDescription As String, ByRef ValidField As Boolean)
Dim a As String
Dim b As String
a = ValItems.ItemByName("Pack").Text
b = ValItems.ItemByName("Quantity").Text
If a = "1" And Trim$(b) = "" Then
ValidField = False
ErrDescription = "There is no Quantity"
End If
End Sub
Option Explicit
' RootFolder script: Root Folder
Private Sub RootFolder_DoFoldering(ByVal pXRootFolder As CASCADELib.CscXFolder)
If Project.ScriptExecutionMode = CscScriptModeValidation Then Exit Sub
Dim i As Long
Dim j As Long
Dim k As Long
Dim strFolderingVal As String
Dim nFolderIndex As Long
Dim pFolder As CscXFolder
Dim pL1Folder As CscXFolder
Dim pL2Folder As CscXFolder
' ## FOLDER LEVEL 1
' For each document in the batch/root folder, perform foldering
For i = pXRootFolder.DocInfos.Count - 1 To 0 Step -1
' Get the foldering value from the document
If pXRootFolder.DocInfos(i).XDocument.Fields.Exists(DFIELD_ACCOUNT) Then
strFolderingVal = pXRootFolder.DocInfos(i).XDocument.Fields.ItemByName(DFIELD_ACCOUNT).Text
Else
strFolderingVal = ""
End If
' Try to find a matching folder
Set pFolder = FindFolder(pXRootFolder, strFolderingVal, FFIELD_ACCOUNT)
If pFolder Is Nothing Then
' Created a new folder and move the document into it
nFolderIndex = Batch.CreateFolderFromDocumentTo(pXRootFolder, i, 0)
' Parse the document field value to the folder field
Set pFolder = pXRootFolder.Folders(nFolderIndex)
pFolder.Fields.ItemByName(FFIELD_ACCOUNT).Text = strFolderingVal
Else
' Move the document into the existing folder
Batch.MoveDocumentTo(pXRootFolder, i, pFolder, 0)
End If
Next i
' ## FOLDER LEVEL 2
' For each document in a level 1 folder, perform foldering
For j = 0 To pXRootFolder.Folders.Count - 1
Set pL1Folder = pXRootFolder.Folders.ItemByIndex(j)
For i = pL1Folder.DocInfos.Count - 1 To 0 Step -1
' Get the foldering value from the document
If pL1Folder.DocInfos(i).XDocument.Fields.Exists(DFIELD_CLASS) Then
strFolderingVal = pL1Folder.DocInfos(i).XDocument.Fields.ItemByName(DFIELD_CLASS).Text
Else
strFolderingVal = ""
End If
' Try to find a matching Level 1 folder
Set pFolder = FindFolder(pL1Folder, strFolderingVal, FFIELD_CLASS)
If pFolder Is Nothing Then
' Created a new folder and move the document into it (a level 2 folder)
nFolderIndex = Batch.CreateFolderFromDocumentTo(pL1Folder, i, 0)
' Parse the document field value to the folder field
Set pFolder = pL1Folder.Folders(nFolderIndex)
pFolder.Fields.ItemByName(FFIELD_CLASS).Text = strFolderingVal
Else
' Move the document into the existing folder (an existing level 2 folder)
Batch.MoveDocumentTo(pL1Folder, i, pFolder, 0)
End If
Next
Next
' ## FOLDER LEVEL 3
' For each document in a level 2 folder, perform foldering
For j = 0 To pXRootFolder.Folders.Count - 1
Set pL1Folder = pXRootFolder.Folders.ItemByIndex(j)
For k = 0 To pL1Folder.Folders.Count - 1
Set pL2Folder = pL1Folder.Folders.ItemByIndex(k)
For i = pL2Folder.DocInfos.Count - 1 To 0 Step -1
' Get the foldering value from the document
If pL2Folder.DocInfos(i).XDocument.Fields.Exists(DFIELD_GUID) Then
strFolderingVal = pL2Folder.DocInfos(i).XDocument.Fields.ItemByName(DFIELD_GUID).Text
Else
strFolderingVal = ""
End If
' Try to find a matching Level 2 folder
Set pFolder = FindFolder(pL2Folder, strFolderingVal, FFIELD_GUID)
If pFolder Is Nothing Then
' Created a new folder and move the document into it (a level 3 folder)
nFolderIndex = Batch.CreateFolderFromDocumentTo(pL2Folder, i, 0)
' Parse the document field value to the folder field
Set pFolder = pL2Folder.Folders(nFolderIndex)
pFolder.Fields.ItemByName(FFIELD_GUID).Text = strFolderingVal
Else
' Move the document into the existing folder (an existing level 2 folder)
Batch.MoveDocumentTo(pL2Folder, i, pFolder, 0)
End If
Next
Next
Next
End Sub
Private Function FindFolder(pFolder As CscXFolder, sFolderingVal As String, sFolderField As String) As CscXFolder
Dim i As Long
For i = 0 To pFolder.Folders.Count - 1
If pFolder.Folders(i).Fields.ItemByName(sFolderField).Text = sFolderingVal Then
Set FindFolder = pFolder.Folders(i)
Exit Function
End If
Next i
Set FindFolder = Nothing
End Function
Option Explicit
' Folder script: GUID
Private Sub Folder_AfterExtract(ByVal pXFolder As CASCADELib.CscXFolder)
' pXFolder.Fields.ItemByIndex(0).Confidence = 1
' pXFolder.Fields.ItemByIndex(0).ExtractionConfident = True
' pXFolder.Fields.ItemByIndex(0).Valid = True
' pXFolder.Fields.ItemByIndex(1).Confidence = 1
' pXFolder.Fields.ItemByIndex(1).ExtractionConfident = True
' pXFolder.Fields.ItemByIndex(1).Valid = True
' pXFolder.Fields.ItemByIndex(2).Confidence = 1
' pXFolder.Fields.ItemByIndex(2).ExtractionConfident = True
' pXFolder.Fields.ItemByIndex(2).Valid = True
Dim lDocCounter As Long
Dim bFolderCheckAccount As Boolean
Dim bFolderCheckClass As Boolean
Dim bFolderCheckGuid As Boolean
bFolderCheckAccount = False
bFolderCheckClass = False
bFolderCheckGuid = False
For lDocCounter = pXFolder.DocInfos.Count - 1 To 0 Step -1
If pXFolder.DocInfos(lDocCounter).XDocument.Fields.ItemByName(DFIELD_ACCOUNT).Valid = False Then
bFolderCheckAccount = True
ElseIf pXFolder.DocInfos(lDocCounter).XDocument.Fields.ItemByName(DFIELD_CLASS).Valid = False Then
bFolderCheckClass = True
ElseIf pXFolder.DocInfos(lDocCounter).XDocument.Fields.ItemByName(DFIELD_GUID).Valid = False Then
bFolderCheckGuid = True
End If
Next lDocCounter
If bFolderCheckAccount = False Then
pXFolder.Fields.ItemByName(FFIELD_ACCOUNT).ExtractionConfident = True
pXFolder.Fields.ItemByName(FFIELD_ACCOUNT).Valid = True
pXFolder.Fields.ItemByName(FFIELD_ACCOUNT).Confidence = 1
End If
If bFolderCheckClass = False Then
pXFolder.Fields.ItemByName(FFIELD_CLASS).ExtractionConfident = True
pXFolder.Fields.ItemByName(FFIELD_CLASS).Valid = True
pXFolder.Fields.ItemByName(FFIELD_CLASS).Confidence = 1
End If
If bFolderCheckGuid = False Then
pXFolder.Fields.ItemByName(FFIELD_GUID).ExtractionConfident = True
pXFolder.Fields.ItemByName(FFIELD_GUID).Valid = True
pXFolder.Fields.ItemByName(FFIELD_GUID).Confidence = 1
End If
End Sub
Private Sub ValidationPanel_AfterFieldChanged(ByVal pXFolder As CASCADELib.CscXFolder, ByVal pField As CASCADELib.CscXFolderField)
pField.Valid = False
End Sub
Private Sub ValidationPanel_AfterFieldConfirmed(ByVal pXFolder As CASCADELib.CscXFolder, ByVal pField As CASCADELib.CscXFolderField)
Dim lDocCounter As Long
For lDocCounter = pXFolder.DocInfos.Count - 1 To 0 Step -1
Select Case pField.Name
Case FFIELD_ACCOUNT
pXFolder.DocInfos(lDocCounter).XDocument.Fields.ItemByName(DFIELD_ACCOUNT).Valid = True
pXFolder.DocInfos(lDocCounter).XDocument.Fields.ItemByName(DFIELD_ACCOUNT).ExtractionConfident = True
pXFolder.DocInfos(lDocCounter).XDocument.Fields.ItemByName(DFIELD_ACCOUNT).Confidence = 1
Case FFIELD_CLASS
pXFolder.DocInfos(lDocCounter).XDocument.Fields.ItemByName(DFIELD_CLASS).Valid = True
pXFolder.DocInfos(lDocCounter).XDocument.Fields.ItemByName(DFIELD_CLASS).ExtractionConfident = True
pXFolder.DocInfos(lDocCounter).XDocument.Fields.ItemByName(DFIELD_CLASS).Confidence = 1
Case FFIELD_GUID
pXFolder.DocInfos(lDocCounter).XDocument.Fields.ItemByName(DFIELD_GUID).Valid = True
pXFolder.DocInfos(lDocCounter).XDocument.Fields.ItemByName(DFIELD_GUID).ExtractionConfident = True
pXFolder.DocInfos(lDocCounter).XDocument.Fields.ItemByName(DFIELD_GUID).Confidence = 1
End Select
Next lDocCounter
End Sub
' Field Formatters
'***************************************************************************
'*** Name : AmountScript_FormatDoubleField
'*** Purpose: Standard KTM script formatter for formatting negative amount.
'***
'***
'*** Inputs : Standard KTM script formatter inputs
'*** Outputs: Standard KTM script formatter outputs
'***
'*** Return : Nothing.
'**************************************************************************
Private Sub AmountScript_FormatDoubleField(ByVal FieldText As String, FormattedText As String,
ErrDescription As String, ValidFormat As Boolean,
ByRef DoubleVal As Double, ByRef DoubleFormatted As Boolean)
Dim pTmpField As New CscXDocField
pTmpField.Text = FieldText
' use the standard amount formatter first
' replace "DefaultAmountFormatter" with the name of you normal amount formatter, or define yours to be the default in the Project Settings
ValidFormat = DefaultAmountFormatter.FormatField(pTmpField)
DoubleVal = pTmpField.DoubleValue
DoubleFormatted = pTmpField.DoubleFormatted
FormattedText = pTmpField.Text
If ValidFormat = False Then
ErrDescription = pTmpField.ErrorDescription
End If
' check for minus sign inside original text
' you could also be more strict and allow only the first or the last character to be a minus sign
' but this might cause problems if the currency symbol is also there
If InStr(FieldText, "-") > 0 Then
' make it negative
FormattedText = "-" +FormattedText
DoubleVal = - DoubleVal
End If
End Sub
Private Sub RegionalDateFormatter_FormatField(ByVal FieldText As String, _
FormattedText As String, ErrDescription As String, ValidFormat As Boolean)
Select Case g_Locale
Case LOCALE_US
ValidFormat = Project.FieldFormatters.ItemByName("USDateFormatter").FormatFieldText( _
FieldText, FormattedText, ErrDescription)
Case Else
ValidFormat = Project.FieldFormatters.ItemByName("OtherDateFormatter").FormatFieldText( _
FieldText, FormattedText, ErrDescription)
End Select
End Sub' Generic Functions
'***************************************************************************
'*** Name : IsStringArrayValid
'*** Purpose: Checks the validity of a given string array.
'***
'***
'*** Inputs : stringArray
'*** Outputs: None
'***
'*** Return : True/False.
'**************************************************************************
Private Function IsStringArrayValid(arrOfStrings() As String) As Boolean
Dim result As Long
On Error GoTo IsStringArrayValidError
result = UBound(arrOfStrings)
IsStringArrayValid = True
Exit Function
IsStringArrayValidError:
IsStringArrayValid = False
End Function
'***************************************************************************
'*** Name : StripNonNumerics
'*** Purpose: Removes any non-numeric characters from the input string
'*** with the exception of any characters specified in the
'*** exceptions list, which is option.
'*** Inputs : inputValue, exceptionsArray
'*** Outputs: None
'***
'*** Return : String.
'**************************************************************************
Private Function StripNonNumerics(inputValue As String, Optional exceptions As Variant) As String
Dim strOutput As String
Dim vException As Variant
Dim lCount As Long
Dim strCurrentChar As String
Dim lExceptionCount As Long
For lCount = 1 To Len(inputValue)
strCurrentChar = Mid(inputValue, lCount, 1)
If IsNumeric(strCurrentChar) Then
'*** Allow all numeric characters. ***
strOutput = strOutput & strCurrentChar
Else
'*** If the character is non-numeric, check to see if the caller provided a list of ***
'*** 'exception' characters (i.e. characters that should never be stripped). ***
If IsArray(exceptions) Then
'*** Exceptions were specified, so check if the current character matches one ***
'*** of them. If so, do not strip it. ***
'For Each vException In exceptions
For lExceptionCount = LBound(exceptions) To UBound(exceptions)
vException = exceptions(lExceptionCount)
If VarType(vException) = vbString Then
If CStr(vException) = strCurrentChar Then
strOutput = strOutput & strCurrentChar
End If
End If
Next
End If
End If
Next
StripNonNumerics = strOutput
End Function
'***************************************************************************
'*** Name : StripAlphaChars
'*** Purpose: Removes any non-numeric characters from the input string
'***
'***
'*** Inputs : inputValue
'*** Outputs: None
'***
'*** Return : String.
'**************************************************************************
Private Function StripAlphaChars(ByVal inputValue As String) As String
Dim iLength As Integer
iLength = Len(inputValue)
While iLength > 0
If IsNumeric(Left(Right(inputValue, iLength), 1)) = False Then
inputValue = Replace(inputValue, Left(Right(inputValue, iLength), 1), "")
End If
iLength = iLength - 1
Wend
StripAlphaChars = inputValue
End Function
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Declare Function CoCreateGuid Lib "OLE32.DLL" (pGuid As GUID) As Long
'***************************************************************************
'*** Name : GetGUID
'*** Purpose: Get a GUID
'*** http://support.microsoft.com/kb/176790
'*** Inputs : None.
'*** Outputs: None.
'***
'*** Return : string.
'**************************************************************************
Public Function GetGUID() As String
Dim udtGUID As GUID
If (CoCreateGuid(udtGUID) = 0) Then
GetGUID = _
String(8 - Len(Hex$(udtGUID.Data1)), "0") & Hex$(udtGUID.Data1) & _
String(4 - Len(Hex$(udtGUID.Data2)), "0") & Hex$(udtGUID.Data2) & _
String(4 - Len(Hex$(udtGUID.Data3)), "0") & Hex$(udtGUID.Data3) & _
IIf((udtGUID.Data4(0) < &H10), "0", "") & Hex$(udtGUID.Data4(0)) & _
IIf((udtGUID.Data4(1) < &H10), "0", "") & Hex$(udtGUID.Data4(1)) & _
IIf((udtGUID.Data4(2) < &H10), "0", "") & Hex$(udtGUID.Data4(2)) & _
IIf((udtGUID.Data4(3) < &H10), "0", "") & Hex$(udtGUID.Data4(3)) & _
IIf((udtGUID.Data4(4) < &H10), "0", "") & Hex$(udtGUID.Data4(4)) & _
IIf((udtGUID.Data4(5) < &H10), "0", "") & Hex$(udtGUID.Data4(5)) & _
IIf((udtGUID.Data4(6) < &H10), "0", "") & Hex$(udtGUID.Data4(6)) & _
IIf((udtGUID.Data4(7) < &H10), "0", "") & Hex$(udtGUID.Data4(7))
End If
End Function
' Assign a GUID as per example below
Private Sub Command1_Click()
Dim sSnippetGUID as String
sSnippetGUID = GetGuid
End SubPrivate Sub SL_SupplierID_PO_LocateAlternatives(ByRef pXDoc As CASCADELib.CscXDocument, ByRef pLocator As CASCADELib.CscXDocField)
On Error GoTo ErrorHandler
'check if the required objects have been created
If goInvoicePacksTools Is Nothing Or goInvoicePacksClassifier Is Nothing Then
InitializeObjects(pXDoc)
End If
Dim sReturnedSupplierID As String
If pXDoc.Locators.ItemByName("SE_PONumber").Alternatives.Count > 0 Then
sReturnedSupplierID = GetSupplierByOrderNumber(pXDoc, Trim$(pXDoc.Locators.ItemByName("SE_PONumber").Alternatives.ItemByIndex(0).Text))
'Only update the initial supplier ID (returned by DB Locator) if the returned result is not blank
If Trim$(sReturnedSupplierID) <> "" Then
pXDoc.Fields.ItemByName(FIELD_SUPPLIER_ID).Text = Trim$(sReturnedSupplierID)
pXDoc.Fields.ItemByName(FIELD_SUPPLIER_ID).ExtractionConfident = True
End If
End If
Exit Sub
ErrorHandler:
General_Error_Handler("SL_SupplierID_PO_LocateAlternatives", LOG_ERROR, DISPLAY_TO_USER)
End Sub
'*********************
' Oracle Connectivity
'*********************
Private Function GetSupplierByOrderNumber(ByRef pXDoc As CASCADELib.CscXDocument, ByVal sPONumber As String) As String
On Error GoTo ErrorHandler
GetSupplierByOrderNumber = ""
Dim sSQL As String
Dim oConnection As Object
Dim oRecordSet As Object
Dim sSupplierID As String
'Prepare and execute SQL lookup
Set oConnection = CreateObject("ADODB.Connection")
oConnection.ConnectionString = cDBConnProd
oConnection.Open
sSQL = "SELECT SUPPLIER_NUMBER "
sSQL = sSQL & "FROM " & cDBTable
sSQL = sSQL & " WHERE PO_NUMBER = '" & sPONumber & "'"
Set oRecordSet = oConnection.Execute(sSQL)
If Not oRecordSet.EOF Then
sSupplierID = Trim$(oRecordSet!SUPPLIER_NUMBER)
End If
oRecordSet.Close
Set oRecordSet = Nothing
oConnection.Close
Set oConnection = Nothing
GetSupplierByOrderNumber = sSupplierID
Exit Function
ErrorHandler:
General_Error_Handler("GetSupplierByOrderNumber", LOG_ERROR, DISPLAY_TO_USER)
End Function
'***************************************************************************
'*** Name : GetAlternativeByIndex
'*** Purpose: Retrieves the alternative with the specified index from the
'*** parent field and returns it. If alternative does not exist,
'*** returns nothing.
'*** Inputs : field, alternativeIndex
'*** Outputs: None
'***
'*** Return : Matched field alternative.
'**************************************************************************
'***************************************************************************
'*** Name : ClearInvoice
'*** Purpose: Clear the tInvoice member variable.
'*** Inputs : None.
'*** Outputs: None.
'***
'*** Return : Nothing.
'**************************************************************************
Private Sub XXXXXXX()
'Project.Databases.ItemByName(�yourdatabasename�). ImportDatabase(True)
End SubPrivate Sub Document_AfterClassifyXDoc(ByVal pXDoc As CASCADELib.CscXDocument)
On Error GoTo ClassifyError
Dim sDummyQRCode As String
Dim asKTMQRCode() As String
sDummyQRCode = "501657|4453921|FGGMBP - D|18/08/1944|4501"
If Project.ScriptExecutionMode = CscScriptModeServerDesign Then
'If executing within Project Builder we need to use a static dummy/test value
pXDoc.Fields.ItemByName("KTMQRCode").Text = sDummyQRCode
asKTMQRCode = Split(sDummyQRCode, "|")
pXDoc.Fields.ItemByName("DocumentNumber").Text = asKTMQRCode(0)
pXDoc.Reclassify(CDF_Name(pXDoc.Fields.ItemByName("DocumentNumber").Text))
Else
If pXDoc.XValues.ItemExists("AC_FIELD_QRCode") Then
pXDoc.Fields.ItemByName("KTMQRCode").Text = Trim$(pXDoc.XValues("AC_FIELD_QRCode"))
asKTMQRCode = Split(pXDoc.Fields.ItemByName("KTMQRCode").Text, "|")
pXDoc.Fields.ItemByName("DocumentNumber").Text = asKTMQRCode(0)
pXDoc.Reclassify(CDF_Name(pXDoc.Fields.ItemByName("DocumentNumber").Text))
Else
pXDoc.Fields.ItemByName("KTMQRCode").Text = "NO QRCODE DATA"
pXDoc.Reclassify("Unknown")
End If
End If
Exit Sub
ClassifyError:
pXDoc.Fields.ItemByName("KTMQRCode").Text = "NO QRCODE DATA"
pXDoc.Reclassify("Unknown")
End Sub' Field Validation Methods
以上是关于vbscript 旧版KTM WinWrap的主要内容，如果未能解决你的问题，请参考以下文章
vbscript 通过KTM验证表单按钮触发对话框。通过SQLDBQuery填充对话框
vbscript 检测瘦客户端验证期间是否需要OLL。在6.1.0.10之前的KTM环境中是必需的
How to solve KTM Bench identified Bosch MEDC17 ECU failure