[AP] Library SP_UtilityLib

 %REM
Library SP_UtilityLib
Created 2023/5/12 by mesha lin
Description: Comments for Library
%END REM

Option Public
Option Declare

'//-------------------------------------//'

(Declarations)

Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Type POINTAPI
x As Long
y As Long
End Type

Type MSG
hwnd As Long
message As Long
wParam As Long
lParam As Long
Time As Long
pt As POINTAPI
End Type

Declare Function GetCursorPos Lib "user32" Alias "GetCursorPos" (lpPoint As POINTAPI) As Long
Declare Function CreatePopupMenu Lib "user32" Alias "CreatePopupMenu" () As Long
Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Integer, ByVal lpNewItem As Any) As Long
Declare Function TrackPopupMenu Lib "user32" Alias "TrackPopupMenu" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal x As Long, ByVal y As Long, ByVal nReserved As Long, ByVal hwnd As Long, lprc As Rect) As Long
Declare Function DestroyMenu Lib "user32" Alias "DestroyMenu" (ByVal hMenu As Long) As Long
Declare Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long
Declare Function GetActiveWindow Lib "user32" Alias "GetActiveWindow" () As Long

'//-------------------------------------//'

Class RegExp
' RegExp -- use VBScript RegExp object to provide regular expressions
' 2004-06-03 David Phillips, rfdinc.com First version.

Public matches As Variant
Public oRegExp As Variant
' VBScript RegExp properties
Public Pattern As String
Public IgnoreCase As Boolean ' default = False
Public Global As Boolean ' default = False

Sub New ()
  Set oRegExp = CreateObject ("VBScript.RegExp")
End Sub

Public Function Match (source As String, pattern As String) As Boolean
' RegEx.Match -- scan source for pattern, set matches collection and return true if any
' (Can't call it Execute as that collides with LotusScript built-in function and statement.)
  With oRegExp
   .Pattern = pattern ' regular expression to match
   .IgnoreCase = IgnoreCase
   .Global = Global
   Set matches = .Execute (source) ' do match
   Match = (Not 0 = matches.count)
  End With
End Function

Public Function Replaces (source As String, pattern As String, replacement As String) As String
' RegEx.Replaces -- scan source for pattern, if found substitute replacement, return result
' (Can't call it Replace as that collides with LotusScript built-in function.)
  With oRegExp
   .Pattern = pattern
   .IgnoreCase = IgnoreCase
   .Global = Global
   Replaces = .Replace (source, replacement) ' do replace
  End With
End Function

Public Function Test (source As String, pattern As String) As Boolean
' RegEx.Test -- scan source for pattern, return true if found
  With oRegExp
   .Pattern = pattern
   .IgnoreCase = IgnoreCase
   Test = .Test (source)
  End With
End Function

End Class

'//-------------------------------------//'

Sub Initialize
End Sub

'//-------------------------------------//'

%REM
Function isrtfMT
Description: Comments for Function
%END REM

Function IsrtfMT (doc As NotesDocument , FieldName As String) As Integer
' Purpose: This function checks if a rich text field is empty
' Origin: This function is taken from https://searchdomino.techtarget.com/tip/Check-Rtf-Field-Empty-New-One-Which-Works
' Error handling: https://www.polymorph.co.uk/content/blog-posts/lotusscript-error-handling-in-a-structured-manner/
' Use any error handling method you like. 
If True Then
Dim mbdcount As Integer
Dim plaintext As String
Dim rtitem As Variant
try:
On Error GoTo catch
' do some code
mbdcount =0 ' initialize
Set rtitem = doc.GetFirstItem(fieldname)
If ( rtitem.Type = RICHTEXT ) Then
plainText = rtitem.GetFormattedText( False, 0 ) ' render the Rich item into text this gets all text values and ignores attachments/OLE
If Len(plaintext) < 1 Then
If IsArray(rtitem.EmbeddedObjects) Then
ForAll o In rtitem.EmbeddedObjects ' loop through array of embedded objects in the rich text item
mbdcount=mbdcount+1 ' there is at least one emb object
End ForAll
End If
End If
End If
Else
catch:
On Error GoTo 0
'Turn on for debugging
'Msgbox fnName & " ERROR: " & Error$ & " (" & Err & ") on line " & Erl
' handle the error
Select Case Err
Case Else
' an error I can't handle here so pass back to caller
Error Err, Error$
End Select
Resume finally
End If
finally:
If (mbdcount + Len(plaintext)) < 1 Then ' if there are no embedded objects AND there is no text also
IsrtfMT=1 ' return flag to calling string RTF IS EMPTY
Else
IsrtfMT=0 ' return flag to calling string RTF IS NOT EMPTY
End If
End Function

'//-------------------------------------//'

%REM
Function SP_ChkSpace
Description: Comments for Function
%END REM

