Using Upsert SQL query

use NitronTradingBeta
go


drop table price

Create Table dbo.Price
(
PriceId int not null IDENTITY constraint Price_PK PRIMARY KEY,
AsofDate DateTime not null ,
Workbook varchar(255) null,
Worksheet varchar(255) null,
CellAddress varchar(32) null,
ADate DateTime null ,
AValue decimal(30,10) null,
UpdatedOn datetime,
CreatedOn datetime not null,
UpdatedID varchar(32) null,
CreatedByID varchar(32) null,
)

create nonclustered index PRICE_IDX_asOFdATE_aVALUE ON PRICE(AsofDate,Workbook,Worksheet,CellAddress,AValue)
go

create nonclustered index PRICE_IDX_asOFdATE_ADate ON PRICE(AsofDate,Workbook,Worksheet,CellAddress,ADate)
go

select getdate()
select CAST (getdate() as DATE)

select * from price
exec dbo.usp_PriceAddUpdate_AValue 'wbtest','sheet1','A1','2016-01-10',1.00079

drop proc dbo.usp_PriceAddUpdate_AValue

create proc dbo.usp_PriceAddUpdate_AValue
@Workbook varchar(255),
@Worksheet varchar(255),
@CellAddress varchar(255),
@AsofDate Datetime,
@aValue NUMERIC
AS

SET NOCOUNT ON

  DECLARE @rowcount INT;     -- store the number of rows that get inserted

INSERT INTO dbo.Price
 (
WorkBook,
Worksheet,
CellAddress,
AsofDate,
AValue
 )
  SELECT TOP 1                 -- important since we're not constraining any records
Workbook=@Workbook,
Worksheet=@Worksheet,
CellAddress=@CellAddress,
    AsofDate = @AsofDate,
Value=@AValue
 
  FROM Price
  WHERE NOT EXISTS             -- do not want to duplicate
  (
    SELECT 1
    FROM Price
    WHERE
Workbook=@Workbook AND
Worksheet=@Worksheet AND
CellAddress=@CellAddress AND
AsofDate = @AsofDate
  )



  SET @rowcount = @@ROWCOUNT     -- return back the rows that got inserted
   print 'rows affected from insert '+ cast (@rowcount as varchar)

  -- if no rows were inserted, the row must exist, so update
  UPDATE PRICE
  SET AValue = @AValue
  WHERE @rowcount = 0 AND
Workbook=@Workbook AND
Worksheet=@Worksheet AND
CellAddress=@CellAddress AND
AsofDate = @AsofDate
       

ADODB recordset for MS Access Recordset property

Private Sub Form_Open(Cancel As Integer)
   Dim cn As ADODB.Connection
   Dim rs As ADODB.Recordset
        
   'Create a new ADO Connection object
   Set cn = New ADODB.Connection
   'Use the Access 10 and SQL Server OLEDB providers to
   'open the Connection
   'You will need to replace MySQLServer with the name
   'of a valid SQL Server
   With cn
      .Provider = "Microsoft.Access.OLEDB.10.0"
      .Properties("Data Provider").Value = "SQLOLEDB"
      .Properties("Data Source").Value = "SQLServerName"
      .Properties("User ID").Value = "sa"
      .Properties("Password").Value = "pwd"
      .Properties("Initial Catalog").Value = "DBName"
      .Open
   End With
   'Create an instance of the ADO Recordset class, and
   'set its properties
   Set rs = New ADODB.Recordset
   With rs
      Set .ActiveConnection = cn
      .Source = "SELECT * FROM Customers"
      .LockType = adLockOptimistic
      .CursorType = adOpenKeyset
      .Open
   End With
  
   'Set the form's Recordset property to the ADO recordset
   Set Me.Recordset = rs
   Set rs = Nothing
   Set cn = Nothing
End Sub

Enterprise Error Management- Setup phase

Part 1

Private Sub Form_Load()


On Error Resume Next
DoCmd.Hourglass True
Me.Visible = False
DoCmd.OpenForm "Splash"
If Not gbApp_SetupOccurred Then
    Call StartUp    'define public variables because processing was interrupted
    '#If APP_MODE = DEBUG_MODE Then
    '    MsgBox "Just defined public variables"
    '#End If

End If


DoCmd.OpenForm "Preferences", acNormal, windowmode:=acHidden
Call Login
Me.Visible = True
DoCmd.Hourglass False
End Sub


Public Sub StartUp()
'will rename to init globals
'will read from INI file to get path for executable
Dim objCatalog As Object    'ADOX.Catalog
Dim objTable As Object      'ADOX.Table
Dim strAppPath As String
On Error Resume Next


Set objCatalog = CreateObject("ADOX.Catalog")
'Set objCatalog = New ADOX.Catalog
Set objCatalog.ActiveConnection = CurrentProject.Connection

'Set objTable = New ADOX.Table
Set objTable = CreateObject("ADOX.Table")
objTable.Name = "DailyWork"
Set objTable.ParentCatalog = objCatalog
Set objTable = objCatalog.Tables("DailyWork")
strAppPath = JustPathfromFileName(objTable.Properties("Jet OLEDB:Link DataSource"))
Application.TempVars.Add "AppPath", strAppPath
gbApp_SetupOccurred = True

'getAppPath()
'Call SetErrorFilePath(CurrentProject.Path) 'log errors here

Call SetErrorFilePath(strAppPath) 'log errors here

gbDEBUG_MODE = Len(Dir$(AddBS(CurrentProject.Path) & "debug.ini")) > 0

