Bulk Send Wizard (Access VBA)

Option Compare Database
Option Explicit
Private Const msMODULE As String = "BulkSendWizard"
#Const DEBUG_MODE = 1
#Const PROD_MODE = 0
#Const APP_MODE = DEBUG_MODE
Dim CurrentStatus As Integer

Public Enum WizardScreen
    PickaFolder = 0
    PickAFileName
    PickEmailTo
    PickWhethereToZip
End Enum
Private m_bOk As Boolean

Public Property Get bOK() As Boolean
bOK = m_bOk
End Property

Private Sub cmdBrowse_Click()
Const ssource As String = "cmdNext_Click"
Dim strOutputFolder As String
On Error GoTo ErrorHandler

'strOutputFolder = BrowseFolder("Output folder for client statements")
strOutputFolder = getFolderDestination(Nz(Me.txtOutputFolder))
If Len(strOutputFolder) Then
    Me.txtOutputFolder.Value = strOutputFolder
    Call VerifyDupeFileNames
End If
ExitProc:
   On Error Resume Next
   Exit Sub
   
ErrorHandler:
    If bCentralErrorHandler(msMODULE, ssource, , bEntryPoint:=True) Then
        Stop
        Resume
    Else
        Resume ExitProc
    End If
End Sub

Private Sub cmdNext_Click()
Const ssource As String = "cmdNext_Click"
On Error GoTo ErrorHandler

Dim CTab As Integer
   
    If ValidateData(CurrentStatus) = 1 Then
    'advance for next tab and setup up stuff
        CurrentStatus = CurrentStatus + 1
        ValidateButton (CurrentStatus)
            CTab = Me.tabWizard.Value + 1
            If CTab = Me.tabWizard.Pages.Count Then
                Else
           
                Me.tabWizard.Pages(CTab).SetFocus
            End If
    Else
        MsgBox ("Please complete the information"), vbInformation, "Incomplete information"
    End If

ExitProc:
   On Error Resume Next
   Exit Sub
   
ErrorHandler:
    If bCentralErrorHandler(msMODULE, ssource, , bEntryPoint:=True) Then
        Stop
        Resume
    Else
        Resume ExitProc
    End If
End Sub

Private Sub cmdPrevious_Click()
Const ssource As String = "cmdClientAdd_Click"
On Error GoTo ErrorHandler
Dim CTab As Integer

CurrentStatus = CurrentStatus - 1
ValidateButton (CurrentStatus)
CTab = Me.tabWizard.Value - 1
If CTab < 0 Then
Else
    Me.tabWizard.Pages(CTab).SetFocus
End If

ExitProc:
   On Error Resume Next
   Exit Sub
   
ErrorHandler:
    If bCentralErrorHandler(msMODULE, ssource, , bEntryPoint:=True) Then
        Stop
        Resume
    Else
        Resume ExitProc
    End If
End Sub


Private Sub cmdCancel_Click()
On Error Resume Next
'DoCmd.Close
Me.Visible = False
End Sub



Private Sub Form_Open(Cancel As Integer)
Dim COB_Date As Date
Dim intRegion As Integer
Dim strSQL As String

On Error Resume Next
Me.chkZipFile.Value = False
Me.chkZipFile.Enabled = False
Me.txtOutputFolder = getAppPath() & "\output"
CurrentStatus = 0
ValidateButton (CurrentStatus)

COB_Date = CDate(Forms!SentDailyWork!tvCOBDates.SelectedItem.Text)
Me.lblErrorCount.Caption = vbNullString
intRegion = getClientLocationId()
'Call loadEmailInfo(Me.lvEmailInfo, COB_Date, intRegion)
strSQL = "SELECT Client.ClientID, Client.ClientName, Client.Email as [To:], " & _
    "DailyWork.COB_Date, Client.ClientLocationID " & _
    "FROM Client INNER JOIN DailyWork ON Client.ClientID = DailyWork.ClientID " & _
    " WHERE DailyWork.COB_Date =#" & COB_Date & "#" & _
    " AND DailyWork.DailyWorkStatusID=2 " & _
    " And Client.ClientLocationID= " & intRegion & _
    " ORDER BY Client.ClientName "