Function SP_ChkSpace(strSource As String, strReplaceKey As String) As String
On Error GoTo errorhandler
SP_ChkSpace = ""
If Trim(strReplaceKey) = "" Then
strReplaceKey = "-"
End If
If strSource = ""  Or strSource = "#N/A"  Then
SP_ChkSpace = strReplaceKey
Else
SP_ChkSpace = strSource 
End If
TheEnd:
Exit Function
ErrorHandler:
Dim strErr As String
strErr = "Libary: SP_UtilityLib / SP_ChkSpace has error! line = " + CStr(Erl) + ", error = " + Error$
Print strErr
MessageBox strErr, 48, "Warning"
Resume TheEnd
End Function

'//-------------------------------------//'

%REM
Function SP_TestNotes
Description: Comments for Function
%END REM

Function SP_ChkIsTesting() As Integer
'// 檢查現在是否測試中
On Error goto errorhandler
Dim session As New NotesSession
Dim db As NotesDatabase
Dim sysProfile As NotesDocument
SP_ChkIsTesting = false
Set db = session.Currentdatabase
Set sysProfile = db.Getprofiledocument("SysProfile")
If sysProfile Is Nothing Then
MessageBox "not found SySProfile!", 48, "Warning"
Exit function
End If
If UCase(sysProfile.isTesting(0)) = "Y"  Then
SP_ChkIsTesting = true
End If
TheEnd:
exit Function
ErrorHandler:
Dim strErr As String
strErr = "Library: SP_UtilityLib / SP_ChkIsTesting has error! line = " + CStr(erl) + ", error = " + Error$
Print strErr
MessageBox strErr, 48, "Warning"
Resume TheEnd
End Function

'//-------------------------------------//'

Function SP_CalcName(pName As String, pType As String) As String
%REM
 ' 1. 參數: 1:欲轉換的Notes ID
 '               2: 指定傳回NotesId型態 
 '                    Canonical = @Name([Canonical],username)    
 '                    Abbreivate = @Name([Abbreiave],username)   
 '                    CommonName = @Name([CN],username)   
 '2. 傳回文字字串:依指定的型態傳回指定型態的Notes Id
%END REM 
 
 Dim namePerson As NotesName
 
 Set namePerson = New NotesName(pName)
 Select Case UCase(pType)
  Case "CANONICAL"       '// CN=XXX/OU=YYY/O=ORG/C=TW
  SP_CalcName = namePerson.Canonical   
  Case "ABBREVIATE"        '// XXX/YYY/ORG/TW
SP_CalcName = namePerson.Abbreviated
  Case "COMMON"           '// XXX
SP_CalcName = namePerson.Common  
  Case "ORG"                     '// ORG
SP_CalcName = namePerson.Organization 
 End Select
End Function

'//-------------------------------------//'

%REM
Function SP_RemoveMaxSizeRTF
Description: Comments for Function
%END REM

Function SP_RemoveMaxSizeRTF() As Integer
Dim doc As NotesDocument
Dim rtitem As Variant
Dim fileCount As Integer
Const MAX = 100000
fileCount = 0    
'...set value of doc...
Set rtitem = doc.GetFirstItem( "Body" )
If ( rtitem.Type = RICHTEXT ) Then
ForAll o In rtitem.EmbeddedObjects
If ( o.Type = EMBED_ATTACHMENT ) _
And ( o.FileSize > MAX ) Then
fileCount = fileCount + 1
Call o.ExtractFile _
( "c:\reports\newfile" & CStr(fileCount) )
Call o.Remove
Call doc.Save( True, True )
End If
End ForAll
End If
End Function

'//-------------------------------------//'

Function SP_IsInRole (RoleName As String) As Integer
'// 檢核是否有該角色
%REM
If IsInRole("[Admin]") then
       ' do stuff
       endif
%END REM
SP_IsInRole = False
Dim userRoles As Variant   
userRoles = Evaluate("@UserRoles")
ForAll role In userRoles
If UCase(role) = UCase(RoleName) Then
SP_IsInRole = True
Exit ForAll
End If
End ForAll
End Function

'//-------------------------------------//'

%REM
Function SP_AryModVItem
Description: Comments for Function
%END REM

Function SP_AryModVItem(doc As NotesDocument, xIndex As String, itemName As String, source2) As Variant
'// input-doc: notesdocument
'// input-xIndex: 項次  (0~end)
'// input-itemName: 欄位名稱
'// input-source2: 修改後的值
On Error GoTo errorhandler
Dim i As Integer, ub As Integer, nNewIndex As Integer
Dim vtmpValue() As String