'gsREG_APP=
'APP_NAME = "CPLI App"

End Sub


========================================================
===============   modGeneral code
========================================================


Public Function FileExists(sFullName As String) As Boolean
    Dim bExists As Boolean
    Dim nLength As Integer
 
    nLength = Len(Dir(sFullName))
 
    If nLength > 0 Then
        bExists = True
    Else
        bExists = False
    End If
 
    FileExists = bExists
End Function


Public Function GetShortName(sLongName As String) As String
    Dim sPath As String
    Dim sShortName As String
 
    BreakdownName sLongName, sShortName, sPath

    GetShortName = sShortName
End Function

Public Function JustPathfromFileName(sLongName As String) As String
Dim sPath As String
Dim sShortName As String

BreakdownName sLongName, sShortName, sPath

JustPathfromFileName = sPath
End Function


Sub BreakdownName(sFullName As String, _
                  ByRef sname As String, _
                  ByRef sPath As String)
               
    Dim nPos As Integer
 
    ' Find out where the file name begins
    nPos = FileNamePosition(sFullName)
 
    If nPos > 0 Then
        sname = Right(sFullName, Len(sFullName) - nPos)
        sPath = Left(sFullName, nPos - 1)
    Else
        'Invalid sFullName - don't change anything
    End If
End Sub

Public Variables from modError
Public Const glHANDLED_ERROR As Long = 9999
Public Const glUSER_CANCEL As Long = 18

Public gstrERROR_LOG_PATH As String
Public gbDEBUG_MODE As Boolean
Private Const msSILENT_ERROR As String = "UserCancel"
Private Const msFILE_ERROR_LOG As String = "Error.log"

Public Sub SetErrorFilePath(strPath As String)
'test if folder exists
If Len(strPath) = 0 Then Exit Sub
If Right$(strPath, 1) = "\" Then strPath = Left(strPath, Len(Trim(strPath)) - 1)
gstrERROR_LOG_PATH = strPath
End Sub

'===========================================================
'Author         :William DeCastro
'Created        :08/31/2009
'Last modified  :08/31/2009 1.0 Beta
'Objective      :will Save/update talent plus rate detail to the
'               appropriate tables
'
'Arguments      :
'Sample Call    :
'Called By      :
'===========================================================
Function Login() As Boolean
Const ssource As String = "Login"
Dim varUserAccessLevel As Variant
Dim strCurrentUser As String

On Error GoTo ErrorHandler

strCurrentUser = getWindowsUserId()
varUserAccessLevel = DLookup("UserAccessLevel", "SecurityUser", "[Name]=" & "'" & strCurrentUser & "'")
If IsNull(varUserAccessLevel) Then
    TempVars.Add "UserAccessLevel", UserRole.ReadOnly
    MsgBox "You currently are not in the system and will therefore be assigned minimal rights as a Read Only user.", _
        vbInformation
    Login = True
Else
    TempVars.Add "UserAccessLevel", CInt(varUserAccessLevel)
    Login = True
End If
 
ExitProc:
    On Error Resume Next
    Exit Function

ErrorHandler:
   
    If bCentralErrorHandler(msMODULE, ssource) Then
        Stop
        Resume
    Else
        Resume ExitProc
    End If

End Function



Private Declare Function GetUserName Lib "advapi32.dll" Alias _
"GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Private Declare Function GetComputerName _
Lib "kernel32" Alias "GetComputerNameA" _
(ByVal lpBuffer As String, nSize As Long) As Long

Function getWindowsUserId() As String
' Returns the network login name.
Dim lngLen As Long, lngX As Long
Dim strUserName As String
strUserName = String$(254, 0)
lngLen = 255
lngX = GetUserName(strUserName, lngLen)
If lngX <> 0 Then
    getWindowsUserId = Left$(strUserName, lngLen - 1)
Else
    getWindowsUserId = "Unknown"
End If

End Function


Public Function GetWorkstationId() As String
' Retrieve the name of the computer.
Const acbcMaxComputerName = 15
Dim strBuffer As String
Dim lngLen As Long
strBuffer = Space(acbcMaxComputerName + 1)
lngLen = Len(strBuffer)
If CBool(GetComputerName(strBuffer, lngLen)) Then
    GetWorkstationId = Left$(strBuffer, lngLen)
Else
    GetWorkstationId = ""
End If
End Function

+++++++++++++++++++++++++++++++

Splash code

Private Sub Form_Load()

On Error Resume Next

Me.lblReleaseDate.Caption = Format(DLookup("VersionDate", "tsysconfig_Local"), "General Date")

Me.lblVersion.Caption = "V" & DLookup("VersionNumber", "tsysconfig_Local")

End Sub

Private Sub Form_Timer()

DoCmd.Close acForm, Me.Name

End Sub

++++++++++++++++++++++++++++++++++++++

Public Enum UserRole

    ReadOnly = 1

    System = 2

    NewBusiness = 3

    MarginAnalyst = 4

    MarginAnalystsSupervisor = 5

    Admin = 8

    SuperAdmin = 10

End Enum

Enterprise Error Management- Setup phase

Part 1

Private Sub Form_Load()


On Error Resume Next
DoCmd.Hourglass True
Me.Visible = False
DoCmd.OpenForm "Splash"
If Not gbApp_SetupOccurred Then
    Call StartUp    'define public variables because processing was interrupted
    '#If APP_MODE = DEBUG_MODE Then
    '    MsgBox "Just defined public variables"
    '#End If

End If