With Me.lbEmailInfo
    .RowSource = strSQL
    .Requery
End With

Call loadListView(COB_Date)
End Sub

Private Sub ValidateButton(StatusId As Integer)
Const ssource As String = "cmdClientAdd_Click"
On Error GoTo ErrorHandler
   
    Select Case StatusId
       
        Case WizardScreen.PickaFolder
            CmdNext.SetFocus
            CmdPrevious.Visible = False
   
        Case WizardScreen.PickAFileName, WizardScreen.PickEmailTo
       
            CmdPrevious.Visible = True
            CmdNext.Caption = "Next>"
       
        Case WizardScreen.PickEmailTo
            CmdNext.Caption = "&Finish"
       
        Case WizardScreen.PickWhethereToZip
            CmdNext.Caption = "&Finish"
           
        Case 4
       
            'MsgBox "will finish now"
            m_bOk = True
            'DoCmd.Close acForm, Me.Name
            Me.Visible = False
            Exit Sub
           
    End Select
   

ExitProc:
   On Error Resume Next
   Exit Sub
   
ErrorHandler:
    If bCentralErrorHandler(msMODULE, ssource, , bEntryPoint:=True) Then
        Stop
        Resume
    Else
        Resume ExitProc
    End If
End Sub

Private Function ValidateData(StatusId As Integer) As Integer
Const ssource As String = "ValidateData"
On Error GoTo ErrorHandler

    Select Case StatusId
            Case 0  ' get Name ans Address
                'If IsNull(CustomerName) Or CustomerName = "" Then
                '    ValidateData = 0
                'ElseIf IsNull(CustomerAddress) Or CustomerAddress = "" Then
                '    ValidateData = 0
                'Else
                ValidateData = 1
                'End If

            Case 1
                'If IsNull(Country) Or Country = "" Then
                '    ValidateData = 0
                'ElseIf IsNull(PostalCode) Or PostalCode = "" Then
                '    ValidateData = 0
               ' Else
                ValidateData = 1
               ' End If

            Case 2
                'If IsNull(Phone) Or Phone = "" Then
                '    ValidateData = 0
               ' ElseIf IsNull(Fax) Or Fax = "" Then
               '     ValidateData = 0
               ' Else
                ValidateData = 1
               ' End If
   
   
            Case WizardScreen.PickWhethereToZip
                'will do the finally validation
               
                If IsNull(Me.txtOutputFolder) Or Len(Me.txtOutputFolder) = 0 Then
                   
                    MsgBox "Need a output folder location", vbInformation, "Validate Controls"
                    ValidateData = 0
                ElseIf Len(Me.lblErrorCount.Caption) > 0 Then
                    Call MsgBox(Me.lblErrorCount.Caption & "." & vbNewLine & _
                    "Please rename those files", vbCritical, "Validate Controls")
                    ValidateData = 0
                   
                Else
                    ValidateData = 1
                End If
              

            Case Else
                ValidateData = 1
   
    End Select
   

ExitProc:
    On Error Resume Next
    Exit Function

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

Function loadListView(COB_Date As Date) As Boolean
Const ssource As String = "loadSecurityUserQueue"
Dim strSQL As String
Dim objLVSentDailyWork As Object, LV As Object
Dim objli As ListItem, objLINew As ListItem
Dim i As Integer
Dim strFileName As String, strFullPathName As String
Dim strOutputPath As String

On Error GoTo ErrorHandler
Set objLVSentDailyWork = Forms!SentDailyWork!lvHistory
Set LV = Me.lvFileName
strOutputPath = AddBS(Me.txtOutputFolder.Value)