Dim NIT As NotesItem
ub = UBound(doc.GetItemValue(itemName))
ReDim tmp(ub) As String
nNewIndex = 0
If ub = 0 Then
tmp(nNewIndex) = source2
Else
For i = 0 To ub
If i = CInt(xIndex) Then
tmp(nNewIndex) = source2
Else
tmp(nNewIndex)=doc.GetItemValue(itemName)(i)
End If
nNewIndex = nNewIndex + 1
Next
End If
Set NIT = doc.ReplaceItemValue( itemName, FullTrim(tmp) )
SP_AryModVItem = FullTrim(tmp)
TheEnd:
Exit Function
ErrorHandler:
Dim strErr As String
strErr = "Librray: SP_UtilityLib / SP_AryModVItem() has error! line =" + CStr(Erl) + ", error = " + Error$
Print strErr
Resume TheEnd
End Function

'//-------------------------------------//'

%REM
Function SP_AryAddItem
Description: Comments for Function
%END REM

Function SP_AryAddItem(sourceArray1, source2) As Variant
On Error GoTo errorhandler
Dim v1 As Variant
If IsArray(sourceArray1) Then
If sourceArray1(0) = "" Then
v1 = source2
Else
'v1 = ArrayAppend(sourceArray1, source2)
If IsArray(source2) Then
ForAll aValue In source2
v1 = ArrayAppend(sourceArray1, aValue)
End ForAll
Else
v1 = ArrayAppend(sourceArray1, source2)
End If
End If
Else
v1 = source2
End If
SP_AryAddItem = v1
TheEnd:
Exit Function
ErrorHandler:
Dim strErr As String
strErr = "Library: SP_UtilityLib / SP_AryAddItem has error!  line = " + CStr(Erl) + ", error = " + Error$
Print strErr
Resume TheEnd
End Function

'//-------------------------------------//'

%REM
Function SP_ArrayAppend
Description: Comments for Function
%END REM

Function SP_ArrayAppend(sourceArray1 As Variant, source2 As Variant ) As Variant
On Error GoTo errorhandler
Dim v1 As Variant
If IsArray(sourceArray1) Then
If sourceArray1(0) = "" Then
v1 = source2
Else
v1 = ArrayAppend(sourceArray1, source2)
End If
Else
v1 = source2
End If
SP_ArrayAppend = v1
TheEnd:
Exit Function
ErrorHandler:
Dim strErr As String
strErr = "Library: SP_ArrayAppend has error! line = " + CStr(erl) + ", error = " + Error$
Print strErr
Resume TheEnd
End Function

'//-------------------------------------//'

Function ModString(doc As NotesDocument, strContent As String, itemName As String, strValue As String) As Variant
%REM
input-doc: notesdocument
input-strContent: 欲修改的項次
input-itemName: 欄位名稱
input-strValue: 異動後的內容
%END REM
Dim i As Integer, ub As Integer
Dim NIT As NotesItem
ub = UBound(doc.GetItemValue(itemName))
'ReDim tmp(ub+1) As String
ReDim tmp(ub) As String
If UBound(doc.GetItemValue(itemName))=0 And doc.GetItemValue(itemName)(0)= "" Then
ub = ub - 1
End If
Dim itmTmp As NotesItem
Set itmTmp = doc.Getfirstitem(Itemname)
'MessageBox "debug - Itemname = " + Itemname + ", " + itmTmp.Values(CInt(strContent))
'If itmTmp.Values(CInt(strContent)) <> strValue Then
' itmTmp.Values(CInt(strContent)) = strValue
'End If
'Dim vAryValue As Variant
For i = 0 To ub
Print "debug - strContent = " +strContent
If strContent = CStr(i) Then
tmp(i)=strValue
Else
tmp(i)=doc.GetItemValue(itemName)(i)
End If
Next
Set NIT = doc.ReplaceItemValue( itemName, FullTrim(tmp) )
ModString = FullTrim(tmp)
End Function

'//-------------------------------------//'

%REM
Function SP_getRefValuebyCode
Description: Comments for Function
%END REM

Function SP_getRefValuebyCode(xCode As String, xType As String) As String
On Error GoTo errorhandler
Dim session As New NotesSession
Dim db As NotesDatabase
Dim sysProfile As NotesDocument
Dim i As Integer
Dim itmField As NotesItem
Dim xReturnValue As String
Set db = session.Currentdatabase
Set sysProfile = SP_getSystemProfileDoc(db)
REM xType : A.廠區 / B.事件類別 / C.通報單位群組
SP_getRefValuebyCode = ""
xReturnValue = ""
Select Case UCase(xType)
Case "A"
Set itmField = sysProfile.Getfirstitem("Fab")
For i = 0 To UBound(sysProfile.FabCode)
If UCase(sysProfile.FabCode(i)) = UCase(xCode) Then
xReturnValue = itmField.Values(i)
Exit for
End If
Next
Case "B"
Set itmField = sysProfile.Getfirstitem("AccidentType")
For i = 0 To UBound(sysProfile.AccidentTypeCode)
If UCase(sysProfile.FabCode(i)) = UCase(xCode) Then
xReturnValue = itmField.Values(i)
Exit For
End If
Next
Case "C"
Set itmField = sysProfile.Getfirstitem("AlertGroup")
For i = 0 To UBound(sysProfile.AlertGroupCode)
If UCase(sysProfile.FabCode(i)) = UCase(xCode) Then
xReturnValue = itmField.Values(i)
Exit For
End If
Next
End Select
SP_getRefValuebyCode = xReturnValue
TheEnd:
Exit Function
ErrorHandler:
Dim strErr As String
strErr = "Library: SP_UtilityLib / SP_getRefValuebyCode has error! line = " + CStr(erl) + ", error = " + Error$
Print strErr
Resume TheEnd
End Function