DoCmd.OpenForm "Preferences", acNormal, windowmode:=acHidden
Call Login
Me.Visible = True
DoCmd.Hourglass False
End Sub


Public Sub StartUp()
'will rename to init globals
'will read from INI file to get path for executable
Dim objCatalog As Object    'ADOX.Catalog
Dim objTable As Object      'ADOX.Table
Dim strAppPath As String
On Error Resume Next


Set objCatalog = CreateObject("ADOX.Catalog")
'Set objCatalog = New ADOX.Catalog
Set objCatalog.ActiveConnection = CurrentProject.Connection

'Set objTable = New ADOX.Table
Set objTable = CreateObject("ADOX.Table")
objTable.Name = "DailyWork"
Set objTable.ParentCatalog = objCatalog
Set objTable = objCatalog.Tables("DailyWork")
strAppPath = JustPathfromFileName(objTable.Properties("Jet OLEDB:Link DataSource"))
Application.TempVars.Add "AppPath", strAppPath
gbApp_SetupOccurred = True

'getAppPath()
'Call SetErrorFilePath(CurrentProject.Path) 'log errors here

Call SetErrorFilePath(strAppPath) 'log errors here

gbDEBUG_MODE = Len(Dir$(AddBS(CurrentProject.Path) & "debug.ini")) > 0

'gsREG_APP=
'APP_NAME = "CPLI App"

End Sub


========================================================
===============   modGeneral code
========================================================


Public Function FileExists(sFullName As String) As Boolean
    Dim bExists As Boolean
    Dim nLength As Integer
 
    nLength = Len(Dir(sFullName))
 
    If nLength > 0 Then
        bExists = True
    Else
        bExists = False
    End If
 
    FileExists = bExists
End Function


Public Function GetShortName(sLongName As String) As String
    Dim sPath As String
    Dim sShortName As String
 
    BreakdownName sLongName, sShortName, sPath

    GetShortName = sShortName
End Function

Public Function JustPathfromFileName(sLongName As String) As String
Dim sPath As String
Dim sShortName As String

BreakdownName sLongName, sShortName, sPath

JustPathfromFileName = sPath
End Function


Sub BreakdownName(sFullName As String, _
                  ByRef sname As String, _
                  ByRef sPath As String)
               
    Dim nPos As Integer
 
    ' Find out where the file name begins
    nPos = FileNamePosition(sFullName)
 
    If nPos > 0 Then
        sname = Right(sFullName, Len(sFullName) - nPos)
        sPath = Left(sFullName, nPos - 1)
    Else
        'Invalid sFullName - don't change anything
    End If
End Sub

Public Variables from modError
Public Const glHANDLED_ERROR As Long = 9999
Public Const glUSER_CANCEL As Long = 18

Public gstrERROR_LOG_PATH As String
Public gbDEBUG_MODE As Boolean
Private Const msSILENT_ERROR As String = "UserCancel"
Private Const msFILE_ERROR_LOG As String = "Error.log"

Public Sub SetErrorFilePath(strPath As String)
'test if folder exists
If Len(strPath) = 0 Then Exit Sub
If Right$(strPath, 1) = "\" Then strPath = Left(strPath, Len(Trim(strPath)) - 1)
gstrERROR_LOG_PATH = strPath
End Sub

'===========================================================
'Author         :William DeCastro
'Created        :08/31/2009
'Last modified  :08/31/2009 1.0 Beta
'Objective      :will Save/update talent plus rate detail to the
'               appropriate tables
'
'Arguments      :
'Sample Call    :
'Called By      :
'===========================================================
Function Login() As Boolean
Const ssource As String = "Login"
Dim varUserAccessLevel As Variant
Dim strCurrentUser As String

On Error GoTo ErrorHandler

strCurrentUser = getWindowsUserId()
varUserAccessLevel = DLookup("UserAccessLevel", "SecurityUser", "[Name]=" & "'" & strCurrentUser & "'")
If IsNull(varUserAccessLevel) Then
    TempVars.Add "UserAccessLevel", UserRole.ReadOnly
    MsgBox "You currently are not in the system and will therefore be assigned minimal rights as a Read Only user.", _
        vbInformation
    Login = True
Else
    TempVars.Add "UserAccessLevel", CInt(varUserAccessLevel)
    Login = True
End If
 
ExitProc:
    On Error Resume Next
    Exit Function

ErrorHandler:
   
    If bCentralErrorHandler(msMODULE, ssource) Then
        Stop
        Resume
    Else
        Resume ExitProc
    End If

End Function



Private Declare Function GetUserName Lib "advapi32.dll" Alias _
"GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Private Declare Function GetComputerName _
Lib "kernel32" Alias "GetComputerNameA" _
(ByVal lpBuffer As String, nSize As Long) As Long

Function getWindowsUserId() As String
' Returns the network login name.
Dim lngLen As Long, lngX As Long
Dim strUserName As String
strUserName = String$(254, 0)
lngLen = 255
lngX = GetUserName(strUserName, lngLen)
If lngX <> 0 Then
    getWindowsUserId = Left$(strUserName, lngLen - 1)
Else
    getWindowsUserId = "Unknown"
End If

End Function


Public Function GetWorkstationId() As String
' Retrieve the name of the computer.
Const acbcMaxComputerName = 15
Dim strBuffer As String
Dim lngLen As Long
strBuffer = Space(acbcMaxComputerName + 1)
lngLen = Len(strBuffer)
If CBool(GetComputerName(strBuffer, lngLen)) Then
    GetWorkstationId = Left$(strBuffer, lngLen)
