Option Base 1
Public Function f_to_continue()
Dim li_choice As Integer
If f_if_sheet_exists(gs_report_name) Then
li_choice = MsgBox(prompt:="The sheet " & gs_report_name & " already exists, " & _
"it will be deleted and re-constructed, it's advisable " & _
"to backup it first!" & Chr(13) & _
Chr(13) & _
" Are you sure to continue?" _
, Buttons:=vbOKCancel + vbCritical + vbDefaultButton2 _
, Title:="Attention!")
If li_choice = vbCancel Then
f_to_continue = False
Else
f_to_continue = True
End If
Else
f_to_continue = True
End If
End Function
Public Function f_all_files_exist()
Dim li_i As Integer
Dim ls_current_path As String
Dim ls_csv_file As String
Dim ls_tmp_file As String
ls_current_path = ThisWorkbook.Path
For li_i = 0 To gdict_csv.Count - 1
ls_csv_file = ls_current_path & "\" & gdict_csv.Items(li_i) & ".csv"
ls_tmp_file = Dir(ls_csv_file)
If ls_tmp_file = "" Then
f_all_files_exist = False
MsgBox ("File " & ls_csv_file & " doesn't exist, please make sure it be there first.")
Exit Function
End If
Next
f_all_files_exist = True
End Function
Public Function f_import_all_files()
Dim li_i As Integer
Dim ls_current_path As String
Dim ls_csv_file As String
Dim ls_tmp_file As String
On Error GoTo 0
If Not f_if_sheet_exists("to_be_delete") Then ThisWorkbook.Worksheets.Add.Name = "to_be_delete"
Dim lo_each_sheet As Worksheet
For Each lo_each_sheet In ThisWorkbook.Worksheets
If lo_each_sheet.Name = gs_report_name Then
lo_each_sheet.Delete
ElseIf Not gdict_report_name.Exists(lo_each_sheet.Name) And lo_each_sheet.Name <> "to_be_delete" Then
lo_each_sheet.Delete
End If
Next
ThisWorkbook.Worksheets.Add.Name = gs_report_name
ThisWorkbook.Worksheets("to_be_delete").Delete
ls_current_path = ThisWorkbook.Path
For li_i = 0 To gdict_csv.Count - 1
ls_csv_file = ls_current_path & "\" & gdict_csv.Items(li_i) & ".csv"
Call sub_import_each_csv(ls_csv_file, gdict_csv_col_type(gdict_csv.Keys(li_i)), gdict_csv_charset(gdict_csv.Keys(li_i)))
Next
ThisWorkbook.Worksheets(gs_report_name).Activate
f_import_all_files = True
End Function
Public Function f_check_if_no_records()
If IsEmpty(garr_need_chk_no_data) Then
f_check_if_no_records = True
Exit Function
End If
Dim li_each As Integer
Dim li_max As Integer
Dim larr_data
li_max = UBound(garr_need_chk_no_data)
For li_each = 1 To li_max
larr_data = Worksheets(gdict_csv(garr_need_chk_no_data(li_each))).UsedRange
If IsEmpty(larr_data) Then GoTo error_no_data
If UBound(larr_data) = 1 Then GoTo error_no_data
Next
f_check_if_no_records = True
Exit Function
error_no_data:
MsgBox prompt:="CSV file " & gdict_csv(garr_need_chk_no_data(li_each)) & ".csv has no data. " & Chr(13) & _
"Please correctly prepare it before running this macro." _
, Buttons:=vbCritical + vbOKOnly _
, Title:="No data found!"
f_check_if_no_records = False
Exit Function
End Function
Public Sub sub_import_each_csv(ByVal as_csv_file_name As String _
, ByVal a_col_data_type As Variant _
, ByVal a_csv_charset)
On Error GoTo 0
Dim lo_new_sheet As Worksheet
Dim ls_file_base_name As String
'open csv file
Dim fso As FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FileExists(as_csv_file_name) Then
Set fso = Nothing
MsgBox ("File " & as_csv_file_name & " not exists!")
Exit Sub
End If
ls_file_base_name = fso.GetBaseName(as_csv_file_name)
Set fso = Nothing
Set lo_new_sheet = ThisWorkbook.Worksheets.Add(after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
lo_new_sheet.Name = ls_file_base_name
'ThisWorkbook.Worksheets.Add.Name = ls_file_base_name
lo_new_sheet.Cells.NumberFormat = "@"
'On Error Resume Next
If IsEmpty(a_col_data_type) Then a_col_data_type = Array(1)
With lo_new_sheet.QueryTables.Add(Connection:="TEXT;" & as_csv_file_name, Destination:=lo_new_sheet.Range("$A$1"))
.Name = ls_file_base_name
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
'.TextFilePlatform = 437
'.TextFilePlatform = 65001
.TextFilePlatform = a_csv_charset
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = a_col_data_type
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
'lo_new_sheet.Visible = xlSheetHidden
'lo_new_sheet.Visible = xlSheetVeryHidden
End Sub
Public Sub sub_compose_header(ByVal ai_repeat_times As Integer)
Dim ll_col_no_from As Long
Dim ll_col_no_to As Long
Dim li_repeat_cnt As Integer
'set the header, base part
ll_col_no_from = 1
ll_col_no_to = UBound(garr_header_base)
ThisWorkbook.Worksheets(gs_report_name).Cells(1, ll_col_no_from).Resize(1, ll_col_no_to) = garr_header_base
'set the header, repeat part
li_repeat_cnt = 1
ll_col_no_from = ll_col_no_to + 1
Do While li_repeat_cnt <= ai_repeat_times
ThisWorkbook.Worksheets(gs_report_name).Cells(1, ll_col_no_from).Resize(1, UBound(garr_header_repeat)) = garr_header_repeat
ll_col_no_from = ll_col_no_from + UBound(garr_header_repeat)
li_repeat_cnt = li_repeat_cnt + 1
Loop
End Sub
Public Sub sub_compose_format()
On Error GoTo 0
Dim ll_each_row As Long
Dim ll_start_row As Long
Dim ll_end_row As Long
Dim ll_col_count As Long
Dim ls_appendix As String
Dim ls_range
Dim li_i As Integer
Sheets(gs_report_name).Activate
ll_start_row = Sheets(gs_report_name).UsedRange.Row
ll_end_row = ll_start_row + Sheets(gs_report_name).UsedRange.Rows.Count - 1
ll_col_count = Sheets(gs_report_name).Range("A1").CurrentRegion.Columns.Count
Sheets(gs_report_name).Range(Cells(1, 1), Cells(1, ll_col_count)).Font.Bold = False
Sheets(gs_report_name).Cells.EntireColumn.AutoFit
'set the report line style
Dim lo_rng As Range
Set lo_rng = Sheets(gs_report_name).Range(Cells(1, 1), Cells(ll_end_row, ll_col_count))
lo_rng.Borders(xlEdgeLeft).LineStyle = xlContinuous
lo_rng.Borders(xlEdgeTop).LineStyle = xlContinuous
lo_rng.Borders(xlEdgeBottom).LineStyle = xlContinuous
lo_rng.Borders(xlEdgeRight).LineStyle = xlContinuous
lo_rng.Borders(xlInsideVertical).LineStyle = xlContinuous
lo_rng.Borders(xlInsideHorizontal).LineStyle = xlContinuous
'Set column rec no.
For li_i = 1 To UBound(g_static_col_color)
If li_i = 1 Then
ls_range = g_static_col_color(li_i) & ll_start_row & ":" & g_static_col_color(li_i) & ll_end_row
Else
ls_range = ls_range & "," & g_static_col_color(li_i) & ll_start_row & ":" & g_static_col_color(li_i) & ll_end_row
End If
Next
If UBound(g_static_col_color) > 0 Then
Set lo_rng = Sheets(gs_report_name).Range(ls_range)
lo_rng.Interior.ThemeColor = xlThemeColorAccent2
lo_rng.Interior.TintAndShade = 0.799981688894314
End If
'FDM color
For li_i = 1 To UBound(g_fdm_color_col)
If li_i = 1 Then
ls_range = g_fdm_color_col(li_i) & ll_start_row & ":" & g_fdm_color_col(li_i) & ll_end_row
Else
ls_range = ls_range & "," & g_fdm_color_col(li_i) & ll_start_row & ":" & g_fdm_color_col(li_i) & ll_end_row
End If
Next
If UBound(g_fdm_color_col) > 0 Then
Set lo_rng = Sheets(gs_report_name).Range(ls_range)
lo_rng.Interior.Color = 5296274
End If
'TICS color
For li_i = 1 To UBound(g_tics_color_col)
If li_i = 1 Then
ls_range = g_tics_color_col(li_i) & ll_start_row & ":" & g_tics_color_col(li_i) & ll_end_row
Else
ls_range = ls_range & "," & g_tics_color_col(li_i) & ll_start_row & ":" & g_tics_color_col(li_i) & ll_end_row
End If
Next
If UBound(g_tics_color_col) > 0 Then
Set lo_rng = Sheets(gs_report_name).Range(ls_range)
lo_rng.Interior.ThemeColor = xlThemeColorLight2
lo_rng.Interior.TintAndShade = 0.799981688894314
End If
'TMS base color
For li_i = 1 To UBound(g_tms_base_color_col)
If li_i = 1 Then
ls_range = g_tms_base_color_col(li_i) & ll_start_row & ":" & g_tms_base_color_col(li_i) & ll_end_row
Else
ls_range = ls_range & "," & g_tms_base_color_col(li_i) & ll_start_row & ":" & g_tms_base_color_col(li_i) & ll_end_row
End If
Next
If UBound(g_tms_base_color_col) > 0 Then
Set lo_rng = Sheets(gs_report_name).Range(ls_range)
lo_rng.Interior.Color = 49407
End If
'cis color
For li_i = 1 To UBound(g_cis_color_col)
If li_i = 1 Then
ls_range = g_cis_color_col(li_i) & ll_start_row & ":" & g_cis_color_col(li_i) & ll_end_row
Else
ls_range = ls_range & "," & g_cis_color_col(li_i) & ll_start_row & ":" & g_cis_color_col(li_i) & ll_end_row
End If
Next
If UBound(g_cis_color_col) > 0 Then
Set lo_rng = Sheets(gs_report_name).Range(ls_range)
lo_rng.Interior.ThemeColor = xlThemeColorAccent1
lo_rng.Interior.TintAndShade = 0.399975585192419
End If
'========== dynamic set the format for repeated columns =========================
'Dim dict_col_indx As New Dictionary
'Call sub_init_col_indx_alpha(dict_col_indx)
Dim li_each_time As Integer
Dim li_col_no As Integer
For li_each_time = 1 To gi_header_repeat_cnt
'cis color
For li_i = 1 To UBound(g_rpt_cis_color_col)
li_col_no = dict_col_indx(g_rpt_cis_color_col(li_i)) + gi_rpt_col_num * (li_each_time - 1)
If li_i = 1 Then
ls_range = Sheets(gs_report_name).Range(Sheets(gs_report_name).Cells(ll_start_row, li_col_no), Sheets(gs_report_name).Cells(ll_end_row, li_col_no)).Address
Else
ls_range = ls_range & "," & Sheets(gs_report_name).Range(Sheets(gs_report_name).Cells(ll_start_row, li_col_no), Sheets(gs_report_name).Cells(ll_end_row, li_col_no)).Address
End If
Next
If UBound(g_rpt_cis_color_col) > 0 Then
Set lo_rng = Sheets(gs_report_name).Range(ls_range)
lo_rng.Interior.ThemeColor = xlThemeColorAccent1
lo_rng.Interior.TintAndShade = 0.399975585192419
End If
'ifop color
For li_i = 1 To UBound(g_rpt_ifop_color_col)
li_col_no = dict_col_indx(g_rpt_ifop_color_col(li_i)) + gi_rpt_col_num * (li_each_time - 1)
If li_i = 1 Then
ls_range = Sheets(gs_report_name).Range(Cells(ll_start_row, li_col_no), Cells(ll_end_row, li_col_no)).Address
Else
ls_range = ls_range & "," & Sheets(gs_report_name).Range(Cells(ll_start_row, li_col_no), Cells(ll_end_row, li_col_no)).Address
End If
Next
If UBound(g_rpt_ifop_color_col) > 0 Then
Set lo_rng = Sheets(gs_report_name).Range(ls_range)
lo_rng.Interior.Color = 15773696
End If
'tms color
For li_i = 1 To UBound(g_rpt_tms_color_col)
li_col_no = dict_col_indx(g_rpt_tms_color_col(li_i)) + gi_rpt_col_num * (li_each_time - 1)
If li_i = 1 Then
ls_range = Sheets(gs_report_name).Range(Cells(ll_start_row, li_col_no), Cells(ll_end_row, li_col_no)).Address
Else
ls_range = ls_range & "," & Sheets(gs_report_name).Range(Cells(ll_start_row, li_col_no), Cells(ll_end_row, li_col_no)).Address
End If
Next
If UBound(g_rpt_tms_color_col) > 0 Then
Set lo_rng = Sheets(gs_report_name).Range(ls_range)
lo_rng.Interior.Color = 49407
End If
Next
'--------------------------------------------------------------
'date format
' For li_i = 1 To UBound(g_date_col)
' If li_i = 1 Then
' ls_range = g_date_col(li_i) & ll_start_row & ":" & g_date_col(li_i) & ll_end_row
' Else
' ls_range = ls_range & "," & g_date_col(li_i) & ll_start_row & ":" & g_date_col(li_i) & ll_end_row
' End If
' Next
'
' If UBound(g_date_col) > 0 Then
' Set lo_rng = Sheets(gs_report_name).Range(ls_range)
' lo_rng.NumberFormat = "dd\/mm\/yyyy"
' End If
'decimal format
For li_i = 1 To UBound(g_dec_col)
If li_i = 1 Then
ls_range = g_dec_col(li_i) & ll_start_row & ":" & g_dec_col(li_i) & ll_end_row
Else
ls_range = ls_range & "," & g_dec_col(li_i) & ll_start_row & ":" & g_dec_col(li_i) & ll_end_row
End If
Next
If UBound(g_dec_col) > 0 Then
Set lo_rng = Sheets(gs_report_name).Range(ls_range)
lo_rng.NumberFormat = "#,##0.00;[Red]-#,##0.00"
End If
'rate format
For li_i = 1 To UBound(g_rate_col)
If li_i = 1 Then
ls_range = g_rate_col(li_i) & ll_start_row & ":" & g_rate_col(li_i) & ll_end_row
Else
ls_range = ls_range & "," & g_rate_col(li_i) & ll_start_row & ":" & g_rate_col(li_i) & ll_end_row
End If
Next
If UBound(g_rate_col) > 0 Then
Set lo_rng = Sheets(gs_report_name).Range(ls_range)
lo_rng.NumberFormat = "#,##0.0000;[Red]-#,##0.0000"
End If
'--------------------------------------------------------------
' set the date for repeated columns
' For li_each_time = 1 To gi_header_repeat_cnt
' 'cis
' For li_i = 1 To UBound(g_rpt_date_col)
' li_col_no = dict_col_indx(g_rpt_date_col(li_i)) + gi_rpt_col_num * (li_each_time - 1)
'
' If li_i = 1 Then
' ls_range = Sheets(gs_report_name).Range(Sheets(gs_report_name).Cells(ll_start_row, li_col_no), Sheets(gs_report_name).Cells(ll_end_row, li_col_no)).Address
' Else
' ls_range = ls_range & "," & Sheets(gs_report_name).Range(Sheets(gs_report_name).Cells(ll_start_row, li_col_no), Sheets(gs_report_name).Cells(ll_end_row, li_col_no)).Address
' End If
' Next
'
' If UBound(g_rpt_date_col) > 0 Then
' Set lo_rng = Sheets(gs_report_name).Range(ls_range)
' 'lo_rng.NumberFormat = "dd\/mm\/yyyy"
' lo_rng.NumberFormat = "@"
' End If
' Next
'---------------------------------------------------------
'if the column is too long, shorten it, to make read easy
For li_col_no = dict_col_indx(gs_rpt_col_after) To ll_col_count
If Columns(li_col_no).ColumnWidth > 30 Then Columns(li_col_no).ColumnWidth = 30
Next
'set legend
ls_appendix = "B" & CStr(ll_end_row + 2): ll_end_row = ll_end_row + 3
Range(ls_appendix) = "LEGEND:"
Range(ls_appendix).Font.Name = "Times New Roman"
Range(ls_appendix).Font.Size = 12
Range(ls_appendix).Font.Bold = True
ls_appendix = "B" & CStr(ll_end_row): ll_end_row = ll_end_row + 1
Range(ls_appendix) = "FDM"
Range(ls_appendix).Interior.Color = 5296274
If gdict_csv.Exists("merival") Then
Range(ls_appendix) = Range(ls_appendix) & " / Merival"
End If
If gdict_csv.Exists("clt_rpt") Then
Range(ls_appendix) = Range(ls_appendix) & " / ClientReporting"
End If
If gdict_csv.Exists("tics") Then
ls_appendix = "B" & CStr(ll_end_row): ll_end_row = ll_end_row + 1
Range(ls_appendix) = "TICS"
Range(ls_appendix).Interior.ThemeColor = xlThemeColorLight2
Range(ls_appendix).Interior.TintAndShade = 0.799981688894314
End If
ls_appendix = "B" & CStr(ll_end_row): ll_end_row = ll_end_row + 1
Range(ls_appendix) = "CIS"
Range(ls_appendix).Interior.ThemeColor = xlThemeColorAccent1
Range(ls_appendix).Interior.TintAndShade = 0.399975585192419
ls_appendix = "B" & CStr(ll_end_row): ll_end_row = ll_end_row + 1
Range(ls_appendix) = "TMS"
Range(ls_appendix).Interior.Color = 49407
If gdict_csv.Exists("ifop") Then
ls_appendix = "B" & CStr(ll_end_row): ll_end_row = ll_end_row + 1
Range(ls_appendix).FormulaR1C1 = "Ifop"
Range(ls_appendix).Interior.Color = 15773696
End If
' Dim ll_last_row As Long
' ll_last_row = f_get_valid_data_max_row(ActiveSheet)
'
' Range("D" & (ll_last_row - 2) & ":L" & ll_last_row).Merge
' Range("D" & (ll_last_row - 2)) = "The date column is in TEXT format, please do not fomat them to DATE."
' Range("D" & (ll_last_row - 2)).Font.ColorIndex = 3
' Range("D" & (ll_last_row - 2)).Font.Size = 14
' Range("D" & (ll_last_row - 2)).VerticalAlignment = xlTop
' Range("D" & (ll_last_row - 2)).WrapText = True
'set zoom
Range("A1").Select
ActiveWindow.Zoom = 85
ActiveWindow.DisplayGridlines = False
ActiveWindow.SplitColumn = 3
ActiveWindow.SplitRow = 1
ActiveWindow.FreezePanes = True
End Sub
Public Sub sub_format_sheets()
On Error Resume Next
Sheets(gdict_report_name.Keys(0)).Move before:=ThisWorkbook.Sheets(1)
Sheets(gdict_report_name.Keys(1)).Move before:=ThisWorkbook.Sheets(2)
Sheets(gdict_report_name.Keys(2)).Move after:=ThisWorkbook.Sheets(3)
'Sheets(gdict_report_name.Keys(2)).Move after:=ThisWorkbook.Sheets(Worksheets.Count)
' If f_if_sheet_exists(gdict_report_name.Keys(0)) And Worksheets.Count > 1 Then
' If Sheets(1).Name <> gdict_report_name.Keys(0) Then
' Sheets(gdict_report_name.Keys(0)).Move before:=ThisWorkbook.Sheets(1)
' End If
' End If
'
' If f_if_sheet_exists(gdict_report_name.Keys(1)) And Worksheets.Count > 1 Then
' If Sheets(2).Name <> gdict_report_name.Keys(1) Then
' Sheets(gdict_report_name.Keys(1)).Move before:=ThisWorkbook.Sheets(2)
' End If
' End If
'
' If f_if_sheet_exists(gdict_report_name.Keys(2)) And Worksheets.Count > 1 Then
' If Sheets(2).Name <> gdict_report_name.Keys(1) Then
' Sheets(gdict_report_name.Keys(1)).Move before:=ThisWorkbook.Sheets(2)
' End If
' End If
ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
If f_if_sheet_exists(gdict_report_name.Keys(0)) Then Sheets(gdict_report_name.Keys(0)).Tab.Color = 5296274
If f_if_sheet_exists(gdict_report_name.Keys(1)) Then Sheets(gdict_report_name.Keys(1)).Tab.Color = 10498160
If f_if_sheet_exists(gdict_report_name.Keys(2)) Then Sheets(gdict_report_name.Keys(2)).Tab.Color = 49407
Sheets(gs_report_name).Activate
On Error GoTo 0
End Sub
Public Function f_pre_check(ByVal as_report_type As String)
If Not f_if_sheet_exists(gs_report_name) Then
MsgBox prompt:="There's no report of " & gs_report_name & "," & Chr(13) & _
"Please generate it first!" _
, Buttons:=vbCritical + vbOK + vbDefaultButton1 _
, Title:="Please extract the report first!"
f_pre_check = False
Exit Function
End If
If ThisWorkbook.Worksheets(gs_report_name).Range("A1").CurrentRegion.Rows.Count <= 1 Then
MsgBox prompt:="No data was found in report " & as_report_type & _
", please extract the report " & as_report_type & " first!", _
Buttons:=vbInformation + vbOKCancel + vbDefaultButton1, _
Title:="No data!"
f_pre_check = False
Exit Function
End If
f_pre_check = True
End Function
Public Function f_get_file_save_path(ByVal as_report_type As String, _
ByRef as_output_file As String)
Dim fso As New FileSystemObject
Dim ls_output_file As String
'Dim ls_drive As String
Dim ls_curr_path As String
ls_curr_path = gs_saved_path
If ls_curr_path = "" Then ls_curr_path = Trim(ThisWorkbook.Path)
'ls_drive = fso.GetDriveName(ls_curr_path)
'ChDrive ls_drive
'ChDir ls_curr_path
ls_output_file = ls_curr_path & "\" & "HKMA_DPS_RPT_" & as_report_type & ".txt"
' as_output_file = ls_output_file 'richard test
' f_get_file_save_path = True 'richard test
' Exit Function 'richard test
ls_output_file = Application.GetSaveAsFilename(ls_output_file, _
"Text files (*.txt), *.txt", 1, "Save as text file")
If Trim(ls_output_file) = "False" Then
Set fso = Nothing
MsgBox prompt:="Process was aborted.", Buttons:=vbExclamation, Title:="Aborted!"
f_get_file_save_path = False
Exit Function
End If
If Trim(ls_output_file) = "" Then
Set fso = Nothing
f_get_file_save_path = False
Exit Function
End If
Dim li_choice As Integer
If fso.FileExists(ls_output_file) Then
Do While True
li_choice = MsgBox(prompt:="File already exists! " & Chr(13) & _
"Press " & Chr(13) & _
" Yes to overwrite it, " & Chr(13) & _
" No to choose another name, " & Chr(13) & _
" Cancel to abort." _
, Buttons:=vbCritical + vbYesNoCancel + vbDefaultButton1 _
, Title:="File already exists!" _
)
If li_choice = vbNo Then
ls_output_file = Application.GetSaveAsFilename(ls_output_file, _
"Text files (*.txt), *.txt", 1, "Save as text file")
If Trim(ls_output_file) = "" Or Trim(ls_output_file) = "False" Then
Set fso = Nothing
MsgBox prompt:="Process was aborted.", Buttons:=vbExclamation, Title:="Aborted!"
f_get_file_save_path = False
Exit Function
End If
End If
If li_choice = vbCancel Then
Set fso = Nothing
MsgBox prompt:="Process was aborted.", Buttons:=vbExclamation, Title:="Aborted!"
f_get_file_save_path = False
Exit Function
End If
If li_choice = vbYes Then
Exit Do
End If
Loop
End If
gs_saved_path = fso.GetParentFolderName(ls_output_file)
Set fso = Nothing
as_output_file = ls_output_file
f_get_file_save_path = True
End Function
Public Function f_compare_ah_names(ByVal as_main_ptfl _
, ByVal dct_no_of_memb _
, ByVal dct_cis_row_from _
, ByVal dct_cis_row_to _
, ByVal arr_cis _
, ByVal dct_tms_gurt _
) As String
On Error GoTo 0
Dim larr_gurtors
Dim li_each_gur As Integer
Dim li_max_gurtors As Integer
Dim ll_cis_row_no As Long
Dim ll_cis_row_from As Long
Dim ll_cis_row_to As Long
Dim ll_cis_row_no_gur As Long
Dim ll_cis_row_fr_gur As Long
Dim ll_cis_row_to_gur As Long
If dct_tms_gurt.Exists(as_main_ptfl) Then ' TMS_3 has gurantor of this ptfl
larr_gurtors = Split(dct_tms_gurt(as_main_ptfl), "|")
li_max_gurtors = UBound(larr_gurtors)
'when cis has no such record
If IsEmpty(dct_no_of_memb(as_main_ptfl)) Then
f_compare_ah_names = gs_EXCEPTION
Exit Function
End If
'if the no_of_memebers of this ptfl is diff from any one of the gurantors, then G.
For li_each_gur = 1 To li_max_gurtors
'when cis has no such record
If IsEmpty(dct_no_of_memb(CDbl(larr_gurtors(li_each_gur)))) Then
f_compare_ah_names = gs_EXCEPTION
Exit Function
End If
If dct_no_of_memb(as_main_ptfl) <> dct_no_of_memb(CDbl(larr_gurtors(li_each_gur))) Then
f_compare_ah_names = "G"
Exit Function
End If
Next
'check if all of AH names of this ptfl are same as all AH names of all gurantor
ll_cis_row_from = dct_cis_row_from(as_main_ptfl)
ll_cis_row_to = dct_cis_row_to(as_main_ptfl)
For ll_cis_row_no = ll_cis_row_from To ll_cis_row_to ' all AH of the main ptfl
For li_each_gur = 1 To li_max_gurtors
ll_cis_row_fr_gur = dct_cis_row_from(CDbl(larr_gurtors(li_each_gur)))
ll_cis_row_to_gur = dct_cis_row_to(CDbl(larr_gurtors(li_each_gur)))
For ll_cis_row_no_gur = ll_cis_row_fr_gur To ll_cis_row_to_gur ' all AH of the this gurantor
If arr_cis(ll_cis_row_no, dict_col_indx("I")) <> arr_cis(ll_cis_row_no_gur, dict_col_indx("I")) Then
f_compare_ah_names = "G"
Exit Function
End If
Next
Next
Next
End If
f_compare_ah_names = "N"
End Function
Public Function f_get_data_of_csv_file(ByVal as_csv_file_tag As String _
, ByRef arr_csv) As Integer
Dim ls_csv_sheet As String
Dim ll_start_row As Long
Dim ll_end_row As Long
ls_csv_sheet = gdict_csv(as_csv_file_tag)
ll_start_row = Sheets(ls_csv_sheet).UsedRange.Row ' ll_start_row = 1
ll_end_row = ll_start_row + Sheets(ls_csv_sheet).UsedRange.Rows.Count - 1
If ll_start_row = ll_end_row Then
f_get_data_of_csv_file = 100
'arr_csv = Array()
Exit Function
End If
ll_start_row = ll_start_row + 1 ' ll_start_row = 2
arr_csv = Sheets(ls_csv_sheet).Range(Sheets(ls_csv_sheet).Cells(ll_start_row, 1), Sheets(ls_csv_sheet).Cells(ll_end_row, Sheets(ls_csv_sheet).UsedRange.Columns.Count))
f_get_data_of_csv_file = 0
End Function
Public Sub sub_add_address_column(ByVal adoStream As ADODB.Stream _
, ByVal ldct_cis_row_from As Dictionary _
, ByVal larr_cis)
Dim ll_max_col_no As Long
Dim ll_end_row As Long
Dim ll_each_row As Long
On Error GoTo 0
ll_max_col_no = Sheets(gs_report_name).UsedRange.Columns.Count
ll_end_row = Sheets(gs_report_name).UsedRange.Rows.Count
' add 6 address 1, 2, 3, 4, 5, 6
ll_max_col_no = ll_max_col_no + 12
Dim li_add_col1 As Integer, li_add_col2 As Integer, li_add_col3 As Integer, li_add_col4 As Integer, li_add_col5 As Integer, li_add_col6 As Integer
Dim li_add_col7 As Integer, li_add_col8 As Integer, li_add_col9 As Integer, li_add_col10 As Integer, li_add_col11 As Integer, li_add_col12 As Integer
li_add_col1 = ll_max_col_no - 11
li_add_col2 = ll_max_col_no - 10
li_add_col3 = ll_max_col_no - 9
li_add_col4 = ll_max_col_no - 8
li_add_col5 = ll_max_col_no - 7
li_add_col6 = ll_max_col_no - 6
li_add_col7 = ll_max_col_no - 5
li_add_col8 = ll_max_col_no - 4
li_add_col9 = ll_max_col_no - 3
li_add_col10 = ll_max_col_no - 2
li_add_col11 = ll_max_col_no - 1
li_add_col12 = ll_max_col_no
Sheets(gs_report_name).Cells(1, li_add_col1) = "POSTAL_ADDR_LINE_1"
Sheets(gs_report_name).Cells(1, li_add_col2) = "POSTAL_ADDR_LINE_2"
Sheets(gs_report_name).Cells(1, li_add_col3) = "POSTAL_ADDR_LINE_3"
Sheets(gs_report_name).Cells(1, li_add_col4) = "POSTAL_ADDR_LINE_4"
Sheets(gs_report_name).Cells(1, li_add_col5) = "POSTAL_ADDR_LINE_5"
Sheets(gs_report_name).Cells(1, li_add_col6) = "POSTAL_ADDR_LINE_6"
Sheets(gs_report_name).Cells(1, li_add_col7) = "ADDR1_Length" & Chr(13) & Chr(10) & "(Bytes)"
Sheets(gs_report_name).Cells(1, li_add_col8) = "ADDR2_Length" & Chr(13) & Chr(10) & "(Bytes)"
Sheets(gs_report_name).Cells(1, li_add_col9) = "ADDR3_Length" & Chr(13) & Chr(10) & "(Bytes)"
Sheets(gs_report_name).Cells(1, li_add_col10) = "ADDR4_Length" & Chr(13) & Chr(10) & "(Bytes)"
Sheets(gs_report_name).Cells(1, li_add_col11) = "ADDR5_Length" & Chr(13) & Chr(10) & "(Bytes)"
Sheets(gs_report_name).Cells(1, li_add_col12) = "ADDR6_Length" & Chr(13) & Chr(10) & "(Bytes)"
Dim larr_acc_num
larr_acc_num = Sheets(gs_report_name).Range("C2:C" & ll_end_row)
Dim larr_address
larr_address = Sheets(gs_report_name).Range(Sheets(gs_report_name).Cells(2, li_add_col1) _
, Sheets(gs_report_name).Cells(ll_end_row, li_add_col12))
Dim ll_cis_row_from As Long
Dim ll_cis_col_start As Long
Dim ll_cis_col_no As Long
Dim ls_addr_line1 As String
Dim ls_retain_mail As String
Dim li_addr_col As Integer
For ll_each_row = 1 To UBound(larr_address, 1)
ll_cis_row_from = ldct_cis_row_from(larr_acc_num(ll_each_row, 1))
If ll_cis_row_from > 0 Then
ls_addr_line1 = larr_cis(ll_cis_row_from, dict_col_indx("AC"))
ls_retain_mail = larr_cis(ll_cis_row_from, dict_col_indx("AD"))
If ls_retain_mail = "02" Then 'retained mail
ll_cis_col_start = dict_col_indx("Z") 'start from address line 4
Else
ll_cis_col_start = dict_col_indx("W")
'check the real address line stores in which field, then the address lines before that should be partner name
'so discard those field before
If Len(Trim(ls_addr_line1)) > 0 Then
For ll_cis_col_no = dict_col_indx("W") To dict_col_indx("AB")
If UCase(larr_cis(ll_cis_row_from, ll_cis_col_no)) = UCase(ls_addr_line1) Then
ll_cis_col_start = ll_cis_col_no
Exit For
End If
Next
End If
End If
li_addr_col = 1
'li_addr_col = ll_cis_col_start - dict_col_indx("W") + 1
For ll_cis_col_no = ll_cis_col_start To dict_col_indx("AB")
larr_address(ll_each_row, li_addr_col) = larr_cis(ll_cis_row_from, ll_cis_col_no)
li_addr_col = li_addr_col + 1
Next
larr_address(ll_each_row, 7) = f_LenByBytes(adoStream, larr_address(ll_each_row, 1))
larr_address(ll_each_row, 8) = f_LenByBytes(adoStream, larr_address(ll_each_row, 2))
larr_address(ll_each_row, 9) = f_LenByBytes(adoStream, larr_address(ll_each_row, 3))
larr_address(ll_each_row, 10) = f_LenByBytes(adoStream, larr_address(ll_each_row, 4))
larr_address(ll_each_row, 11) = f_LenByBytes(adoStream, larr_address(ll_each_row, 5))
larr_address(ll_each_row, 12) = f_LenByBytes(adoStream, larr_address(ll_each_row, 6))
Else
larr_address(ll_each_row, 7) = 0
larr_address(ll_each_row, 8) = 0
larr_address(ll_each_row, 9) = 0
larr_address(ll_each_row, 10) = 0
larr_address(ll_each_row, 11) = 0
larr_address(ll_each_row, 12) = 0
End If
Next
Sheets(gs_report_name).Range(Sheets(gs_report_name).Cells(2, li_add_col1) _
, Sheets(gs_report_name).Cells(UBound(larr_address, 1) + 1, ll_max_col_no) _
).NumberFormat = "@"
Sheets(gs_report_name).Cells(2, li_add_col1).Resize(UBound(larr_address, 1), 12) = larr_address
End Sub
Public Sub sub_add_names_column(ByVal adoStream As ADODB.Stream _
, ByVal ldct_cis_row_from As Dictionary _
, ByVal larr_cis)
Dim ll_max_col_no As Long
Dim ll_end_row As Long
On Error GoTo 0
ll_max_col_no = Sheets(gs_report_name).UsedRange.Columns.Count
ll_end_row = Sheets(gs_report_name).UsedRange.Rows.Count
Sheets(gs_report_name).Cells(1, ll_max_col_no) = "AH_NAME"
Sheets(gs_report_name).Cells(1, ll_max_col_no + 1) = "ADDITIONAL_NAME1"
Sheets(gs_report_name).Cells(1, ll_max_col_no + 2) = "ADDITIONAL_NAME2"
Dim larr_acc_num
larr_acc_num = Sheets(gs_report_name).Range("C2:C" & ll_end_row)
Dim larr_names
larr_names = Sheets(gs_report_name).Range(Sheets(gs_report_name).Cells(2, ll_max_col_no) _
, Sheets(gs_report_name).Cells(ll_end_row, ll_max_col_no + 2))
For ll_each_row = 1 To UBound(larr_names, 1)
larr_names(ll_each_row, 1) = larr_cis(ldct_cis_row_from(larr_acc_num(ll_each_row, 1)), dict_col_indx("AC"))
larr_names(ll_each_row, 2) = larr_cis(ldct_cis_row_from(larr_acc_num(ll_each_row, 1)), dict_col_indx("AD"))
larr_names(ll_each_row, 3) = larr_cis(ldct_cis_row_from(larr_acc_num(ll_each_row, 1)), dict_col_indx("AE"))
Next
Sheets(gs_report_name).Cells(2, ll_max_col_no).Resize(UBound(larr_names, 1), 3) = larr_names
End Sub
Public Sub sub_format_column_to_text(ByVal al_row_from As Long, ByVal al_row_to As Long)
Dim li_i As Integer
Dim ls_range As String
Dim lo_rng As Range
Dim li_each_time As Integer
Dim li_col_no As Integer
'format base column to text format, especially force format date to text
For li_i = 1 To UBound(gar_txt_fmt_col)
If li_i = 1 Then
ls_range = gar_txt_fmt_col(li_i) & al_row_from & ":" & gar_txt_fmt_col(li_i) & al_row_to
Else
ls_range = ls_range & "," & gar_txt_fmt_col(li_i) & al_row_from & ":" & gar_txt_fmt_col(li_i) & al_row_to
End If
Next
If UBound(gar_txt_fmt_col) > 0 Then
Set lo_rng = Sheets(gs_report_name).Range(ls_range)
lo_rng.NumberFormat = "@"
End If
' set the date for repeated columns
For li_each_time = 1 To gi_header_repeat_cnt
'cis
For li_i = 1 To UBound(gar_rptd_txt_fmt_col)
li_col_no = dict_col_indx(gar_rptd_txt_fmt_col(li_i)) + gi_rpt_col_num * (li_each_time - 1)
If li_i = 1 Then
ls_range = Sheets(gs_report_name).Range(Sheets(gs_report_name).Cells(al_row_from, li_col_no), Sheets(gs_report_name).Cells(al_row_to, li_col_no)).Address
Else
ls_range = ls_range & "," & Sheets(gs_report_name).Range(Sheets(gs_report_name).Cells(al_row_from, li_col_no), Sheets(gs_report_name).Cells(al_row_to, li_col_no)).Address
End If
Next
If UBound(gar_rptd_txt_fmt_col) > 0 Then
Set lo_rng = Sheets(gs_report_name).Range(ls_range)
lo_rng.NumberFormat = "@"
End If
Next
Set lo_rng = Nothing
End Sub
Public Sub sub_get_clt_id_br_rpt_a_c(ByVal as_csv_tag As String _
, ByRef ldct_cis_row_from _
, ByRef ldct_cis_row_to _
, ByRef larr_cis _
, ByRef ldct_c_clt_id_no _
, ByRef ldct_c_clt_cert _
)
Dim ll_rtn_code As Integer
'FDM part C
Dim larr_csv
ll_rtn_code = f_get_data_of_csv_file(as_csv_tag, larr_csv)
'get fdm c 's client
Dim ll_cis_row_no As Long
Dim ll_cis_row_from As Long
Dim ll_cis_row_to As Long
Dim ls_acc_num
Dim ls_id_num As String
Dim ls_cert As String
Dim larr_split
Dim li_each_item As Integer
Dim ll_each_row As Long
For ll_each_row = 1 To UBound(larr_csv, 1)
If as_csv_tag = "fdm_c" Then
If larr_csv(ll_each_row, dict_col_indx("H")) = gs_OVERDRAFT Then
GoTo next_for
End If
End If
If as_csv_tag = "clt_rpt" Then
ls_acc_num = larr_csv(ll_each_row, dict_col_indx("D"))
Else
ls_acc_num = larr_csv(ll_each_row, dict_col_indx("C"))
End If
ll_cis_row_from = ldct_cis_row_from(ls_acc_num)
ll_cis_row_to = ldct_cis_row_to(ls_acc_num)
If ll_cis_row_from > 0 Then
For ll_cis_row_no = ll_cis_row_from To ll_cis_row_to
'id number
larr_split = Split(larr_cis(ll_cis_row_no, dict_col_indx("L")), ";")
For li_each_item = 0 To UBound(larr_split)
ls_id_num = f_remv_non_alphanum(larr_split(li_each_item))
If Len(ls_id_num) > 0 Then
If Not ldct_c_clt_id_no.Exists(ls_id_num) Then
ldct_c_clt_id_no(ls_id_num) = 1
End If
End If
Next
'cert
larr_split = Split(larr_cis(ll_cis_row_no, dict_col_indx("N")), ";")
For li_each_item = 0 To UBound(larr_split)
ls_cert = f_remv_non_alphanum(larr_split(li_each_item))
If Len(ls_cert) > 0 Then
If Not ldct_c_clt_cert.Exists(ls_cert) Then
ldct_c_clt_cert(ls_cert) = 1
End If
End If
Next
Next
End If
next_for:
Next
End Sub
Public Sub sub_get_dbtor_depstor_ind(ByVal as_report As String _
, ByVal as_id_num As String _
, ByVal as_cert_num As String _
, ByRef ldct_c_clt_id_no _
, ByRef ldct_c_clt_cert _
, ByRef ls_flg As String _
, ByRef ls_id_num_matched _
)
ls_flg = "N"
ls_id_num_matched = ""
Dim ls_id_num As String
Dim ls_cert As String
Dim larr_split
Dim li_each_item As Integer
'id number
larr_split = Split(as_id_num, ";")
For li_each_item = 0 To UBound(larr_split)
ls_id_num = f_remv_non_alphanum(larr_split(li_each_item))
If Len(ls_id_num) > 0 Then
If ldct_c_clt_id_no.Exists(ls_id_num) Then
ls_flg = "Y"
ls_id_num_matched = ls_id_num
Exit For
End If
End If
Next
If as_report = "C" Then Exit Sub
'cert
If ls_flg = "N" Then
larr_split = Split(as_cert_num, ";")
For li_each_item = 0 To UBound(larr_split)
ls_cert = f_remv_non_alphanum(larr_split(li_each_item))
If Len(ls_cert) > 0 Then
If ldct_c_clt_cert.Exists(ls_cert) Then
ls_flg = "Y"
Exit For
End If
End If
Next
End If
End Sub
Option Explicit
Option Base 1
Public Sub sub_init_col_indx_alpha(ByRef ao_dict As Dictionary)
Dim ll_i As Integer
Dim ll_j As Integer
Dim ll_cnt As Integer
' ao_dict.Add "A", 1
' ao_dict.Add "B", 2
' ao_dict.Add "C", 3
' ...
'A to Z
For ll_i = 1 To 26
ao_dict(Chr(64 + ll_i)) = ll_i
Next
'AA to AZ, BA to BZ, ...
ll_cnt = 26
For ll_i = 1 To 10 ' A to J
For ll_j = 1 To 26
ll_cnt = ll_cnt + 1
ao_dict(Chr(64 + ll_i) & Chr(64 + ll_j)) = ll_cnt
Next
Next
End Sub
Public Function f_LeftByBytes(ByVal adoStream As ADODB.Stream _
, ByVal as_str_in As String _
, ByVal ai_pos As Integer) As String
Dim li_position As Integer
Dim ls_text
Dim ls_spaces As String
If ai_pos < 101 Then
ls_spaces = String(100, " ")
Else
ls_spaces = String(500, " ")
End If
li_position = 3 + ai_pos 'BOM occupy 3 bytes
'before write, clear all
adoStream.Type = adTypeText
adoStream.Position = 0
adoStream.SetEOS
adoStream.WriteText as_str_in + ls_spaces
adoStream.Position = li_position
adoStream.SetEOS
adoStream.Position = 0
ls_text = adoStream.ReadText()
're-read, to avoid the last 2-bytes charactor be disposed
adoStream.Position = 0
adoStream.SetEOS
adoStream.WriteText ls_text + ls_spaces
adoStream.Position = li_position
adoStream.SetEOS
adoStream.Position = 0
ls_text = adoStream.ReadText()
'clear all, for next use
adoStream.Position = 0
adoStream.SetEOS
'adoStream.Close
f_LeftByBytes = ls_text
End Function
Public Function f_LenByBytes(ByVal adoStream As ADODB.Stream _
, ByVal as_str_in As String) As String
Dim ls_bytes
adoStream.Position = 0
adoStream.SetEOS
adoStream.Type = adTypeText
adoStream.WriteText as_str_in
adoStream.Position = 0
adoStream.Type = adTypeBinary
ls_bytes = adoStream.Read
adoStream.Position = 0
adoStream.SetEOS
f_LenByBytes = UBound(ls_bytes) + 1 - 3
End Function
Public Sub sub_LenByBytes()
Dim adoStream As New ADODB.Stream
adoStream.Charset = "utf-8"
adoStream.Type = 2 'adTypeText
adoStream.Open
MsgBox f_LenByBytes(adoStream, ActiveCell.Text)
adoStream.Close
Set adoStream = Nothing
End Sub
Public Function f_date2string(ByVal ad_date) As String
If IsDate(ad_date) Then
f_date2string = Format(ad_date, "dd/mm/yyyy")
Else
f_date2string = Format(ad_date, "@")
End If
Exit Function
End Function
Public Function f_date_rm_slash(ByVal as_date) As String
If UCase(TypeName(as_date)) = "DATE" Then
f_date_rm_slash = Left(Format(as_date, "ddmmyyyy") & String(8, " "), 8)
Else
f_date_rm_slash = Left(Replace(as_date, "/", "") & String(8, " "), 8)
End If
Exit Function
End Function
Public Function f_get_valid_data_max_row(ByVal ao_activesheet As Worksheet) As Long
Dim ll_excel_max_row As Long
ll_excel_max_row = ao_activesheet.Cells.Rows.Count
Dim ll_used_max_col As Long
ll_used_max_col = ao_activesheet.UsedRange.Column + ao_activesheet.UsedRange.Columns.Count - 1
Dim ll_each_col As Long
Dim ll_max_row_saved As Long
Dim ll_max_row_each_col As Long
ll_max_row_saved = 0
For ll_each_col = 1 To ll_used_max_col
ll_max_row_each_col = ao_activesheet.Cells(ll_excel_max_row, ll_each_col).End(xlUp).Row
If ll_max_row_each_col > ll_max_row_saved Then ll_max_row_saved = ll_max_row_each_col
Next
f_get_valid_data_max_row = ll_max_row_saved
End Function
Public Function f_get_valid_data_max_col(ByVal ao_activesheet As Worksheet) As Long
Dim ll_excel_max_col As Long
ll_excel_max_col = ao_activesheet.Cells.Columns.Count
Dim ll_used_max_row As Long
ll_used_max_row = ao_activesheet.UsedRange.Row + ao_activesheet.UsedRange.Rows.Count - 1
Dim ll_each_row As Long
Dim ll_max_col_saved As Long
Dim ll_max_col_each_row As Long
ll_max_col_saved = 0
For ll_each_row = 1 To ll_used_max_row
ll_max_col_each_row = ao_activesheet.Cells(ll_each_row, ll_excel_max_col).End(xlToLeft).Column
If ll_max_col_each_row > ll_max_col_saved Then ll_max_col_saved = ll_max_col_each_row
Next
f_get_valid_data_max_col = ll_max_col_saved
End Function
Public Sub sub_protect_data(ByRef ao_worksheet As Worksheet)
On Error GoTo 0
'ao_worksheet.Unprotect
ao_worksheet.Cells.Locked = False
Dim lo_range As Range
Set lo_range = ao_worksheet.Range(ao_worksheet.Cells(1, 1) _
, ao_worksheet.Cells(f_get_valid_data_max_row(ao_worksheet), f_get_valid_data_max_col(ao_worksheet)) _
)
ao_worksheet.UsedRange.Locked = True
ao_worksheet.UsedRange.FormulaHidden = False
ao_worksheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
' ao_worksheet.Protect _
' DrawingObjects:=True _
' , Contents:=True _
' , Scenarios:=True _
' , AllowFormattingCells:=True _
' , AllowFormattingColumns:=True _
' , AllowFormattingRows:=True _
' , AllowInsertingColumns:=False _
' , AllowInsertingRows:=False _
' , AllowInsertingHyperlinks:=True _
' , AllowSorting:=True _
' , AllowFiltering:=True
End Sub
Public Sub sub_open_txt_file(ByVal as_file As String)
Dim lo_wsh As New WshSHell
Dim ls_default_app As String
Dim ls_app_path As String
Dim ls_shell_str As String
ls_default_app = lo_wsh.RegRead("HKEY_CLASSES_ROOT\.txt\")
ls_app_path = lo_wsh.RegRead("HKEY_CLASSES_ROOT\" & ls_default_app & "\shell\open\Command\")
If Len(ls_app_path) <= 0 Then
' MsgBox prompt:=ls_default_app & " not installed!", Buttons:=vbCritical + vbOKOnly, Title:="Error"
' Exit Sub
ls_app_path = "notepad.exe %1"
End If
Dim ls_command As String
ls_command = Application.Substitute(ls_app_path, "%1", as_file)
lo_wsh.exec ls_command
Set lo_wsh = Nothing
End Sub
Public Function f_if_sheet_exists(ByVal as_sheet_name As String)
Dim lo_each_sheet As Worksheet
'For Each lo_each_sheet In ao_workbook.Worksheets
For Each lo_each_sheet In ThisWorkbook.Worksheets
If LCase(lo_each_sheet.Name) = LCase(as_sheet_name) Then
f_if_sheet_exists = True
Exit Function
End If
Next
f_if_sheet_exists = False
End Function
Public Function f_get_prev_monthend(ByVal ad_base_date As Date) As Date
Dim ld_curr_date As Date
Dim ld_curr_mth_1st As Date
ld_curr_date = ad_base_date
ld_curr_mth_1st = DateSerial(Year(ld_curr_date), Month(ld_curr_date), 1)
f_get_prev_monthend = DateAdd("d", -1, ld_curr_mth_1st)
End Function
Public Function f_get_next_monthend(ByVal ad_base_date As Date) As Date
Dim ld_curr_date As Date
Dim ld_curr_month_1st As Date
Dim ld_curr_month_last As Date
Dim ld_next_month_1st As Date
Dim ld_next_month_last As Date
Dim ld_next_next_month_1st As Date
ld_curr_date = ad_base_date
'ld_curr_date = Date
ld_curr_month_1st = DateSerial(Year(ld_curr_date), Month(ld_curr_date), 1)
ld_next_month_1st = DateAdd("m", 1, ld_curr_month_1st)
ld_curr_month_last = DateAdd("d", -1, ld_next_month_1st)
If DateDiff("d", ld_curr_date, ld_curr_month_last) > 0 Then
f_get_next_monthend = ld_curr_month_last
Exit Function
Else
ld_next_next_month_1st = DateAdd("m", 1, ld_next_month_1st)
ld_next_month_last = DateAdd("d", -1, ld_next_next_month_1st)
f_get_next_monthend = ld_next_month_last
Exit Function
End If
End Function
Public Function f_remv_non_alphanum(ByVal as_string As String) As String
Dim lo_RegExp As New RegExp
lo_RegExp.Global = True
lo_RegExp.IgnoreCase = True
lo_RegExp.Pattern = "[^0-9a-zA-Z]"
If lo_RegExp.test(as_string) Then
f_remv_non_alphanum = lo_RegExp.Replace(as_string, "")
Else
f_remv_non_alphanum = Trim(as_string)
End If
Set lo_RegExp = Nothing
End Function
Public Function f_get_1st_value(ByVal as_string As String) As String
If Len(Trim(as_string)) = 0 Then
f_get_1st_value = ""
Exit Function
End If
Dim li_i As Integer
li_i = 0
Dim lo_RegExp As New RegExp
lo_RegExp.Global = True
lo_RegExp.IgnoreCase = True
lo_RegExp.Pattern = "[^0-9a-zA-Z]"
While Len(f_get_1st_value) = 0 And li_i <= UBound(Split(as_string, ";"))
f_get_1st_value = Trim(Split(as_string, ";")(li_i))
If lo_RegExp.test(f_get_1st_value) Then
f_get_1st_value = lo_RegExp.Replace(f_get_1st_value, "")
End If
li_i = li_i + 1
Wend
Set lo_RegExp = Nothing
End Function
Public Function f_get_mail_1st_value(ByVal as_string As String) As String
If Len(Trim(as_string)) = 0 Then
f_get_mail_1st_value = ""
Exit Function
End If
Dim li_i As Integer
li_i = 0
While Len(f_get_mail_1st_value) = 0
f_get_mail_1st_value = Trim(Split(as_string, ";")(li_i))
li_i = li_i + 1
Wend
End Function
Private Sub sub_gen_utf8_textfile(ByVal as_output_file As String)
Dim ls_spaces As String
Dim ls_zeros As String
Dim larr_report
Dim ll_each_row As Long
Dim ll_max_row As Long
Dim ll_each_col As Integer
'Dim ll_max_col As Integer
ls_spaces = String(100, " ")
ls_zeros = String(100, "0")
'Dim dict_col_indx As New Dictionary
'Call sub_init_col_indx_alpha(dict_col_indx)
larr_report = ThisWorkbook.Worksheets(gs_report_name).Range("A1").CurrentRegion
ll_max_row = UBound(larr_report, 1)
'll_max_col = UBound(larr_report, 2)
Dim li_each_deposit As Integer
'Dim li_repeat_cnt As Integer
'li_repeat_cnt = (ll_max_col - dict_col_indx(gs_rpt_col_after)) / gi_rpt_col_num
Dim larr_no_of_memeber
Dim li_addr_col_start As Integer
larr_no_of_memeber = ThisWorkbook.Worksheets(gs_report_name).Range(gs_no_of_memb_col & "2:" & gs_no_of_memb_col & ll_max_row)
li_addr_col_start = dict_col_indx(gs_rpt_col_after) + Application.Max(larr_no_of_memeber) * gi_rpt_col_num + 1
Dim ll_rec_num As Long
Dim ldc_sum_prcp_bal As Double
Dim ls_each_record
Dim ls_col_a, ls_col_b, ls_col_c, ls_col_d, ls_col_e, ls_col_f, ls_col_g, ls_col_h, ls_col_i
Dim ls_col_j, ls_col_k, ls_col_l, ls_col_m, ls_col_n, ls_col_o, ls_col_p, ls_col_q, ls_col_r
Dim ls_col_s, ls_col_t, ls_col_u, ls_col_w, ls_col_v, ls_col_x, ls_col_y
ldc_sum_prcp_bal = 0
For ll_each_row = 2 To ll_max_row
ldc_sum_prcp_bal = ldc_sum_prcp_bal + larr_report(ll_each_row, dict_col_indx("F")) 'nominal value/quantity
Next
ll_rec_num = larr_report(ll_max_row, dict_col_indx("A"))
Dim lo_output As New ADODB.Stream
lo_output.Type = 2
lo_output.Charset = "UTF-8"
lo_output.Open
' for truncate address
Dim adoStream As New ADODB.Stream
adoStream.Type = 2
adoStream.Charset = "UTF-8"
adoStream.Open
lo_output.WriteText (Left("UBS" & ls_spaces, 10) & _
Format(ll_rec_num, "0000000000") & _
Format(ldc_sum_prcp_bal, "0000000000000000000.0000000000;-000000000000000000.0000000000") _
), adWriteLine
For ll_each_row = 2 To ll_max_row
ls_each_record = Empty
ls_col_a = larr_report(ll_each_row, dict_col_indx("A")) 'Record number
ls_col_b = larr_report(ll_each_row, dict_col_indx("B")) 'deposit type code, 10 is short, need toconfirm
ls_col_c = larr_report(ll_each_row, dict_col_indx("C")) 'account number
ls_col_d = larr_report(ll_each_row, dict_col_indx("D"))
ls_col_e = larr_report(ll_each_row, dict_col_indx("E"))
ls_col_f = larr_report(ll_each_row, dict_col_indx("F"))
ls_col_g = larr_report(ll_each_row, dict_col_indx("G"))
ls_col_h = larr_report(ll_each_row, dict_col_indx("H"))
ls_col_i = larr_report(ll_each_row, dict_col_indx("I"))
ls_col_j = larr_report(ll_each_row, dict_col_indx("J"))
ls_col_k = larr_report(ll_each_row, dict_col_indx("K"))
ls_col_l = larr_report(ll_each_row, dict_col_indx("L"))
'ls_each_record = ls_each_record & StrConv(larr_report(ll_each_row, ll_each_col), vbUnicode)
ls_each_record = Right(ls_zeros & ls_col_a, 10) & _
Left(ls_col_b & ls_spaces, 10) & _
Right(ls_zeros & ls_col_c, 30) & _
Left(ls_col_d & ls_spaces, 30) & _
Left(ls_col_e & ls_spaces, 3) & _
Format(CDec(ls_col_f), "+000000000000000000.0000000000;-000000000000000000.0000000000") & _
Format(CDec(ls_col_g), "+000000000000000000.0000000000;-000000000000000000.0000000000") & _
f_date_rm_slash(ls_col_h) & _
Right(ls_zeros & ls_col_i, 3) & _
Left(ls_col_j & ls_spaces, 1) & _
Left(ls_col_k & ls_spaces, 1) & _
Left(Format(ls_col_l, "000") & ls_spaces, 3)
lo_output.WriteText ls_each_record
ls_each_record = Empty
If IsNull(ls_col_i) Or IsEmpty(ls_col_i) Then
ls_col_i = 0
End If
'Each Depositor Information
'For li_each_deposit = 0 To li_repeat_cnt - 1
For li_each_deposit = 0 To ls_col_i - 1
ls_col_m = larr_report(ll_each_row, (li_each_deposit * gi_rpt_col_num) + dict_col_indx("M"))
ls_col_n = larr_report(ll_each_row, (li_each_deposit * gi_rpt_col_num) + dict_col_indx("N"))
ls_col_o = larr_report(ll_each_row, (li_each_deposit * gi_rpt_col_num) + dict_col_indx("O"))
ls_col_p = larr_report(ll_each_row, (li_each_deposit * gi_rpt_col_num) + dict_col_indx("P"))
ls_col_q = larr_report(ll_each_row, (li_each_deposit * gi_rpt_col_num) + dict_col_indx("Q"))
ls_col_r = larr_report(ll_each_row, (li_each_deposit * gi_rpt_col_num) + dict_col_indx("R"))
ls_col_s = larr_report(ll_each_row, (li_each_deposit * gi_rpt_col_num) + dict_col_indx("S"))
ls_col_t = larr_report(ll_each_row, (li_each_deposit * gi_rpt_col_num) + dict_col_indx("T"))
ls_col_u = larr_report(ll_each_row, (li_each_deposit * gi_rpt_col_num) + dict_col_indx("U"))
ls_col_v = larr_report(ll_each_row, (li_each_deposit * gi_rpt_col_num) + dict_col_indx("V"))
'ls_col_w = larr_report(ll_each_row, (li_each_deposit * gi_rpt_col_num) + dict_col_indx("W"))
ls_col_w = f_LeftByBytes(adoStream, larr_report(ll_each_row, li_addr_col_start), 50) _
& f_LeftByBytes(adoStream, larr_report(ll_each_row, li_addr_col_start + 1), 50) _
& f_LeftByBytes(adoStream, larr_report(ll_each_row, li_addr_col_start + 2), 50) _
& f_LeftByBytes(adoStream, larr_report(ll_each_row, li_addr_col_start + 3), 50) _
& f_LeftByBytes(adoStream, larr_report(ll_each_row, li_addr_col_start + 4), 50)
ls_col_x = larr_report(ll_each_row, (li_each_deposit * gi_rpt_col_num) + dict_col_indx("X"))
ls_col_y = larr_report(ll_each_row, (li_each_deposit * gi_rpt_col_num) + dict_col_indx("Y"))
ls_each_record = ls_each_record & _
f_LeftByBytes(adoStream, ls_col_m, 100) & _
Left(ls_col_n & ls_spaces, 1) & _
Left(ls_col_o & ls_spaces, 1) & _
Left(ls_col_p & ls_spaces, 20) & _
f_date_rm_slash(ls_col_q) & _
Left(ls_col_r & ls_spaces, 20) & _
Left(ls_col_s & ls_spaces, 20) & _
Left(ls_col_t & ls_spaces, 100) & _
Left(ls_col_u & ls_spaces, 20) & _
Left(ls_col_v & ls_spaces, 20) & _
ls_col_w & _
Left(ls_col_x & ls_spaces, 20) & _
Left(ls_col_y & ls_spaces, 20)
Next
If ls_each_record = Empty Then
ls_each_record = String(600, " ") ' to append spaces
End If
'lo_output.WriteText RTrim(ls_each_record), adWriteLine
lo_output.WriteText ls_each_record, adWriteLine
'lo_output.WriteBlankLines (1)
Next
lo_output.WriteText Left("UBS" & ls_spaces, 10), adWriteLine
lo_output.SaveToFile as_output_file, 2
lo_output.Close
Set lo_output = Nothing
adoStream.Close
Set adoStream = Nothing
End Sub