'//-------------------------------------//'

Function SP_ChkSignType(doc As NotesDocument) As String
'// 檢核簽核文件是加簽(1)還是會簽(2);預設串簽(0)
On Error GoTo errorhandler
Dim session As New NotesSession
Dim db As NotesDatabase
Dim xSignType As String
xSignType = "0"
%REM
Dim itmTmpItem As NotesItem
Set itmTmpItem = doc.Getfirstitem("GTApprCurFlowPerInfo")
If itmTmpItem.Contains("加簽人員") Then
xSignType = "1"
elseIf itmTmpItem.Contains("會簽人員") Then
xSignType = "2"
End If
%END REM
If doc.GTApprPostRoleList(0) = "加簽人員"   Then
xSignType = "1"
End If
SP_ChkSignType = xSignType
TheEnd:
Exit Function
ErrorHandler:
Dim strErr As String
strErr = "Libary: SP_UtilityLib / SP_ChkSignType has error! line = " + CStr(Erl) + ", error = " + Error$
Print strErr
MessageBox strErr, 48, "Warning"
Resume TheEnd
End Function

'//-------------------------------------//'

%REM
Function SP_ChkIsSpecialChar
Description: 檢核是否包含特殊字元
%END REM

Function SP_ChkIsSpecialChar(xSource As String, xPattern As String) As Integer
On Error GoTo errorhandler
Dim session As New NotesSession
Dim db As NotesDatabase
SP_ChkIsSpecialChar = false
'Dim xASCcode As String
'xASCcode = Asc("[^\W_]") 
'If strContains(xSource, xASCcode) = True Then
'End If
Dim re As New RegExp
re.IgnoreCase = True ' 設定是否區分字元大小寫。
re.Global = True ' 設定全域可用性。
If Trim(xPattern) = "" Then
xPattern = "<[^%!&?/\|>]+>"
End If
'Dim xRecord As String
'xRecord = re.Replaces (xSource, "<[^%!&?/\|>]+>", "") '刪除所有特殊字元
Dim bMatch As Boolean
bMatch = re.Match (xSource, xPattern) ' 比對所有特殊字元
'If xRecord <> xSource Then
' SP_ChkIsSpecialChar = True
'End If
If bMatch = True Then
SP_ChkIsSpecialChar = True
End If
TheEnd:
Exit Function
ErrorHandler:
Dim strErr As String
strErr = "Libary: SP_UtilityLib / SP_ChkIsSpecialChar has error! line = " + CStr(Erl) + ", error = " + Error$
Print strErr
MessageBox strErr, 48, "Warning"
Resume TheEnd
End Function

'//-------------------------------------//'

%REM
Function IsRTFNull
Description: Comments for Function
%END REM

Function IsRTFNull(rtfield As String) As Integer
Dim Session As NotesSession
Dim Db As NotesDatabase
Dim ApDoc As NotesDocument           
Dim ws As New NotesUIWorkspace
Dim uidoc As NotesUIDocument
Dim curtDoc As NotesDocument
Dim rtnav As NotesRichTextNavigator
Dim rtlink As NotesRichTextDocLink
Dim agendaIsEmpty As Boolean
Set uidoc = ws.CurrentDocument
Set curtDoc=uidoc.Document
Dim rtf As Variant
Set rtf = curtDoc.GetFirstItem(rtfield)
Set rtnav = rtf.CreateNavigator
If (Trim(uidoc.FieldGetText(rtfield)) <> "") Then '判斷有無文字
agendaIsEmpty=False
IsRTFNull = False
ElseIf  rtnav.FindFirstElement(RTELEM_TYPE_DOCLINK) Then'判斷是否為連結
IsRTFNull = False
Print IsRTFNull
ElseIf Not (rtf.Type = RICHTEXT And IsArray(rtf.embeddedobjects)) Then '無文字時判斷有無附加檔案
agendaIsEmpty=True
IsRTFNull = True
Else
IsRTFNull = False
End If
End Function

'//-------------------------------------//'