Else
    GetWorkstationId = ""
End If
End Function

+++++++++++++++++++++++++++++++

Splash code

Private Sub Form_Load()

On Error Resume Next

Me.lblReleaseDate.Caption = Format(DLookup("VersionDate", "tsysconfig_Local"), "General Date")

Me.lblVersion.Caption = "V" & DLookup("VersionNumber", "tsysconfig_Local")

End Sub

Private Sub Form_Timer()

DoCmd.Close acForm, Me.Name

End Sub

++++++++++++++++++++++++++++++++++++++

Public Enum UserRole

    ReadOnly = 1

    System = 2

    NewBusiness = 3

    MarginAnalyst = 4

    MarginAnalystsSupervisor = 5

    Admin = 8

    SuperAdmin = 10

End Enum

Enterprise grade Error Management (Overview)

In an Enterprise wide application just displaying to the user is not always appropriate.  For example, in a remote server who is going to read a model message box

If this is a critical issue, when do you display a message to the user versus when you log a message to a text file or database

What doe
Adapated from code taken from Rob Bovey's exhaustive book.  

Sample SQL Script to Create table with Foreign Key Constraints

Step 1 :  Creating the tables

drop table SecurityMaster

Create Table SecurityMaster
(
SecurityMasterID int not null identity constraint SecurityMaster_PKSecurityMasterID primary key,
CurrentPurchaseLimit Decimal,
FacilityFee varchar(255),
BasePercentage decimal,
UsedProgram varchar(255),
LCFee decimal,
BasePercentage2 decimal,
SettlementPaymentDateSD date,
SettlementPaymentDateSDType int,
LAFAPool varchar(255),
CalculationCDNextBusinessDay varchar(255),
CalculationCDNextBusinessDayType int,
GRID varchar(255),
CalculationDate datetime,
PaymentDate datetime,
ExpiryDate datetime,
InvoiceDueDate datetime,
FeeToParis decimal,
AdminFee decimal,
EstimatedActualLIBOR decimal,
EstimatedActualLIBORType int,
AmortMatchFounderDeals varchar(255),
AmortMatchFundedDealTypeID int,
Analyst varchar(255),
PM varchar(255),
KeyContacts varchar(255),
CurrentMonthDealStatus varchar(255),
CurrentMonthRenewalEffectiveDate datetime,
YTDDealStatus varchar(255),
YTDRenewalEffectiveDate DateTime
)

alter table SecurityMaster

add foreign key(SettlementPaymentDateSD)
references LK_SettlementPaymentDate(LK_SettlementPaymentDateID)


create table LK_SettlementPaymentDate
(
LK_SettlementPaymentDateID integer identity not null constraint LK_SettlementPaymentDateID primary key,
Description varchar(255)
)

create table LK_EstimatedActualLIBORType
(
LK_EstimatedActualLIBORTypeID integer identity not null
constraint LK_EstimatedActualLIBORTypeID primary key,
Description varchar(255)
)

create table LK_CalculationCDNextSettlementPaymentDate
(
LK_CalculationCDNextSettlementPaymentDateID integer identity not null constraint LK_CalculationCDNextSettlementPaymentDateID primary key,
Description varchar(255)
)


drop table LK_AmountMatchFundedDeal

drop table LK_AmortMatchFoundedDealTypeID

create table LK_AmortMatchFundedDealTypeID
(
LK_AmortMatchFundedDealTypeID integer identity not null constraint LK_AmortMatchFundedDealTypeID_PK primary key,
Description varchar(255)
)

Step 2:  Adding Foreign Key Constraints

alter table SecurityMaster

add foreign key(SettlementPaymentDateSDType)

references LK_SettlementPaymentDate(LK_SettlementPaymentDateID)

-- AmortMATCHFUNDED Deal

alter table SecurityMaster

add foreign key(EstimatedActualLIBORType)

references LK_EstimatedActualLIBORType(LK_EstimatedActualLIBORTypeID)

-- AmortMATCHFUNDED Deal

alter table SecurityMaster

add foreign key(AmortMatchFundedDealTypeID)

references LK_AmortMatchFundedDealTypeID(LK_AmortMatchFundedDealTypeID)

Trips,Trick and Traps: Excel Form Control ListBox/ComboBox

Trips,Trick and Traps: Excel Form Control ListBox/ComboBox

Questions:

1. How to load a ComboBox/ListBox  from an Array
2. How to load a multi-column ComboBox/ListBox?
3. Get the selected entry in a ComboBox/ListBox?
4. Allow the user to make multiple selections in a ListBox?
5. Load values from a range into a ComboBox/ListBox?
6. Select or de-select all the entries in a multi-selectable ListBox?
7. How to load a ComboBox/ListBox  one entry at a time from a source – e.g an array or ADO.Recordset?
8. How to sort the contents of ComboBox/ListBox?
9. Conditionally enable/disable other controls when the user scrolls through the entries in a ComboBox/ListBox?
10. Count the number of entries in a ComboBox/ListBox?

Answers

Building COM DLLs in C# (Part I)

http://www.codeproject.com/Articles/7859/Building-COM-Objects-in-C



How to make a DLL on www.youtube.com


http://stackoverflow.com/questions/7092553/turn-a-simple-c-sharp-dll-into-a-com-interop-component

http://www.csharptutorial.in/21/how-to-make-com-dll-in-csharp-net

Upsizing from Access to SQL Server

Checklist for SQL server



Converting Access queries to SQL Server



Migrating to SQL Server using SSMA

Data Validation Finding required fields that are null in MS Access