With LV

    'clear out old data
    .ListItems.Clear
    .ColumnHeaders.Clear

    'define headers
    .ColumnHeaders.Add , , "Client ID", 0
    .ColumnHeaders.Add , , "COB_Date", 1100, lvwColumnRight
    .ColumnHeaders.Add , , "Client Name", 0
    .ColumnHeaders.Add , , "File Name", 4320, lvwColumnLeft
    .ColumnHeaders.Add , , "Dupe", 720, lvwColumnCenter

  
    For Each objli In objLVSentDailyWork.ListItems
           Set objLINew = LV.ListItems.Add(, , Nz(objli.Text))
           With objLINew
                .SubItems(1) = Format(COB_Date, MASK_DATE)
                .SubItems(2) = objli.SubItems(4)
                strFileName = Format(COB_Date, "yyyymmdd") & _
                Space(1) & objli.SubItems(4) & " Statement" & ".pdf"
                .SubItems(3) = strFileName
                '.SubItems(4) = ""
            End With
           
     Next
     Call VerifyDupeFileNames
End With
   
loadListView = True
ExitProc:
    On Error Resume Next
    Set objli = Nothing
   
    Exit Function

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

Function VerifyDupeFileNames() As Boolean
Const ssource As String = "VerifyDupeFileNames"
Dim strSQL As String
Dim LV As Object
Dim objli As ListItem
Dim i As Integer
Dim strFileName As String, strFullPathName As String
Dim strOutputPath As String
Dim objfsh As Scripting.FileSystemObject

On Error GoTo ErrorHandler

Set LV = Me.lvFileName
strOutputPath = AddBS(Me.txtOutputFolder.Value)
Set objfsh = CreateObject("Scripting.FileSystemObject")
For Each objli In LV.ListItems
   
    With objli
         strFileName = .SubItems(3)
          strFullPathName = strOutputPath & strFileName
         
         .SubItems(4) = Format$(objfsh.FileExists(strFullPathName), "Yes/No")
    End With
Next
    
Call CalcErrors
VerifyDupeFileNames = True
ExitProc:
    On Error Resume Next
    Set objli = Nothing
    Set LV = Nothing
   
   
    Exit Function

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

Function CalcErrors() As Boolean
Const ssource As String = "CalcErrors"
Dim strSQL As String
Dim LV As Object
Dim objli As ListItem
Dim i As Integer
Dim iErrorCount As Integer

On Error GoTo ErrorHandler

Set LV = Me.lvFileName

For Each objli In LV.ListItems
    With objli
        If Mid$(.SubItems(4), 1, 1) = "Y" Then
            iErrorCount = iErrorCount + 1
        End If
    End With
Next
    
If iErrorCount Then
    Me.lblErrorCount.Caption = Format(iErrorCount, "#,##0") & " file conflict error(s)"
Else
    Me.lblErrorCount.Caption = vbNullString
End If

CalcErrors = True
ExitProc:
    On Error Resume Next
    Set objli = Nothing
    Set LV = Nothing
    Exit Function

ErrorHandler:
   
    If bCentralErrorHandler(msMODULE, ssource) Then
        Stop
        Resume
    Else
        Resume ExitProc
    End If
   
End Function
   
Function loadEmailInfo(ByRef LV As CustomControl, _
    ByVal asofDate As Date, _
    ByVal Region As Integer) As Boolean
   
Const ssource As String = "loadEmailInfo"
On Error GoTo ErrorHandler
Dim strSQL As String
Dim rs As ADODB.Recordset
Dim objConn As ADODB.Connection
Dim objli As ListItem
Dim i As Integer

Dim objCatalog As ADOX.Catalog
Dim objCmd As ADODB.Command
Dim strQueryName As String

   
strQueryName = "qryClientgetEmailInfo"

Set objCatalog = New ADOX.Catalog
Set objCatalog.ActiveConnection = CurrentProject.Connection

Set objCmd = New ADODB.Command
Set objCmd = objCatalog.Procedures(strQueryName).Command
objCmd.Parameters(0).Value = asofDate
objCmd.Parameters(1).Value = Region

    LV.ListItems.Clear
    Set rs = objCmd.Execute
   
    LV.ColumnHeaders.Clear
    LV.ColumnHeaders.Add , , "ID", 0
    LV.ColumnHeaders.Add , , "Client Name", 2880, lvwColumnLeft
    LV.ColumnHeaders.Add , , "To:", 2880
   
    If Not (rs.EOF() And rs.BOF) Then
        Do While Not rs.EOF
           Set objli = LV.ListItems.Add(, , Nz(rs.Fields("ClientID").Value))
           With objli
                .SubItems(1) = Nz(rs.Fields("ClientName").Value)
                .SubItems(2) = Nz(rs.Fields("Email").Value)
            End With
            rs.MoveNext
        Loop
        loadEmailInfo = (LV.ListItems.Count > 0)
    End If
   