Function SP_ChkIsSysEnable() As Integer
On Error GoTo errorhandler
Dim session As New NotesSession
Dim db As NotesDatabase
Dim sysProfile As NotesDocument
'// 系統測試期間系統不啟用
SP_ChkIsSysEnable = False
Set db = session.Currentdatabase
Set sysProfile = db.Getprofiledocument("sysProfile")
If sysProfile Is Nothing Then
MessageBox "not found sysProfile!", 48, "Warning"
Exit Function
End If
If UCase(sysProfile.IsSystemEnable(0)) = "Y"  Then
SP_ChkIsSysEnable = True
End If
TheEnd:
Exit Function
ErrorHandler:
Dim strErr As String
strErr = "Library: SP_UtilityLib / SP_ChkIsSysEnable has error! line = " + CStr(Erl) + ", error = " + Error$
Print strErr
MessageBox strErr, 48, "Warning"
Resume TheEnd
End Function

'//-------------------------------------//'

%REM
Function SP_getProfileDoc
Description: Comments for Function
%END REM

Function SP_getProfileDoc(db As NotesDatabase, xProfileName As String) As NotesDocument
On Error GoTo errorhandler
Dim session As New NotesSession
Dim sysProfile As NotesDocument
'Set db = session.Currentdatabase
Set sysProfile = db.Getprofiledocument(xProfileName)
Set  SP_getProfileDoc = Nothing
If Not sysProfile Is Nothing Then
Set  SP_getProfileDoc = sysProfile
End If
TheEnd:
Exit Function
ErrorHandler:
Dim strErr As String
strErr = "Library: SP_UtilityLib / SP_getProfileDoc has error! line = " + CStr(Erl) + ", error = " + Error$
Print strErr
MessageBox strErr, 48, "Warning"
Resume TheEnd
End Function

'//-------------------------------------//'

Function CountAttachmentsRTF (doc As NotesDocument, rtfFieldName As String) As Integer
'-------------------------------
' Functionality: Counts how many attachments a Rich Text Field holds. 
' Author: Adrian Marikar
' Company: Domino People Ltd
' Date: 12/02/2020
' Dependency
'    IsrtfMT function (https://searchdomino.techtarget.com/tip/Check-Rtf-Field-Empty-New-One-Which-Works)
'-------------------------------
' Error handling: https://www.polymorph.co.uk/content/blog-posts/lotusscript-error-handling-in-a-structured-manner/
  ' Use any error handling method you like. 
  
If True Then
Dim AttachmentsField As Variant
Dim counter As Integer
    
try:
  On Error GoTo catch
  Set AttachmentsField = doc.GetFirstItem(rtfFieldName)
  counter% = 0
    'Use isrtfMT function to validate if rtf is not empty i.e. has attachments or text
  If isrtfMT(doc, rtfFieldName) = 0 Then 
      If IsArray(AttachmentsField.EmbeddedObjects) Then ' Isarray validates for attachments ignoring embedded text
        ForAll att In AttachmentsField.EmbeddedObjects
            If att.Type = EMBED_ATTACHMENT Then
                counter% = counter + 1
            End If
        End ForAll
    Else
    counter = 1 'If embedded text only, then add 1 to counter. 
    End If
  End If
Else
catch:
    On Error GoTo 0
    ' Displays error details to user
'Turn on for debugging
' Msgbox "Fn: CountAttachmentsRTF" & " ERROR: " & Error$ & " (" & Err & ") on line " & Erl
' handle the error
    Select Case Err
    Case Else
        ' an error I can't handle here so pass back to caller
        Error Err, Error$
    End Select
    Resume finally
End If
finally:
CountAttachmentsRTF = counter ' return counter (integer)
End Function

'//-------------------------------------//'

%REM
Function SP_AryDelVItem
Description: Comments for Function
%END REM

Function SP_AryDelVItem(doc As NotesDocument, xIndex As String, itemName As String) As Variant
%REM
input-doc: notesdocument
input-xIndex: 項次  (0~end)
input-itemName: 欄位名稱
%END REM
On Error GoTo errorhandler
Dim i As Integer, ub As Integer, nNewIndex As Integer
Dim vtmpValue() As String
Dim NIT As NotesItem
ub = UBound(doc.GetItemValue(itemName))
ReDim tmp(ub) As String
nNewIndex = 0
If ub = 0 Then
tmp(nNewIndex) = ""
Else
For i = 0 To ub
If i <> CInt(xIndex) Then
tmp(nNewIndex)=doc.GetItemValue(itemName)(i)
nNewIndex = nNewIndex + 1
End If
Next
End If
Set NIT = doc.ReplaceItemValue( itemName, FullTrim(tmp) )
SP_AryDelVItem = FullTrim(tmp)
TheEnd:
Exit Function
ErrorHandler:
Dim strErr As String
strErr = "Librray: SP_UtilityLib / SP_AryDelVItem() has error! line =" + CStr(Erl) + ", error = " + Error$
Print strErr
Resume TheEnd
End Function

'//-------------------------------------//'

%REM
Function SP_CountIF
Description: 檢核資料重覆的次數
input: 
%END REM