Public Sub ProcessTables()
Dim db As DAO.Database
Dim td As DAO.TableDef
Dim strTableName As String

Set db = CurrentDb()

For Each td In db.TableDefs
    strTableName = td.Name
    Debug.Print td.Name
    Call ProcessTableDef(db, td)
Next


ExitProc:
    Set db = Nothing
    Set td = Nothing
    Exit Sub
End Sub


Private Sub ProcessTableDef(db As DAO.Database, td As DAO.TableDef)
Dim fld As DAO.Field
Dim strSQL As String
Dim strTableName As String
Dim strColumnName As String
Dim rst As DAO.Recordset
Dim lngRecordCount As Long

strTableName = td.Name


If Left$(strTableName, 4) = "MSys" Then
    'do nothing
Else
    For Each fld In td.Fields
        strColumnName = fld.Name
        strSQL = "SELECT COUNT(*) FROM " & strTableName & " WHERE " & "[" & strColumnName & "]" & _
            " IS NULL "
        If fld.Type = 101 Or fld.Type = 104 Then
       
        Else
            Set rst = db.OpenRecordset(strSQL, dbOpenSnapshot)
            If Not rst.EOF() Then
                lngRecordCount = CLng(rst.Fields(0).Value)
                If lngRecordCount > 0 Then
                    Debug.Print strTableName, strColumnName, lngRecordCount, strSQL
                End If
            End If
        End If
    Next
End If
Debug.Print ""


End Sub

Using ADO to get path to BackEnd table

Option Compare Database
Option Explicit

#Const DEBUG_MODE = 1
#Const PROD_MODE = 0
#Const APP_MODE = DEBUG_MODE

Private Const msMODULE As String = "modMain"


Function getAppPath() As String
Const ssource As String = "getAppPath"
On Error GoTo ErrorHandler

'Dim objCatalog As Object    'ADOX.Catalog
'Dim objTable As Object      'ADOX.Table

'Set objCatalog = CreateObject("ADOX.Catalog")
'Set objCatalog = New ADOX.Catalog
'Set objCatalog.ActiveConnection = CurrentProject.Connection

'Set objTable = New ADOX.Table
''Set objTable = CreateObject("ADOX.Table")
'objTable.Name = "DailyWork"
'Set objTable.ParentCatalog = objCatalog
'Set objTable = objCatalog.Tables("DailyWork")
'getAppPath = JustPathfromFileName(objTable.Properties("Jet OLEDB:Link DataSource"))
getAppPath = Application.TempVars("AppPath").Value
ExitProc:
    On Error Resume Next
    'Set objCatalog = Nothing
    'Set objTable = Nothing
    Exit Function

ErrorHandler:
   
    If bCentralErrorHandler(msMODULE, ssource) Then
        Stop
        Resume
    Else
        Resume ExitProc
    End If

End Function
Public Sub StartUp()
'will rename to init globals
'will read from INI file to get path for executable
Dim objCatalog As Object    'ADOX.Catalog
Dim objTable As Object      'ADOX.Table
Dim strAppPath As String
On Error Resume Next


Set objCatalog = CreateObject("ADOX.Catalog")
'Set objCatalog = New ADOX.Catalog
Set objCatalog.ActiveConnection = CurrentProject.Connection

'Set objTable = New ADOX.Table
Set objTable = CreateObject("ADOX.Table")
objTable.Name = "DailyWork"
Set objTable.ParentCatalog = objCatalog
Set objTable = objCatalog.Tables("DailyWork")
strAppPath = JustPathfromFileName(objTable.Properties("Jet OLEDB:Link DataSource"))
Application.TempVars.Add "AppPath", strAppPath
gbApp_SetupOccurred = True

'getAppPath()
'Call SetErrorFilePath(CurrentProject.Path) 'log errors here

Call SetErrorFilePath(strAppPath) 'log errors here

gbDEBUG_MODE = Len(Dir$(AddBS(CurrentProject.Path) & "debug.ini")) > 0

'gsREG_APP=
'APP_NAME = "CPLI App"

End Sub

Public Sub SetErrorFilePath(strPath As String)
'test if folder exists
If Len(strPath) = 0 Then Exit Sub
If Right$(strPath, 1) = "\" Then strPath = Left(strPath, Len(Trim(strPath)) - 1)
gstrERROR_LOG_PATH = strPath
End Sub

modMain

Private Sub Form_Open(Cancel As Integer)
' Minimize the database window and initialize the form.

    ' Move to the switchboard page that is marked as the default.
    Me.Filter = "[ItemNumber] = 0 AND [Argument] = 'Default' "
    Me.FilterOn = True
    If Not gbApp_SetupOccurred Then
        Call StartUp    'define public variables because processing was interrupted
        '#If APP_MODE = DEBUG_MODE Then
        '    MsgBox "Just defined public variables"
        '#End If
   
    End If
End Sub


Option Compare Database
Option Explicit

#Const DEBUG_MODE = 1
#Const PROD_MODE = 0
#Const APP_MODE = DEBUG_MODE

Private Const msMODULE As String = "modMain"


Function getAppPath() As String
Const ssource As String = "getAppPath"
On Error GoTo ErrorHandler

'Dim objCatalog As Object    'ADOX.Catalog
'Dim objTable As Object      'ADOX.Table

'Set objCatalog = CreateObject("ADOX.Catalog")
'Set objCatalog = New ADOX.Catalog
'Set objCatalog.ActiveConnection = CurrentProject.Connection