ExitProc:
    On Error Resume Next
    Set rs = Nothing
    Set objConn = Nothing
    Exit Function

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

End Function

Save As File Dialog in Access VBA

 Private Sub cmdBrowse_Click()
Const ssource As String = "cmdNext_Click"
Dim strOutputFolder As String
On Error GoTo ErrorHandler

'strOutputFolder = BrowseFolder("Output folder for client statements")
strOutputFolder = getFolderDestination(Nz(Me.txtOutputFolder))
If Len(strOutputFolder) Then
    Me.txtOutputFolder.Value = strOutputFolder
  
End If
ExitProc:
   On Error Resume Next
   Exit Sub
  
ErrorHandler:
    If bCentralErrorHandler(msMODULE, ssource, , bEntryPoint:=True) Then
        Stop
        Resume
    Else
        Resume ExitProc
    End If
End Sub

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

How to correctly release object variables in ADO

Connection object

Cnxn.Open sConnString     '"Provider=OraOLEDB.Oracle;Data Source=(DESCRIPTION=(CID=JCGPRD01)(ADDRESS_LIST=(ADDRESS=(PROTOCOL=TCP)(HOST=JCG04AW.vsp.sas.com)(PORT=6660)))(CONNECT_DATA=(SID=JCGPRD01)(SERVER=DEDICATED)));User Id=jcg0vbapp;Password=oyv3re8d4;"
          '
100       If Cnxn.State <> adStateOpen Then

110          sMsg = "**** ERROR Could Not Open Connection to File! ****" & vbCrLf & vbCrLf & _
                       "in Module 'modUtils' - Function 'Fetch_TD_Data'" & vbCrLf & "Line # " & 90 & vbCrLf & _
                       vbCrLf & " SQL: '" & strSQL & "'"
120          vLogMsg = sMsg
130          MsgLog

140          GoTo Fetch_TD_Data_Exit
150       End If

 Recordset object
Set rs = New ADODB.Recordset
190       strSQL = cnstLOCK_ROWS & strSQL
200       rs.Open strSQL, Cnxn  ', adOpenStatic, adLockReadOnly, adCmdText 'adLockOptimistic  'adLockReadOnly
          '
210       If rs.State <> adStateOpen Then

220          sMsg = "**** ERROR Could Not Open/Find File! ****" & vbCrLf & vbCrLf & _
                       "in Module 'modUtils' - Function 'Fetch_TD_Data'" & vbCrLf & "Line # " & 190 & vbCrLf & _
                       vbCrLf & " SQL: '" & strSQL & "'"
230          vLogMsg = sMsg
240          MsgLog

250          GoTo Fetch_TD_Data_Exit
260       End If


Determine if a recordset contains data


If Not rs.EOF And Not rs.BOF Then    'Check for End or Beginning of File
'310           Debug.Print rs!locationid    'Print the contents of the field...
'           End If
'280       If rs.RecordCount > 0 Then
360          vtemp = rs.GetRows()
370          If IsArray(vtemp) Then
380             Fetch_TD_Data = TransposeArray(vtemp)    'vtemp '
390          End If
400       Else
410          sMsg = "**** ERROR NO DATA FOUND ****" & vbCrLf & vbCrLf & _
                       "in Module 'modUtils' - Function 'Fetch_TD_Data'" & vbCrLf & "Line # " & 140 & vbCrLf & _
                       vbCrLf & " SQL: '" & strSQL & "'"
420          vLogMsg = sMsg
430          MsgLog
440       End If 


Cleanup recordset object variable

 ' clean up
450       If Not rs Is Nothing Then
460          If rs.State = adStateOpen Then rs.Close
470       End If
480       Set rs = Nothing


Cleanup connection object variable

 490       If Not Cnxn Is Nothing Then
500           If Cnxn.State = adStateOpen Then Cnxn.Close
510       End If
520       Set Cnxn = Nothing

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