Function SP_CountIF(varFromList As Variant, varKeyWord As Variant) As Integer
On Error GoTo errorhandler
Dim nChkCount As Integer
SP_CountIF = 0
Dim bKeyisArray As Boolean
If IsArray(varKeyWord) Then
bKeyisArray = True
Else
bKeyisArray =False
End If
ForAll varElement In varFromList
If bKeyisArray = False Then
If varElement = varKeyWord Then
nChkCount = nChkCount + 1
'SP_CountIF = 1
'Exit ForAll
End If
End If
If bKeyisArray = True Then
ForAll varTarget In varKeyWord
If varElement = varTarget Then
nChkCount = nChkCount + 1
End If
End ForAll
End If
End ForAll
'If bKeyisArray = True Then
'If nChkCount = UBound(varKeyWord) + 1 Then
SP_CountIF = nChkCount
'End If
'End If
TheEnd:
Exit Function
ErrorHandler:
Dim strErr As String
strErr = "Library: SP_UtilityLib / SP_CountIF has error! line = " + CStr(Erl) + ", error = " + Error$
Print strErr
MessageBox strErr, 48, "Warning"
Resume TheEnd
End Function

'//-------------------------------------//'

Function cImplode(anArray As Variant, concatenator As String) As String
'// 多重字串組成一個字元
   Dim tmpString As String
   
   If Not IsArray(anArray) Then
      tmpString = anArray
   Else
      If UBound(anArray) = LBound(anArray) Then
         tmpString = Trim(anArray(LBound(anArray)))
      Else
         ForAll items In anArray
            tmpString = tmpString & items & concatenator
         End ForAll
         ' The concatenator was always added; the last one needs to be removed
         tmpString = Left(tmpString, Len(tmpString) - Len(concatenator))
      End If
   End If
   cImplode = tmpString
End Function

'//-------------------------------------//'

'@Contains(UserDept;WMDept)
%REM
Function strContains
Description: Comments for Function
Check for the existence of an element in an array.
%END REM

Function strContains(varFromList As Variant, varKeyWord As Variant) As Boolean
On Error GoTo errorhandler
Dim nChkCount As Integer
strContains = False
Dim bKeyisArray As Boolean
If IsArray(varKeyWord) Then
bKeyisArray = True
Else
bKeyisArray =False
End If
ForAll varElement In varFromList
If bKeyisArray = False Then
If varElement = varKeyWord Then
strContains = True
Exit ForAll
End If
End If
If bKeyisArray = true Then
ForAll varTarget In varKeyWord
If varElement = varTarget Then
nChkCount = nChkCount + 1
End If
End ForAll
End If
End ForAll
If bKeyisArray = True Then
If nChkCount = UBound(varKeyWord) + 1 Then
strContains = True
End If
End If
TheEnd:
Exit Function
ErrorHandler:
Dim strErr As String
strErr = "error line = " + CStr(erl) + ", error = " + Error$
Print strErr
MessageBox strErr, 48, "Warning"
Resume TheEnd
End Function

'//-------------------------------------//'

Function PopMenu (pstrItem As String, mx As Long, my As Long) As Long
' Pop a menu at coordinates mx, my (pixels)
' or current cursor position if 0,0
' pstrItem is a semicolon-delimited string
' ie: "Item 1;Item 2;-;Item 3"
' A separator is created from a '-'
' Use of ampersand to underline character is Ok
'
' Returns number of item chosen, or 0 if user
' clicks off the menu or presses <Esc>
Const MF_ENABLED = &H0
Const TPM_LEFTALIGN = &H0
Const MF_SEPARATOR = &H800
Const SEP = ";"
Dim msgdata As MSG
Dim rectdata As RECT
Dim Cursor As POINTAPI
ReDim strItem(1 To 20) As String
Dim i As Long
Dim j As Long
Dim last As Long
Dim hMenu As Long
Dim id As Integer
Dim junk As Long
On Error GoTo errorHandling
If Right$(pstrItem, 1) <> SEP Then pstrItem = pstrItem + SEP
j = 1
Do
i = InStr(j, pstrItem, SEP)
If i Then
last = last + 1
strItem(last) = Mid$(pstrItem, j, i - j)
j = i + 1
End If
Loop Until i = 0
hMenu = CreatePopupMenu()
id = 1
For i = 1 To last
If strItem(i) <> "-" Then
junk = AppendMenu(hMenu, MF_ENABLED, id, strItem(i))
id = id + 1
Else
junk = AppendMenu(hMenu, MF_SEPARATOR, 0, "")
End If
Next
If mx = 0 And my = 0 Then
Call GetCursorPos(Cursor)
mx = Cursor.x
my = Cursor.y
End If
junk = TrackPopupMenu(hMenu, TPM_LEFTALIGN, mx, my, 0, GetActiveWindow(), rectdata)
junk = GetMessage(msgdata, GetActiveWindow(), 0, 0)
i = Abs(msgdata.wparam)
If msgdata.message = 273 Then
PopMenu = i
End If
'Call DestroyMenu(hMenu)
Exit Function
errorHandling:
Call DestroyMenu(hMenu) 
Exit Function
End Function