'Set objTable = New ADOX.Table
''Set objTable = CreateObject("ADOX.Table")
'objTable.Name = "DailyWork"
'Set objTable.ParentCatalog = objCatalog
'Set objTable = objCatalog.Tables("DailyWork")
'getAppPath = JustPathfromFileName(objTable.Properties("Jet OLEDB:Link DataSource"))
getAppPath = Application.TempVars("AppPath").Value
ExitProc:
    On Error Resume Next
    'Set objCatalog = Nothing
    'Set objTable = Nothing
    Exit Function

ErrorHandler:
   
    If bCentralErrorHandler(msMODULE, ssource) Then
        Stop
        Resume
    Else
        Resume ExitProc
    End If

End Function

Public Sub StartUp()
'will rename to init globals
'will read from INI file to get path for executable
Dim objCatalog As Object    'ADOX.Catalog
Dim objTable As Object      'ADOX.Table
Dim strAppPath As String
On Error Resume Next


Set objCatalog = CreateObject("ADOX.Catalog")
'Set objCatalog = New ADOX.Catalog
Set objCatalog.ActiveConnection = CurrentProject.Connection

'Set objTable = New ADOX.Table
Set objTable = CreateObject("ADOX.Table")
objTable.Name = "DailyWork"
Set objTable.ParentCatalog = objCatalog
Set objTable = objCatalog.Tables("DailyWork")
strAppPath = JustPathfromFileName(objTable.Properties("Jet OLEDB:Link DataSource"))
Application.TempVars.Add "AppPath", strAppPath
gbApp_SetupOccurred = True

'getAppPath()
'Call SetErrorFilePath(CurrentProject.Path) 'log errors here

Call SetErrorFilePath(strAppPath) 'log errors here

gbDEBUG_MODE = Len(Dir$(AddBS(CurrentProject.Path) & "debug.ini")) > 0

'gsREG_APP=
'APP_NAME = "CPLI App"

End Sub

modGeneral

Option Compare Database

Option Explicit

#Const DEBUG_MODE = 1

#Const PROD_MODE = 0

#Const APP_MODE = DEBUG_MODE

Public Const msMODULE As String = "modGeneral"

Public Enum OfficeProduct

    Access2007Only = 1

    [MSAccess95-2003]

    Excel2007Only

    [MSExcel95-2003]

    [XML]

End Enum

Public Function FixSingleQuotes(varValue As Variant) As String

Const SINGLEQUOTE = "'"

FixSingleQuotes = SINGLEQUOTE & _

                     Replace(varValue, SINGLEQUOTE, SINGLEQUOTE & SINGLEQUOTE) & _

                     SINGLEQUOTE

End Function

Public Function FixSQLforRecordset(varValue As Variant) As Variant

Const SINGLEQUOTE = "'"

If IsNull(varValue) Then Exit Function

FixSQLforRecordset = Replace(varValue, SINGLEQUOTE, SINGLEQUOTE & SINGLEQUOTE)

End Function

Function getSaveAs2(iOfficeVersion As OfficeProduct, _

    Optional bAllowMultiSelect As Boolean = False, _

    Optional strInitialFileName As String) As String

Const ssource As String = "getSaveAs2"

Dim fDialog As Office.FileDialog

On Error GoTo ErrorHandler

' Requires reference to Microsoft Office 11.0 Object Library.

' Set up the File Dialog.

'Set fDialog = Application.FileDialog(msoFileDialogFilePicker)

Set fDialog = Application.FileDialog(msoFileDialogSaveAs)

With fDialog

    '.AllowMultiSelect = bAllowMultiSelect

          

    'If Len(strInitialFileName) Then

     '   .InitialFileName = strInitialFileName

    'End If

    ' Set the title of the dialog box.

    .Title = "Please select one or more files"

    ' Clear out the current filters, and add our own.

    If .Filters.Count > 0 Then

        '.Filters.Clear

    End If

    'Select Case iOfficeVersion

       ' Case OfficeProduct.Excel2007Only

           ' .Filters.Add "Excel 2007 Workbooks", "*.XLSX"

           ' .Filters.Add "All Files", "*.*"

      '  Case OfficeProduct.Access2007Only

      '      .Filters.Add "Access Databases", "*.MDB"

      '      .Filters.Add "Access Projects", "*.ADP"

      '      .Filters.Add "All Files", "*.*"

        

      '  Case Else

      '      .Filters.Add "All Files", "*.*"

    'End Select

    

      ' Show the dialog box. If the .Show method returns True, the

      ' user picked at least one file. If the .Show method returns

      ' False, the user clicked Cancel.

    If .Show Then

        getSaveAs2 = .SelectedItems(1)

    End If

End With

ExitProc:

    On Error Resume Next

    Set fDialog = Nothing

    Exit Function

ErrorHandler:

    

    If bCentralErrorHandler(msMODULE, "getSaveAs2") Then

        Stop

        Resume

    Else

        Resume ExitProc

    End If

End Function

Function getFolderDestination(Optional strInitialFileName As String) As String

Const ssource As String = "getSaveAs2"

Dim fDialog As Office.FileDialog

On Error GoTo ErrorHandler

' Requires reference to Microsoft Office 11.0 Object Library.

' Set up the File Dialog.

'Set fDialog = Application.FileDialog(msoFileDialogFilePicker)

Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)

With fDialog

    

    If Len(strInitialFileName) Then

        .InitialFileName = strInitialFileName

    End If

    ' Set the title of the dialog box.

    '.Title = "Please select one or more files"

    

      ' Show the dialog box. If the .Show method returns True, the

      ' user picked at least one file. If the .Show method returns

      ' False, the user clicked Cancel.

    If .Show Then

        getFolderDestination = .SelectedItems(1)

    End If

