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
No comments:
Post a Comment