'//-------------------------------------//'

Function AddString(doc As NotesDocument, strContent As String, itemName As String) As Variant
REM This program append the strContent into Field as the next attrib with Name as itemName
REM xdoc.Log_EH= AddString(xdoc, "執行Agent[.資料修正\彈性假異動] " + Server_Time() +" by "+s.UserNameList(0).Abbreviated, "Log_EH")
%REM
input-doc: notesdocument
input-strContent: 項次
input-itemName: 欄位名稱
%END REM
Dim i As Integer, ub As Integer
  Dim NIT As NotesItem
  ub = UBound(doc.GetItemValue(itemName))
  ReDim tmp(ub+1) As String
 
  If UBound(doc.GetItemValue(itemName))=0 And doc.GetItemValue(itemName)(0)= "" Then
  ub = ub - 1
  End If
 
  For i = 0 To ub
  tmp(i)=doc.GetItemValue(itemName)(i)
  Next
 
  i = ub +1
  tmp(i) = strContent
 
  Set NIT = doc.ReplaceItemValue( itemName, FullTrim(tmp) )
  AddString = FullTrim(tmp)
End Function

'//-------------------------------------//'

%REM
Function SP_getSystemProfileDoc
Description: Comments for Function
%END REM

Function SP_getSystemProfileDoc(db As NotesDatabase) As NotesDocument
On Error GoTo errorhandler
Dim session As New NotesSession
Dim sysProfile As NotesDocument
'Set db = session.Currentdatabase
Set sysProfile = db.Getprofiledocument("SysProfile")
Set  SP_GetSystemProfileDoc = nothing
If Not sysProfile Is Nothing Then
Set  SP_GetSystemProfileDoc = sysProfile
End If
TheEnd:
Exit Function
ErrorHandler:
Dim strErr As String
strErr = "Library: SP_UtilityLib / SP_GetSystemProfileDoc has error! line = " + CStr(Erl) + ", error = " + Error$
Print strErr
MessageBox strErr, 48, "Warning"
Resume TheEnd
End Function

'//-------------------------------------//'

%REM
Function SP_GoToField
Description: Comments for Function
%END REM

Function SP_GoToField(uiws As NotesUIWorkspace, xFieldNm As String) As Integer
On Error GoTo errorhandler
Dim uidoc As NotesUIDocument
Set uidoc = uiws.Currentdocument
If Trim(xFieldNm) <> "" Then
Call uidoc.Gotofield(xFieldNm)
End If
'If ChkIsRTFNull("ATH_8") = True Then Call SP_GotoField(pws, "ATH_8") : Error 997, "矯正措施, 其狀態為Done的項目" & Chr(10) & "Error: 請填寫矯正措施 - 權責部門改善附檔!!"
TheEnd:
Exit Function
ErrorHandler:
Dim strErr As String
strErr = "Library: SP_UtilityLib / SP_GotoField has error! line = " + CStr(erl) + ", error = " + Error$
Print strErr
Resume TheEnd
End Function

'//-------------------------------------//'

%REM
Function DeleteString
Description: Comments for Function
%END REM

Function DeleteString(doc As NotesDocument, strContent As String, itemName As String) As Variant
%REM
input-doc: notesdocument
input-strContent: 欲修改的項次
input-itemName: 欄位名稱
%END REM
On Error GoTo errorHandler
Dim i As Integer, ub As Integer
Dim NIT As NotesItem
ub = UBound(doc.GetItemValue(itemName))
'ReDim tmp(ub+1) As String
ReDim tmp(ub) As String
Dim vAryValue As Variant
'If UBound(doc.GetItemValue(itemName))=0 And doc.GetItemValue(itemName)(0)= "" Then
' ub = ub - 1
'End If
Dim nIndex As Integer
nIndex = 0
'nIndex = ArrayGetIndex(doc.GetItemValue(itemName),strContent)
Dim xIndexValue As String
xIndexValue = doc.GetItemValue(itemName)(CInt(strContent))
Dim ndelIndex As Integer
ndelIndex = CInt(strContent)
For i = 0 To ub
'If i <> nIndex Then
'If doc.Getitemvalue(itemName)(i) <> xIndexValue then
If i <> ndelIndex Then
'tmp(nIndex) = ArrayAppend(tmp, doc.Getitemvalue(itemName)(i))
tmp(nIndex) =doc.Getitemvalue(itemName)(i)
nIndex = nIndex +1
End If
Next
Set NIT = doc.ReplaceItemValue( itemName, FullTrim(tmp) )
DeleteString = FullTrim(tmp)
TheEnd:
Exit function
errorHandler:
Dim strErr As String
strErr = "Library: SP_UtilityLib / DeleteString has error! line = " + CStr(erl) + ", error = " + Error$
Print strErr
MessageBox strErr, 48, "Warning"
Resume TheEnd
End Function