End With

ExitProc:

    On Error Resume Next

    Set fDialog = Nothing

    Exit Function

ErrorHandler:

    

    If bCentralErrorHandler(msMODULE, "getSaveAs2") Then

        Stop

        Resume

    Else

        Resume ExitProc

    End If

End Function

Function getFileOpen2(iOfficeVersion As OfficeProduct, _

    Optional bAllowMultiSelect As Boolean = False, _

    Optional strInitialFileName As String, _

    Optional ByVal strTitle As String) As String

Const ssource As String = "getFileOpen2"

Dim fDialog As Office.FileDialog

On Error GoTo ErrorHandler

' Requires reference to Microsoft Office 11.0 Object Library.

' Set up the File Dialog.

Set fDialog = Application.FileDialog(msoFileDialogFilePicker)

'Set fDialog = Application.FileDialog(msoFileDialogSaveAs)

With fDialog

    .AllowMultiSelect = bAllowMultiSelect

          

    'If Len(strInitialFileName) Then

     '   .InitialFileName = strInitialFileName

    'End If

    ' Set the title of the dialog box.

    If Len(strTitle) > 0 Then

        .Title = strTitle

    Else

        .Title = "Please select one or more files"

    End If

    

    ' Clear out the current filters, and add our own.

    .Filters.Clear

    Select Case iOfficeVersion

        Case OfficeProduct.Excel2007Only

            .Filters.Add "Excel 2007 Workbooks", "*.XLSX"

            .Filters.Add "All Files", "*.*"

        Case OfficeProduct.Access2007Only

            .Filters.Add "Access Databases", "*.MDB"

            .Filters.Add "Access Projects", "*.ADP"

            .Filters.Add "All Files", "*.*"

            

        Case OfficeProduct.XML

           ' .Filters.Add "All Files", "*.*"

            .Filters.Add "XML Files", "*.XML"

            

        

        Case Else

            .Filters.Add "All Files", "*.*"

    End Select

    

      ' Show the dialog box. If the .Show method returns True, the

      ' user picked at least one file. If the .Show method returns

      ' False, the user clicked Cancel.

    If .Show Then

        getFileOpen2 = .SelectedItems(1)

    End If

End With

ExitProc:

    On Error Resume Next

    Set fDialog = Nothing

    Exit Function

ErrorHandler:

    

    If bCentralErrorHandler(msMODULE, "getSaveAs2") Then

        Stop

        Resume

    Else

        Resume ExitProc

    End If

End Function

Public Function FeatureNotAvailibleYet() As Boolean

MsgBox "In development but feature is not availible yet ", vbInformation

End Function

Public Function isLoaded(strFormName As String) As Boolean

Const FORMOPEN = -1

Const FORMCLOSED = 0

If SysCmd(acSysCmdGetObjectState, acForm, strFormName) <> FORMCLOSED Then

    isLoaded = True

Else

    isLoaded = False

End If

End Function

Function CheckFieldSize2(ctrl As Control, strFieldName As String, intMaxSize As Integer) As Boolean

Dim strValue As String

Dim strMsg As String

strValue = Nz(ctrl.Value, "")

If Len(strValue) > intMaxSize Then

    'warn the user

    strMsg = "The " & strFieldName & " field can only accept a maximum of " & _

    intMaxSize & " characters " & "The field has been truncated to the maximum size"

    MsgBox strMsg, vbCritical, "Validate Control"

End If

End Function

Public Function CanNavigateInForm(iMode As ACTION_MODE) As Boolean

'checks to see if the user is currently updating/adding a record before navigating

'to another record

Dim strErrorMsg As String

strErrorMsg = "You can't select another record while updating the existing record. Either continue " & _

    "your actions or hit cancel to move off the current record."

If iMode <> ACTION_MODE.navigate Then

    MsgBox strErrorMsg, vbInformation, "Invalid record movement"

    CanNavigateInForm = False

Else

    CanNavigateInForm = True

End If

End Function

Function CanCloseWindow(iMode As ACTION_MODE) As Boolean

If iMode <> navigate Then

    MsgBox "Can't close while updating or adding the record." & vbCrLf & _

    "Please first complete action or cancel updating/editing", vbInformation, "Confirm action"

    CanCloseWindow = False

Else

    CanCloseWindow = True

End If

End Function

Function setOrderBy(f As SubForm, PrimarySort As String, Optional SecondarySort, _

    Optional TertiarySort) As Boolean

Const ssource As String = "setOrderBy"

Dim strOrderByClause As String

On Error GoTo ErrorHandler

strOrderByClause = PrimarySort

If Len(SecondarySort) Then

    strOrderByClause = strOrderByClause & "," & SecondarySort

End If

If Len(TertiarySort) Then

    strOrderByClause = strOrderByClause & "," & TertiarySort

End If

With f.Form

    .OrderBy = strOrderByClause

    .OrderByOn = True

End With

ExitProc:

    On Error Resume Next

    

    Exit Function

ErrorHandler:

    

    If bCentralErrorHandler(msMODULE, ssource) Then

        Stop

        Resume

    Else

        Resume ExitProc

    End If

End Function

Public Sub ReLogin()

On Error Resume Next

If CurrentProject.AllForms("frmlogon").isLoaded Then

    Forms!frmLogon.Visible = True

Else

    MsgBox "frmlogon has been inadvertly closed"