'//-------------------------------------//'

%REM
Function SP_ErrorNotice
Description: Comments for Function
%END REM

Function SP_ErrorNotice(doc As NotesDocument, vErrorMsg As Variant) As Integer
'// 發生錯誤時的通知
On Error GoTo errorhandler
Dim session As New NotesSession
Dim db As NotesDatabase
Dim sysProfile As NotesDocument
Dim varSendTo As Variant, varCopyTo As Variant, varBlindCopyTo As Variant
'
Set db = session.Currentdatabase
'
Set sysProfile = db.Getprofiledocument("SysProfile")
If sysProfile Is Nothing Then
MessageBox "not found SySProfile!", 48, "Warning"
Exit Function
End If
'// 檢核是否測試
Dim bTesting As Boolean
If SP_ChkIsTesting() = True Then
bTesting = True   '// ZZZZZZZ  (when system disable)
Else 
bTesting = False
End If
'// TO: developer
If Trim(sysProfile.ITOwnerNotesID(0)) = "" Then
varSendTo = ""
Else
varSendTo = sysProfile.ITOwnerNotesID
End If
'// CC: 
'varCopyTo = "H412工作流程管理"    '// send wam team group
'// mail send
Dim maildoc As NotesDocument
Dim xSubject As String
Dim rtItem As NotesRichTextItem
Dim richStyle As NotesRichTextStyle, rtpStyle As  NotesRichTextParagraphStyle
'// 信件格式
Set maildoc = New NotesDocument(db)
Set rtItem = maildoc.CreateRichTextItem("Body")  
Set richStyle = session.CreateRichTextStyle
richStyle.FontSize = 11
richStyle.NotesFont = RTItem.GetNotesFont("Microsoft JhengHei UI", True)   '// Arial  '// Default Sans Serif
Call rtItem.AppendStyle(richStyle)
Call rtItem.AppendParagraphStyle(rtpStyle)
richStyle.NotesColor = COLOR_BLACK
Call rtItem.AppendStyle(richStyle)
xSubject = db.Title + " >>> " + "程式發生錯誤..."
If bTesting = True Then
xSubject = "[TEST] " + xSubject
End If
maildoc.Form = "Memo"
maildoc.Subject = xSubject
maildoc.SendTo = varSendto
maildoc.CopyTo = varCopyTo
maildoc.BlindCopyTo = varBlindCopyTo
Set rtItem = New NotesRichTextItem(maildoc,"Body")
Call rtItem.AppendText(xSubject)
Call rtItem.AddNewLine(2)
Call rtItem.AppendText("ErrorMsg : " )
Call rtItem.AddNewLine(2)
Call rtItem.AppendText(vErrorMsg)
Call rtItem.AddNewLine(2)
Call rtItem.AppendDocLink(doc,"按圖示可連結至此份文件!!")
If Trim(maildoc.SendTo(0)) <> "" Then
Call maildoc.Send(False,False)
End If
TheEnd:
Exit Function
ErrorHandler:
Dim strErr As String
strErr = "Library: SP_UtilityLib / SP_ErrorNotice has error! line = " + CStr(Erl) + ", error = " + Error$
Print strErr
MessageBox strErr, 48, "Warning"
Resume TheEnd
End Function


'//-------------------------------------//'

Function cExplode(strIn As String, sepstr As String) As Variant
' this function takes an incoming string (strIn) and turns it into an array separating via sepstr
' strIn - incoming string to be converted, e.g. abc;gef;abb;ddd
Dim evalstr As String ' the string combined for evaluate statement
Dim evalRtn As Variant ' the returned results of Evaluate
' check sepstr
If sepstr = "" Then
     sepstr =";"
End If
' test strIn
If strIn="" Then
     cExplode = ""
     Exit Function
Else
' lets do explode
evalstr = |@Trim(@Explode("| + strIn + |"; "| + sepstr + |"))|
evalRtn = Evaluate(evalstr)
End If
cExplode = evalRtn
End Function

'//-------------------------------------//'

Function SP_GetProfileData(ProfileName As String, KeyField As String) As Variant 
'程式名稱：GetProfileData
'程式說明：取得SysProifile中之資料
'應用：
Dim session As New NotesSession
Dim db As NotesDatabase
Dim profiledoc As NotesDocument
Dim itmProfileData As NotesItem
 
Set db = session.CurrentDatabase
Set profiledoc = db.GetProfileDocument(ProfileName)  ' 取得Profile文件
Set itmProfileData= profiledoc.GetFirstItem(KeyField)   ' 取得Profie中欄位
SP_GetProfileData = itmProfileData.text
End Function