End If

End Sub

Public Sub ChangePreferences()

On Error Resume Next

If CurrentProject.AllForms("Preferences").isLoaded Then

    Forms!Preferences.Visible = True

Else

    'MsgBox "Preferences has been inadvertly closed"

    DoCmd.OpenForm "Preferences", , , , , acHidden

End If

End Sub

Function CheckFieldSize(ctrl As Control, strFieldName As String, intMaxSize As Integer) As Boolean

Const ssource As String = "CheckFieldSize"

Dim strValue As String

Dim strMsg As String

On Error GoTo ErrorHandler

strValue = Nz(ctrl.Value, "")

If Len(strValue) > intMaxSize Then

    On Error GoTo 0

    Err.Raise vbObjectError + 1, "The " & strFieldName & _

        " can only accept a maximum of " & intMaxSize & " characters." & _

        "The field has been truncated to the maximum size", ssource

    CheckFieldSize = False

Else

    CheckFieldSize = True

End If

ExitProc:

    On Error Resume Next

    

    Exit Function

ErrorHandler:

    

    If bCentralErrorHandler(msMODULE, ssource) Then

        Stop

        Resume

    Else

        Resume ExitProc

    End If

End Function

Public Function bOkToOverWrite(sFullName As String) As Boolean

Dim sMsg As String

Dim nButtons As Long

Dim nResponse As Long

Dim bOverwrite As Boolean

bOverwrite = False

sMsg = sFullName & " already exists.  Do you want to overwrite it?"

nButtons = vbYesNoCancel + vbExclamation + vbDefaultButton2

nResponse = MsgBox(sMsg, nButtons, "Overwrite File?")

If nResponse = vbYes Then

    bOverwrite = True

End If

bOkToOverWrite = bOverwrite

End Function

Public Function FileExists(sFullName As String) As Boolean

    Dim bExists As Boolean

    Dim nLength As Integer

    

    nLength = Len(Dir(sFullName))

    

    If nLength > 0 Then

        bExists = True

    Else

        bExists = False

    End If

    

    FileExists = bExists

End Function

Public Function GetShortName(sLongName As String) As String

    Dim sPath As String

    Dim sShortName As String

    

    BreakdownName sLongName, sShortName, sPath

    GetShortName = sShortName

End Function

Public Function JustPathfromFileName(sLongName As String) As String

Dim sPath As String

Dim sShortName As String

BreakdownName sLongName, sShortName, sPath

JustPathfromFileName = sPath

End Function

Sub BreakdownName(sFullName As String, _

                  ByRef sname As String, _

                  ByRef sPath As String)

                  

    Dim nPos As Integer

    

    ' Find out where the file name begins

    nPos = FileNamePosition(sFullName)

    

    If nPos > 0 Then

        sname = Right(sFullName, Len(sFullName) - nPos)

        sPath = Left(sFullName, nPos - 1)

    Else

        'Invalid sFullName - don't change anything

    End If

End Sub

' Returns the position or index of the first

' character of the file name given a full name

' A full name consists of a path and a filename

' Ex. FileNamePosition("C:\Testing\Test.txt") = 11

Public Function FileNamePosition(sFullName As String) As Integer

    Dim bFound As Boolean

    Dim nPosition As Integer

    

    bFound = False

    nPosition = Len(sFullName)

    

    Do While bFound = False

        ' Make sure we were not dealt a

        ' zero-length string

        If nPosition = 0 Then Exit Do

        

        ' We are looking for the first "\"

        ' from the right.

        If Mid(sFullName, nPosition, 1) = "\" Then

            bFound = True

        Else

            ' Working right to left

            nPosition = nPosition - 1

        End If

    Loop

    

    If bFound = False Then

        FileNamePosition = 0

    Else

        FileNamePosition = nPosition

    End If

End Function

Function SendEmailviaOutLook(strTo As String, strSubject As String, _

    strBody As String, aAttachments As Variant)

Const ssource As String = "SendEmailviaOutLook"

Dim objOutlook As Object    'Outlook.Application

Dim objMail As Object       'Outlook.MailItem

Dim i As Integer

Dim bSendOut As Boolean

On Error GoTo ErrorHandler

DoCmd.Hourglass True

On Error Resume Next

Set objOutlook = GetObject(, "Outlook.Application")

bSendOut = Not (objOutlook Is Nothing)

On Error GoTo ErrorHandler

If bSendOut Then

    With objOutlook

        'Set objMail = objOutlook.CreateItem(olMailItem)

        Set objMail = objOutlook.CreateItem(0)

        With objMail

           '

            .To = strTo

            '.BodyFormat = olFormatHTML

            '.HTMLBody = strBody

            .Body = strBody

            .Subject = strSubject

           For i = LBound(aAttachments) To UBound(aAttachments)

                .Attachments.Add aAttachments(i)

           Next

            '.Display

            .Send

            

        End With

    End With

    Set objMail = Nothing

    '--------- part C ----------

    'send the email out to the client

    SendEmailviaOutLook = True

End If

ExitProc:

    On Error Resume Next

    Set objOutlook = Nothing

    Set objMail = Nothing

    DoCmd.Hourglass False

    Exit Function

ErrorHandler:

    If Err.Number = 429 Then

        'Outlook is not running so try again with CreateObject

        Set objOutlook = CreateObject("Outlook.Application")

        Resume Next

    ElseIf bCentralErrorHandler(msMODULE, ssource) Then

        Stop

        Resume

    Else

        Resume ExitProc

    End If

End Function