[VBA] Replace EOL characters for converting it from unix to window format

https://github.com/walter426/VbaUtilities/blob/master/FileSysUtilities.bas

Because the default txt editor(notepad, VBA I/O) cannot recognize the EOL defined in Unix.
It is necessary to do the conversion in window by replacing below three characters.
vbCrLf->vbCr;
vbCr->vbLf;
vbCrL-> vbCr.

Below is an example to make use of the function I written before to do the EOL conversion in a file.

Code:
 Call ReplaceStrInFile("./sample.txt", Array(vbCrLf, vbLf, vbCr), Array(vbCr, vbCr, vbCrLf))

Ref:
http://waltertech426.blogspot.hk/2013/06/vba-replace-multiple-strings-in-file.html

[Sybase] Create Cross Tab Query

https://github.com/walter426/SybaseRef/blob/master/CrossTabQry.sql

There is no standard function in Sybase to create Cross Tab Query.
Below is the code modified from internet to do Cross Tab Query.

Code:

/*
cd UnixPath
isql -Udc -Pdc -Sdwhdb -w2000 < CrossTabQry.sql
*/

IF EXISTS (SELECT * FROM sysobjects WHERE 
              TYPE LIKE "P" 
              AND
              NAME LIKE "CrossTabQry")
              DROP PROC CrossTabQry
GO

CREATE PROC CrossTabQry
    @dayago INT
AS

    DECLARE
            @s_date VARCHAR(20)
            ,@col_len INT


    SELECT @s_date=CONVERT(CHAR(8), dateadd(day, -@dayago, getdate()), 1)
    SELECT @col_len = 15

    SELECT "DATE" = CONVERT(CHAR(8), DATE_ID, 1)
            ,"RECORD_ID" = SUBSTRING(RECORD_ID,1,10)
            
            ,"DataVector_0" = REPLACE(STR(SUM(ISNULL(CASE WHEN DCVECTOR_INDEX = 0 THEN DataVector ELSE 0 END, 0)), @col_len), "0" + REPLICATE(" ", @col_len - 1), REPLICATE(" ", @col_len - 1) + "0")
            ,"DataVector_1" = REPLACE(STR(SUM(ISNULL(CASE WHEN DCVECTOR_INDEX = 1 THEN DataVector ELSE 0 END, 0)), @col_len), "0" + REPLICATE(" ", @col_len - 1), REPLICATE(" ", @col_len - 1) + "0")
            ,"DataVector_2" = REPLACE(STR(SUM(ISNULL(CASE WHEN DCVECTOR_INDEX = 2 THEN DataVector ELSE 0 END, 0)), @col_len), "0" + REPLICATE(" ", @col_len - 1), REPLICATE(" ", @col_len - 1) + "0")
            ,"DataVector_3" = REPLACE(STR(SUM(ISNULL(CASE WHEN DCVECTOR_INDEX = 3 THEN DataVector ELSE 0 END, 0)), @col_len), "0" + REPLICATE(" ", @col_len - 1), REPLICATE(" ", @col_len - 1) + "0")
            ,"DataVector_4" = REPLACE(STR(SUM(ISNULL(CASE WHEN DCVECTOR_INDEX = 4 THEN DataVector ELSE 0 END, 0)), @col_len), "0" + REPLICATE(" ", @col_len - 1), REPLICATE(" ", @col_len - 1) + "0")
            ,"DataVector_5" = REPLACE(STR(SUM(ISNULL(CASE WHEN DCVECTOR_INDEX = 5 THEN DataVector ELSE 0 END, 0)), @col_len), "0" + REPLICATE(" ", @col_len - 1), REPLICATE(" ", @col_len - 1) + "0")
            ,"DataVector_6" = REPLACE(STR(SUM(ISNULL(CASE WHEN DCVECTOR_INDEX = 6 THEN DataVector ELSE 0 END, 0)), @col_len), "0" + REPLICATE(" ", @col_len - 1), REPLICATE(" ", @col_len - 1) + "0")
            ,"DataVector_7" = REPLACE(STR(SUM(ISNULL(CASE WHEN DCVECTOR_INDEX = 7 THEN DataVector ELSE 0 END, 0)), @col_len), "0" + REPLICATE(" ", @col_len - 1), REPLICATE(" ", @col_len - 1) + "0")
            ,"DataVector_8" = REPLACE(STR(SUM(ISNULL(CASE WHEN DCVECTOR_INDEX = 8 THEN DataVector ELSE 0 END, 0)), @col_len), "0" + REPLICATE(" ", @col_len - 1), REPLICATE(" ", @col_len - 1) + "0")
            ,"DataVector_9" = REPLACE(STR(SUM(ISNULL(CASE WHEN DCVECTOR_INDEX = 9 THEN DataVector ELSE 0 END, 0)), @col_len), "0" + REPLICATE(" ", @col_len - 1), REPLICATE(" ", @col_len - 1) + "0")
            ,"DataVector_10" = REPLACE(STR(SUM(ISNULL(CASE WHEN DCVECTOR_INDEX = 10 THEN DataVector ELSE 0 END, 0)), @col_len), "0" + REPLICATE(" ", @col_len - 1), REPLICATE(" ", @col_len - 1) + "0")
            ,"DataVector_11" = REPLACE(STR(SUM(ISNULL(CASE WHEN DCVECTOR_INDEX = 11 THEN DataVector ELSE 0 END, 0)), @col_len), "0" + REPLICATE(" ", @col_len - 1), REPLICATE(" ", @col_len - 1) + "0")
            ,"DataVector_12" = REPLACE(STR(SUM(ISNULL(CASE WHEN DCVECTOR_INDEX = 12 THEN DataVector ELSE 0 END, 0)), @col_len), "0" + REPLICATE(" ", @col_len - 1), REPLICATE(" ", @col_len - 1) + "0")
            ,"DataVector_13" = REPLACE(STR(SUM(ISNULL(CASE WHEN DCVECTOR_INDEX = 13 THEN DataVector ELSE 0 END, 0)), @col_len), "0" + REPLICATE(" ", @col_len - 1), REPLICATE(" ", @col_len - 1) + "0")
            ,"DataVector_14" = REPLACE(STR(SUM(ISNULL(CASE WHEN DCVECTOR_INDEX = 14 THEN DataVector ELSE 0 END, 0)), @col_len), "0" + REPLICATE(" ", @col_len - 1), REPLICATE(" ", @col_len - 1) + "0")
            ,"DataVector_15" = REPLACE(STR(SUM(ISNULL(CASE WHEN DCVECTOR_INDEX = 15 THEN DataVector ELSE 0 END, 0)), @col_len), "0" + REPLICATE(" ", @col_len - 1), REPLICATE(" ", @col_len - 1) + "0")
            
            ,"DataVectorPucch_0" = REPLACE(STR(SUM(ISNULL(CASE WHEN DCVECTOR_INDEX = 0 THEN DataVectorPucch ELSE 0 END, 0)), @col_len), "0" + REPLICATE(" ", @col_len - 1), REPLICATE(" ", @col_len - 1) + "0")
            ,"DataVectorPucch_1" = REPLACE(STR(SUM(ISNULL(CASE WHEN DCVECTOR_INDEX = 1 THEN DataVectorPucch ELSE 0 END, 0)), @col_len), "0" + REPLICATE(" ", @col_len - 1), REPLICATE(" ", @col_len - 1) + "0")
            ,"DataVectorPucch_2" = REPLACE(STR(SUM(ISNULL(CASE WHEN DCVECTOR_INDEX = 2 THEN DataVectorPucch ELSE 0 END, 0)), @col_len), "0" + REPLICATE(" ", @col_len - 1), REPLICATE(" ", @col_len - 1) + "0")
            ,"DataVectorPucch_3" = REPLACE(STR(SUM(ISNULL(CASE WHEN DCVECTOR_INDEX = 3 THEN DataVectorPucch ELSE 0 END, 0)), @col_len), "0" + REPLICATE(" ", @col_len - 1), REPLICATE(" ", @col_len - 1) + "0")
            ,"DataVectorPucch_4" = REPLACE(STR(SUM(ISNULL(CASE WHEN DCVECTOR_INDEX = 4 THEN DataVectorPucch ELSE 0 END, 0)), @col_len), "0" + REPLICATE(" ", @col_len - 1), REPLICATE(" ", @col_len - 1) + "0")
            ,"DataVectorPucch_5" = REPLACE(STR(SUM(ISNULL(CASE WHEN DCVECTOR_INDEX = 5 THEN DataVectorPucch ELSE 0 END, 0)), @col_len), "0" + REPLICATE(" ", @col_len - 1), REPLICATE(" ", @col_len - 1) + "0")
            ,"DataVectorPucch_6" = REPLACE(STR(SUM(ISNULL(CASE WHEN DCVECTOR_INDEX = 6 THEN DataVectorPucch ELSE 0 END, 0)), @col_len), "0" + REPLICATE(" ", @col_len - 1), REPLICATE(" ", @col_len - 1) + "0")
            ,"DataVectorPucch_7" = REPLACE(STR(SUM(ISNULL(CASE WHEN DCVECTOR_INDEX = 7 THEN DataVectorPucch ELSE 0 END, 0)), @col_len), "0" + REPLICATE(" ", @col_len - 1), REPLICATE(" ", @col_len - 1) + "0")
            ,"DataVectorPucch_8" = REPLACE(STR(SUM(ISNULL(CASE WHEN DCVECTOR_INDEX = 8 THEN DataVectorPucch ELSE 0 END, 0)), @col_len), "0" + REPLICATE(" ", @col_len - 1), REPLICATE(" ", @col_len - 1) + "0")
            ,"DataVectorPucch_9" = REPLACE(STR(SUM(ISNULL(CASE WHEN DCVECTOR_INDEX = 9 THEN DataVectorPucch ELSE 0 END, 0)), @col_len), "0" + REPLICATE(" ", @col_len - 1), REPLICATE(" ", @col_len - 1) + "0")
            ,"DataVectorPucch_10" = REPLACE(STR(SUM(ISNULL(CASE WHEN DCVECTOR_INDEX = 10 THEN DataVectorPucch ELSE 0 END, 0)), @col_len), "0" + REPLICATE(" ", @col_len - 1), REPLICATE(" ", @col_len - 1) + "0")
            ,"DataVectorPucch_11" = REPLACE(STR(SUM(ISNULL(CASE WHEN DCVECTOR_INDEX = 11 THEN DataVectorPucch ELSE 0 END, 0)), @col_len), "0" + REPLICATE(" ", @col_len - 1), REPLICATE(" ", @col_len - 1) + "0")
            ,"DataVectorPucch_12" = REPLACE(STR(SUM(ISNULL(CASE WHEN DCVECTOR_INDEX = 12 THEN DataVectorPucch ELSE 0 END, 0)), @col_len), "0" + REPLICATE(" ", @col_len - 1), REPLICATE(" ", @col_len - 1) + "0")
            ,"DataVectorPucch_13" = REPLACE(STR(SUM(ISNULL(CASE WHEN DCVECTOR_INDEX = 13 THEN DataVectorPucch ELSE 0 END, 0)), @col_len), "0" + REPLICATE(" ", @col_len - 1), REPLICATE(" ", @col_len - 1) + "0")
            ,"DataVectorPucch_14" = REPLACE(STR(SUM(ISNULL(CASE WHEN DCVECTOR_INDEX = 14 THEN DataVectorPucch ELSE 0 END, 0)), @col_len), "0" + REPLICATE(" ", @col_len - 1), REPLICATE(" ", @col_len - 1) + "0")
            ,"DataVectorPucch_15" = REPLACE(STR(SUM(ISNULL(CASE WHEN DCVECTOR_INDEX = 15 THEN DataVectorPucch ELSE 0 END, 0)), @col_len), "0" + REPLICATE(" ", @col_len - 1), REPLICATE(" ", @col_len - 1) + "0")

            
    FROM Table
    WHERE [DATE] = @s_date
    GROUP BY [DATE], [RECORD_ID]
    ORDER BY [RECORD_ID], [DATE]

GO

[VBS] Scheduling for running Microsoft Applications(.mdb, .xls, etc)

https://github.com/walter426/VbaUtilities/blob/master/schedule.vbs

Below is an example to do scheduling for running Microsoft Application.
To do scheduling for automation, it is necessary to bypass the error prompt to prevent the application pending.
However, because line label cannot be used in VBS. So actions after error bypassing have to be included in the if brackets which leave bad syntax in the code.

Code:

Option Explicit

'Schdule Task to append Database
Dim fso, oD

Set fso = CreateObject("Scripting.FileSystemObject")
Set oD = fso.GetDrive(fso.GetDriveName(WScript.ScriptFullName))

'Check whether space is enough for appending
If oD.FreeSpace/1024/1024/1024 < 2 then
    WScript.Quit
End If

Dim CurrDir_path
CurrDir_path = fso.GetParentFolderName(Wscript.ScriptFullName)

Dim oAccess
Set oAccess = CreateObject("access.application")

With oAccess
    .Visible = True

On Error Resume Next
    .OpenCurrentDatabase CurrDir_path & "\SampleDb.mdb"
    
If Err.Number = 0 Then
.DoCmd.RunMacro "ScheduleTask"

.CloseCurrentDatabase

End If 'Err.Number = 0

    .Quit

End With 'oAccess

Set oAccess = Nothing


WScript.Quit (0)

[VBA] Control the use of 'MsgBox' for automation

https://github.com/walter426/VbaUtilities/blob/master/General%20Utilities.bas

In my code, "MsgBox" is always replaced by "ShowMsgBox" which was written by me.
It is because the running VBA program will be held by the "MsgBox" dialog, so any automation cannot be executed.
Therefore, i need below codes insered in the "General Utilites" to control the prompt of the MsgBox dialog


Public NotShowMsgBox As Boolean

Public Function EnableMsgBox()
    NotShowMsgBox = False
End Function

Public Function DisableMsgBox()
    NotShowMsgBox = True
End Function

Public Function ShowMsgBox(str As String, Optional ByVal Buttons As Integer = vbOKOnly, Optional ByVal Title As Variant = Nothing) As Boolean
    
    If NotShowMsgBox = False Then
        Call MsgBox(str, Buttons, Title)
    End If
    
    ShowMsgBox = NotShowMsgBox
    
End Function

[VBA] Replace string by regular expression

https://github.com/walter426/VbaUtilities/blob/master/StrUtilities.bas

Although there are regular expression objects in VBA, it is too complicated when use it from zero.
There I have written below function to replace string by regular expression in an easy way.

Code:

'Replace substring by regular expression
'Ref: Microsoft VBScript Regular Expressions 5.5
Public Function Replace_RE(str As String, Pattern_f As String, substr_r As String) As String
    On Error GoTo Exit_Replace_RE
    
    Replace_RE = str
    
    Dim RE As RegExp
    Set RE = CreateObject("vbscript.regexp")
    
    With RE
        .MultiLine = True
        .Global = True
        .IgnoreCase = False
        .Pattern = Pattern_f
        
        Replace_RE = .Replace(str, substr_r)
    End With
    
Exit_Replace_RE:
    Exit Function

Err_Replace_RE:
    Call ShowMsgBox(Err.Description)
    Resume Exit_Replace_RE
End Function

[VBA] Export Access Table to Text file

https://github.com/walter426/VbaUtilities/blob/master/AccessObjUtilities.bas
20140718:
-Add Quotation field


20130906:
- Fix cannot handle null string in fields
- Fix cannot convert correct Date Time Format

In my experience, "DoCmd.TransferText acExportDelim" fails to export table in some cases.
Therefore, I had to write below function to replace the use of previous command.

Code:

'Export Access Table to Text file
Public Function ExportTableToTxt(Tbl_name As String, des As String, Optional Delim As String = " ", Optional Quotation As String = "", Optional HasFldName As Boolean = True, Optional NullStr As String = "", Optional DateFmt As String = "MM/DD/YY", Optional TimeFmt As String = "h:mm") As String
    On Error GoTo Err_ExportTableToTxt
    
    Dim FailedReason As String
    
    If des = "" Or Tbl_name = "" Then
        FailedReason = "Input is invalid"
        GoTo Exit_ExportTableToTxt
    End If
    
    If TableExist(Tbl_name) = False Then
        FailedReason = Tbl_name & " does not exist"
        GoTo Exit_ExportTableToTxt
    End If
    
    If Delim = "" Then
        Delim = " "
    End If

    
    Dim des_PortNum As Integer
    des_PortNum = FreeFile

    Open des For Output As #des_PortNum

    With CurrentDb
        Dim line As String
        line = ""
    
        If HasFldName = True Then
            Dim TD_Tbl As TableDef
            Set TD_Tbl = .TableDefs(Tbl_name)
            
            Dim fld As Field
            
            For Each fld In TD_Tbl.Fields
                line = line & fld.Name & Delim
            Next
            
            line = Left(line, Len(line) - Len(Delim))
            Print #des_PortNum, line
        End If
        
        
        Dim RS_Tbl As Recordset
        Set RS_Tbl = .OpenRecordset(Tbl_name)
        
        With RS_Tbl
            .MoveFirst
        
            Dim FldIdx As Integer
            Dim fld_str As String
            
            Do Until .EOF
                FldIdx = 0
                line = ""
                
                For FldIdx = 0 To .Fields.count - 1
                    If IsNull(.Fields(FldIdx)) = True Then
                        fld_str = NullStr
                    
                    ElseIf .Fields(FldIdx).Type = dbDate Then
                        If .Fields(FldIdx).Value > 1 Then
                            fld_str = Format(str(.Fields(FldIdx).Value), DateFmt)
                        Else
                            fld_str = Format(str(.Fields(FldIdx).Value), TimeFmt)
                        End If
                        
                    Else
                        fld_str = .Fields(FldIdx).Value
                        
                    End If
                    
                    
                    line = line & Quotation & fld_str & Quotation & Delim
                    
                Next
                
                line = Left(line, Len(line) - Len(Delim))
                Print #des_PortNum, line
                
                .MoveNext
                
            Loop
            
        End With 'RS_Tbl
        
        .Close
        
    End With 'CurrentDb
    
    Close #des_PortNum


Exit_ExportTableToTxt:
    ExportTableToTxt = FailedReason
    Exit Function

Err_ExportTableToTxt:
    FailedReason = Err.Description
    Resume Exit_ExportTableToTxt
        
End Function

[VBA] Convert Access Table into HTML Format

https://github.com/walter426/VbaUtilities/blob/master/AccessObjUtilities.bas
The intention to convert an Access Table into HTML format is due to the less supoort between access and outlook. In my recognition, it is impossible to copy an access table, and paste it into the body of an outlook mail directly through VBA.

Therefore, it is necessary to convert the access table into HTML format first, and insert the HTML code of the table into the HTMLBody of the outlook mail.

Below is the code.

'Convert Access Table into HTML Format
Public Function ConvertTblToHtml(Tbl_name As String, Html As String) As String
    On Error GoTo Err_ConvertTblToHtml
 
    Dim FailedReason As String
 
    If TableValid(Tbl_name) = False Then
        FailedReason = Tbl_name & "is not valid"
        GoTo Exit_ConvertTblToHtml
    End If
 

    Html = Html & "<table border = ""1"", style = ""font-size:9pt;"">" & vbCrLf

 
    Dim RS_Tbl As DAO.Recordset
    Set RS_Tbl = CurrentDb.OpenRecordset(Tbl_name)
 
    'Create table
    With RS_Tbl
        Dim fld_idx As Integer
 
        'Create header
        Html = Html & "<tr>" & vbCrLf
     
        For fld_idx = 0 To .Fields.count - 1
            Html = Html & "<th bgcolor = #c0c0c0>" & .Fields(fld_idx).Name & "</th>" & vbCrLf
        Next fld_idx 'For fld_idx = 0 To .Fields.count - 1
     
        Html = Html & "</tr>"
     
     
        'Create rows
        .MoveFirst
     
        Do Until .EOF
            Html = Html & "<tr>" & vbCrLf
         
            For fld_idx = 0 To .Fields.count - 1
                Html = Html & "<td>" & .Fields(fld_idx).Value & "</td>" & vbCrLf
            Next fld_idx 'For fld_idx = 0 To .Fields.count - 1
         
            Html = Html & "</tr>" & vbCrLf
         
            .MoveNext
        Loop

        .Close
     
    End With 'RS_TblD
 
 
    Html = Html & "</table>"
 
 
Exit_ConvertTblToHtml:
    ConvertTblToHtml = FailedReason
    Exit Function

Err_ConvertTblToHtml:
    MsgBox Err.Description
    Resume Exit_ConvertTblToHtml
End Function

[QGIS] QgisUtilites

https://github.com/walter426/QgisUtilites/

Description:
[Python QGIS]: Collection of Utilites frequently used

SQLiteTool:
- Initialize SQLite Db
- Exampls to create SQLite Tables
- Create a table Joining Two SQLite points into a Line string
- Delete Spatialite Geometry Column
- Recover Spatialite Geometry Column
- Add Spatialite Geometry Column
- Data Type Mapping from xlrd to SQLite

[VBA] Collection of Utilites frequently used

https://github.com/walter426/VbaUtilities

VbaUtilites
Creater: Walter Tsui

Description:
[VBA]: Collection of Utilites frequently used

AccessObjUtilities
- Delete Table
- Delete Table by sub string
- Check whether table exists or not
- Delete Query
- Check whether query exist or not
- Obtain record counts of a table
- Obtain record counts of a query
- Obtain record counts of a SQL object
- Check whether a table is valid or not
- Check whether a query is valid or not
- Link Table Through Table Definition
- Remove all link tables
- Get the current path of a link table
- Get Link Table connection Info
- Obtain a string with all columns names of a table
- Find a column in a table
- Export Table to Text file
- Convert Access Table into HTML Format
- Generate a concatenated string of related records (SQL Query Use)

ArrayUtilities
- Find item in an array
- Append items to an array
- Delete item in an array by index

ExcelUtilities:
- Check whether specified worksheet exists or not in specified workbook
- Convert Column Number To Column Letter
- Link multiple worksheets in workbooks
- Export a table to one or more worksheets in case row count over 65535
- Replace String in a range of a worksheet that enclose any excel error in a function

FileSysUtilities:
- Check whether a file exists
- Copy File without error msg
- Unzip multiple files in directory
- Unzip a file
- Ftp upload file
- Ftp download file
- Count Row Number of a text file
- Split a Text File into multiple text files of specified row count(default: 65535)
- Delete rows in a text file
- Replace multiple strings in multiple files in a folder
- Replace multiple strings in a file

General Utilities:
- Enable user-defined MsgBox
- Disable user-defined MsgBox
- Display string in a msgbox depending on the user-defined flag

MathUtilities:
- Min
- Max
- Ceiling
- Logarithm of base 10

ShellUtilities:
- Start a Shell command and wait for it to finish, hiding while it is running.
- Send multiples shell commands with timeout

SqlUtilities:
- Run SQL command without warning msg
- Re-Select table columns
- Update multiple columns of a table under the same condition
- Update a column of a table under a specified condition
- Create Table with dedicated Column and Expressions from a source table
- Create Table of group function, there is a default Group function for all columns, columns can be specified to different group fucntion
- Create a set of grouped table, the grouping config is set in a specified table
- Create table which are joined from two tables having the same columns for joining
- Create table which is cancatenated from multiple tables of the same structure
- Execute SQLite Command Set
- Append Table into a SQLite database

StrUtilities:
- Split a string into array by separator
- Find string in an array
- Replace substring by regular expression

[Python] Tools to enter commands and capture log automatically from telnet batchly.

https://github.com/walter426/TelnetToLog

20130808:
Modify to support multiple arguments in templates


TelnetToLog
Creater: Walter Tsui

Description:
[Python]: Tools to enter commands and capture log automatically from telnet batchly.

1. Set the IP config in "TelnetToLog.py"
2. Set commands template in the folder, "template"
3. Create "log" folder, "list.txt" in the folder, "log". the "list.txt" declares the arguments will be passed into the template,
    where "CELL" are used in the template to be the argument passed here.
4. Modify "TelnetToLog_batch.bat" to process the batch DL

[VBA] Send Commands to shell with Timeout

https://github.com/walter426/VbaUtilities/blob/master/ShellUtilities.bas

Dim oShell As Object
Set oShell = CreateObject("WScript.Shell")

Dim CmdTxt As String

CmdTxt =  line1 & vbCrLf & _
                  line2 & vbCrLf & _
                  ""
    
oShell.Run ("cmd.exe")
Sleep 1000
   
FailedReason = Shell_SendKeysWithTimeout(oShell, CmdTxt, 1000)

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Public Function Shell_SendKeysWithTimeout(oShell As Object, CmdTxt As String, Timeout As Integer) As String
    On Error GoTo Err_Shell_SendKeysWithTimeout
    
    Dim FailedReason As String
    
    
    Dim CmdSet As Variant
    CmdSet = SplitStrIntoArray(CmdTxt, Chr(10))
    
    Dim cmd_idx As Integer
    
    For cmd_idx = 0 To UBound(CmdSet)
        If CmdSet(cmd_idx) = "" Then
            GoTo Next_Shell_SendKeysWithTimeout
        End If
        
        
        With oShell
            .SendKeys (CmdSet(cmd_idx) & vbCrLf)
            Sleep Timeout
        End With 'oShell
        
Next_Shell_SendKeysWithTimeout:
    Next cmd_idx


Exit_Shell_SendKeysWithTimeout:
    Shell_SendKeysWithTimeout = FailedReason
    Exit Function

Err_Shell_SendKeysWithTimeout:
    MsgBox Err.Description
    Resume Exit_Shell_SendKeysWithTimeout
    
End Function

Ref:
SplitStrIntoArray:
http://waltertech426.blogspot.hk/2013/06/vba-split-string-and-trim-space.html

[VBA] Split String And Trim Space

Public Function SplitStrIntoArray(str As String, separator As String) As Variant
    Dim Arr As Variant
    
    If Len(str) > 0 Then
        Arr = Split(str, separator)
        
        Dim i As Integer
        
        For i = 0 To UBound(Arr)
            Arr(i) = Trim(Arr(i))
        Next i
    Else
        Arr = Array()
    End If
    
    SplitStrIntoArray = Arr
    
End Function

[VBA] FTP Upload And Download

https://github.com/walter426/VbaUtilities/blob/master/FileSysUtilities.bas

20140813:
- Add Error handling

20130905:
- Fix the current directory of the window shell is changed to the local ftp directory after ftp download/upload.

20130807:
- Fix do not delete temp files in FTPDownload
- Add Optional argument "Delay" to set a guard time after upload/download as the there are some cases that some files are still being transferred  after the ftp commands had been finished even the the shell command is set to do waiting.

Below code are modified from internet with proper variable declration for use in VBA.

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

'Ftp upload file
Public Function FTPUpload(Site, sUsername, sPassword, sLocalFile, sRemotePath, Optional Delay As Integer = 1000) As String
    On Error GoTo Err_FTPUpload

    Dim FailedReason As String
    
    Dim oFTPScriptFSO As Object
    Dim oFTPScriptShell As Object
    
    Set oFTPScriptFSO = CreateObject("Scripting.FileSystemObject")
    Set oFTPScriptShell = CreateObject("WScript.Shell")
    
    sRemotePath = Trim(sRemotePath)
    sLocalFile = Trim(sLocalFile)
    
    
    '----------Path Checks---------
    'Here we willcheck the path, if it contains
    'spaces then we need to add quotes to ensure
    'it parses correctly.
    If InStr(sRemotePath, " ") > 0 Then
        If Left(sRemotePath, 1) <> """" And Right(sRemotePath, 1) <> """" Then
            sRemotePath = """" & sRemotePath & """"
        End If
    End If
    
    If InStr(sLocalFile, " ") > 0 Then
        If Left(sLocalFile, 1) <> """" And Right(sLocalFile, 1) <> """" Then
            sLocalFile = """" & sLocalFile & """"
        End If
    End If
    
    
    'Check to ensure that a remote path was
    'passed. If it's blank then pass a "\"
    If Len(sRemotePath) = 0 Then
        'Please note that no premptive checking of the
        'remote path is done. If it does not exist for some
        'reason. Unexpected results may occur.
        sRemotePath = "\"
    End If
    
    
    'Check the local path and file to ensure
    'that either the a file that exists was
    'passed or a wildcard was passed.
    If InStr(sLocalFile, "*") Then
        If InStr(sLocalFile, " ") Then
            FailedReason = "Error: Wildcard uploads do not work if the path contains a space." & vbCrLf
            FailedReason = FailedReason & "This is a limitation of the Microsoft FTP client."
            
            GoTo Exit_FTPUpload
        End If
        
    ElseIf Len(sLocalFile) = 0 Or Not oFTPScriptFSO.FileExists(sLocalFile) Then
        'nothing to upload
        FailedReason = "Error: File Not Found."
        GoTo Exit_FTPUpload
        
    End If
    '--------END Path Checks---------
    
    
    'build input file for ftp command
    Dim sFTPScript As String
    
    sFTPScript = sFTPScript & "USER " & sUsername & vbCrLf
    sFTPScript = sFTPScript & sPassword & vbCrLf
    sFTPScript = sFTPScript & "cd " & sRemotePath & vbCrLf
    sFTPScript = sFTPScript & "binary" & vbCrLf
    sFTPScript = sFTPScript & "prompt n" & vbCrLf
    sFTPScript = sFTPScript & "put " & sLocalFile & vbCrLf
    sFTPScript = sFTPScript & "quit" & vbCrLf & "quit" & vbCrLf & "quit" & vbCrLf
    
    
    Dim sFTPTemp As String
    Dim sFTPTempFile As String
    Dim sFTPResults As String
    
    sFTPTemp = oFTPScriptShell.ExpandEnvironmentStrings("%TEMP%")
    sFTPTempFile = sFTPTemp & "\" & oFTPScriptFSO.GetTempName
    sFTPResults = sFTPTemp & "\" & oFTPScriptFSO.GetTempName
    
    
    'Write the input file for the ftp command
    'to a temporary file.
    Dim fFTPScript As Object
    Set fFTPScript = oFTPScriptFSO.CreateTextFile(sFTPTempFile, True)
    
    fFTPScript.WriteLine (sFTPScript)
    fFTPScript.Close
    
    Set fFTPScript = Nothing
    
    oFTPScriptShell.Run "%comspec% /c FTP -n -s:" & sFTPTempFile & " " & Site & " > " & sFTPResults, 0, True
    Sleep Delay
    
    
    'Check results of transfer.
    Dim fFTPResults As Object
    Dim sResults As String
    
    Const OpenAsDefault = -2
    Const FailIfNotExist = 0
    Const ForReading = 1
    Const ForWriting = 2

    Set fFTPResults = oFTPScriptFSO.OpenTextFile(sFTPResults, ForReading, FailIfNotExist, OpenAsDefault)
    sResults = fFTPResults.ReadAll
    fFTPResults.Close
    
    
    If InStr(sResults, "226 Transfer complete.") > 0 Then
        FailedReason = ""
    ElseIf InStr(sResults, "File not found") > 0 Then
        FailedReason = "Error: File Not Found"
    ElseIf InStr(sResults, "cannot log in.") > 0 Then
        FailedReason = "Error: Login Failed."
    Else
        FailedReason = "Error: Unknown."
    End If
    
    
    oFTPScriptFSO.DeleteFile (sFTPTempFile)
    oFTPScriptFSO.DeleteFile (sFTPResults)
    
    Set oFTPScriptFSO = Nothing
    
    oFTPScriptShell.CurrentDirectory = sOriginalWorkingDirectory
    Set oFTPScriptShell = Nothing
    
    
Exit_FTPUpload:
    FTPUpload = FailedReason
    Exit Function
    
Err_FTPUpload:
    FailedReason = Err.Description
    Resume Exit_FTPDownload
    
End Function

'Ftp download file
Function FTPDownload(Site, sUsername, sPassword, sLocalPath, sRemotePath, sRemoteFile, Optional Delay As Integer = 1000) As String
    On Error GoTo Err_FTPDownload
    
    Dim FailedReason As String
    
    Dim oFTPScriptFSO As Object
    Dim oFTPScriptShell As Object
    
    Set oFTPScriptFSO = CreateObject("Scripting.FileSystemObject")
    Set oFTPScriptShell = CreateObject("WScript.Shell")
    
    
    sRemotePath = Trim(sRemotePath)
    sLocalPath = Trim(sLocalPath)
    
    '----------Path Checks---------
    If InStr(sRemotePath, " ") > 0 Then
        If Left(sRemotePath, 1) <> """" And Right(sRemotePath, 1) <> """" Then
            sRemotePath = """" & sRemotePath & """"
        End If
    End If
    
    
    If Len(sRemotePath) = 0 Then
        sRemotePath = "\"
    End If
    
    
    'If the local path was blank. Pass the current working direcory.
    If Len(sLocalPath) = 0 Then
        sLocalPath = oFTPScriptShell.CurrentDirectory
    End If
    
    
    If Not oFTPScriptFSO.FolderExists(sLocalPath) Then
        'destination not found
        FailedReason = "Error: Local Folder Not Found."
        GoTo Exit_FTPDownload
    End If
    
    
    Dim sOriginalWorkingDirectory As String
    sOriginalWorkingDirectory = oFTPScriptShell.CurrentDirectory
    oFTPScriptShell.CurrentDirectory = sLocalPath
    '--------END Path Checks---------
    
    'build input file for ftp command
    Dim sFTPScript As String
    sFTPScript = ""
    
    sFTPScript = sFTPScript & "USER " & sUsername & vbCrLf
    sFTPScript = sFTPScript & sPassword & vbCrLf
    sFTPScript = sFTPScript & "cd " & sRemotePath & vbCrLf
    sFTPScript = sFTPScript & "binary" & vbCrLf
    sFTPScript = sFTPScript & "prompt n" & vbCrLf
    sFTPScript = sFTPScript & "mget " & sRemoteFile & vbCrLf
    sFTPScript = sFTPScript & "quit" & vbCrLf & "quit" & vbCrLf & "quit" & vbCrLf
    
    
    Dim sFTPTemp As String
    Dim sFTPTempFile As String
    Dim sFTPResults As String
    
    sFTPTemp = oFTPScriptShell.ExpandEnvironmentStrings("%TEMP%")
    sFTPTempFile = sFTPTemp & "\" & oFTPScriptFSO.GetTempName
    sFTPResults = sFTPTemp & "\" & oFTPScriptFSO.GetTempName
    
    'Write the input file for the ftp command to a temporary file.
    Dim fFTPScript As Object
    Set fFTPScript = oFTPScriptFSO.CreateTextFile(sFTPTempFile, True)
    
    fFTPScript.WriteLine (sFTPScript)
    fFTPScript.Close
    
    Set fFTPScript = Nothing
    
    
    oFTPScriptShell.Run "%comspec% /c FTP -n -s:" & sFTPTempFile & " " & Site & " > " & sFTPResults, 0, True
    Sleep Delay

    
    'Check results of transfer.
    Dim fFTPResults As Object
    Dim sResults As String
    
    Const OpenAsDefault = -2
    Const FailIfNotExist = 0
    Const ForReading = 1
    Const ForWriting = 2
    
    Set fFTPResults = oFTPScriptFSO.OpenTextFile(sFTPResults, ForReading, FailIfNotExist, OpenAsDefault)
    sResults = fFTPResults.ReadAll
    fFTPResults.Close
    
    
    If InStr(sResults, "226 Transfer complete.") > 0 Then
        FailedReason = ""
    ElseIf InStr(sResults, "File not found") > 0 Then
        FailedReason = "Error: File Not Found"
    ElseIf InStr(sResults, "cannot log in.") > 0 Then
        FailedReason = "Error: Login Failed."
    Else
        FailedReason = "Error: Unknown."
    End If
    
    
    oFTPScriptFSO.DeleteFile (sFTPTempFile)
    oFTPScriptFSO.DeleteFile (sFTPResults)
    
    Set oFTPScriptFSO = Nothing
    
    oFTPScriptShell.CurrentDirectory = sOriginalWorkingDirectory
    Set oFTPScriptShell = Nothing
    
    
Exit_FTPDownload:
    FTPDownload = FailedReason
    Exit Function
    
Err_FTPDownload:
    FailedReason = Err.Description
    Resume Exit_FTPDownload
    
End Function

[VBA] Unzip a File and Files in a folder

I used to try to find methods within VBA to unzip files, but the result was failed.

So I have to do the extraction by an external command line program, 7zip is used here.

Below is the url for the command line version of 7 zip.

http://www.7-zip.org/download.html

1. ShellAndWait is not a standard method in VBA, pls find it in this url, http://waltertech426.blogspot.hk/2013/06/vba-do-shell-command-and-wait-it-finishs.html.

2. ZipTool_local_path is a global constant which define the relative location of the 7zip command line program,
e.g. \7za\7za

Public Function ExtractZipInDir(SrcDir As String, DesDir As String, Optional Criteria As String = "", Optional DeleteZipFile As Boolean = False) As String
    On Error GoTo Err_ExtractZip
    
    Dim FailedReason As String
    
    Dim Result As String
    
    Criteria = SrcDir & Criteria
    Result = Dir(Criteria)
    
    
    Do While Len(Result) > 0
        Call ExtractZip(SrcDir & Result, DesDir, DeleteZipFile)
        Result = Dir
    Loop

Exit_ExtractZip:
    ExtractZipInDir = FailedReason
    Exit Function

Err_ExtractZip:
    Call ShowMsgBox(Err.Description)
    Resume Exit_ExtractZip

End Function

Public Function ExtractZip(Src As String, DesDir As String, Optional DeleteZipFile As Boolean = False) As String
    On Error GoTo Err_ExtractZip
    
    Dim FailedReason As String
    
    Dim ZipTool_path As String
    ZipTool_path = [CurrentProject].[Path] & ZipTool_local_path
    
    Dim ShellCmd As String
    Dim Success As Boolean

    
    ShellCmd = ZipTool_path & " x " & Src & " -o" & DesDir & " -ry"
    'MsgBox ShellCmd
    Success = ShellAndWait(ShellCmd, vbHide)

    If Success = True And DeleteZipFile = True Then
        Kill Src
    End If

Exit_ExtractZip:
    ExtractZip = FailedReason
    Exit Function

Err_ExtractZip:
    Call ShowMsgBox(Err.Description)
    Resume Exit_ExtractZip

End Function 

[VBA] Replace multiple strings in a file and files in a folder

https://github.com/walter426/VbaUtilities/blob/master/FileSysUtilities.bas

Below functions are written to do replacing in an efficient ways.

'Replace multiple strings in multiple files in a folder
Function ReplaceStrInFolder(folder_name As String, Arr_f As Variant, Arr_r As Variant, Optional StartRow As Long = 0) As String
    On Error GoTo Err_ReplaceStrInFolder
    
    Dim FailedReason As String
    
    Dim file_name As String
        
    file_name = Dir(folder_name & "\")
        
    Do Until file_name = ""
        file_name = folder_name & "\" & file_name
        Call ReplaceStrInFile(file_name, Arr_f, Arr_r, StartRow)
        file_name = Dir()
    Loop

Exit_ReplaceStrInFolder:
    ReplaceStrInFolder = FailedReason
    Exit Function
    
Err_ReplaceStrInFolder:
    FailedReason = Err.Description
    GoTo Exit_ReplaceStrInFolder
    
End Function

'Replace multiple strings in a file
Function ReplaceStrInFile(file_name As String, Arr_f As Variant, Arr_r As Variant, Optional StartRow As Long = 0) As String
    On Error GoTo Err_ReplaceStrInFile
    
    Dim FailedReason As String
    
    Dim temp_file_name As String
    temp_file_name = file_name & "_temp"
    
    On Error Resume Next
    Kill temp_file_name
    On Error GoTo Err_ReplaceStrInFile
    
    
    Dim iFileNum As String
    iFileNum = FreeFile()
    
    Open temp_file_name For Output As #iFileNum
    
    Dim fso As Object
    Dim File As Object
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set File = fso.OpenTextFile(file_name, 1)

    Dim row As Long
    Dim str_line As String
    Dim i As Integer
    Dim str_f As String
    Dim str_r As String

    row = 0


    Do Until File.AtEndOfStream = True 'EOF(2)
        row = row + 1
        
        str_line = File.ReadLine
    
        If row < StartRow Then
            GoTo Loop_ReplaceStrInFile_1
        End If
    
        For i = 0 To UBound(Arr_f)
            str_f = Arr_f(i)
            str_r = Arr_r(i)
            
            str_line = Replace(str_line, str_f, str_r)

        Next i
        
Loop_ReplaceStrInFile_1:

        Print #iFileNum, str_line
        
    Loop


    File.Close
    Close iFileNum
    Kill file_name
    Name temp_file_name As file_name
    

Exit_ReplaceStrInFile:
    ReplaceStrInFile = FailedReason
    Exit Function
    
Err_ReplaceStrInFile:
    FailedReason = Err.Description
    GoTo Exit_ReplaceStrInFile
    
End Function

[VBA] Copy File bypass error

If call "FileCopy" method in VBA, an error may occur when copying file from network drive to local computer in my experience.

Therefore, It is necessary to call an alternative method to overcome it.
Below is the code to make use of the  FileSystemObject to replace the FileCopy method.

Public Sub CopyFileBypassErr(src As String, des As String)
    Dim objFSO As Object
    Set objFSO = CreateObject("Scripting.FileSystemObject")
 
    'object.copyfile,source,destination,file overright(True is default)
    objFSO.CopyFile src, des, True
 
    Set objFSO = Nothing
End Sub

[VBA] Do Shell Command And Wait it finishs

Below code are modified from internet.

Call ShellAndWait(ShellCmd, vbHide)

' Start the indicated program and wait for it
' to finish, hiding while we wait.
Public Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Public Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Public Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Long) As Long

Const INFINITE = &HFFFF

Const SYNCHRONIZE = &H100000

Public Function ShellAndWait(ByVal cmd As String, _
    ByVal window_style As VbAppWinStyle) As Boolean
    Dim process_id As Long
    Dim process_handle As Long

    ' Start the program.
    On Error GoTo ShellError
    
    ShellAndWait = False
        
    process_id = Shell(cmd, window_style)
    On Error GoTo 0

    ' Wait for the program to finish.
    ' Get the process handle.
    process_handle = OpenProcess(SYNCHRONIZE, 0, process_id)
    
    If process_handle <> 0 Then
        WaitForSingleObject process_handle, INFINITE
        CloseHandle process_handle
        
        ShellAndWait = True
    End If

    Exit Function

ShellError:
    'MsgBox "Error starting task " & _
    '    txtProgram.text & vbCrLf & _
    '    Err.Description, vbOKOnly Or vbExclamation, _
    '    "Error"
    ShellAndWait = False

End Function

[VBA]Automation of Sending Email in Outlook without Security Warning

20130627: I found out this method is valid only after the visual basic editor of the outlook application has been opened once in order to refresh the macro reference of the outlook.

it is very annoying a security dialog will be prompted for comfirmation when send email from any VBA macro out of Outlook.

After my investigation, it is impossible to turn off this annoying dialog, but it can be bypassed.

In my investigation, the dialog will be prompted out when the "olMailItem.send" method is called directly in any application out of outlook like below.

Dim olApp As Outlook.Application
Set olApp = CreateObject("Outlook.Application")

Dim objMail As Outlook.MailItem
Set objMail = olApp.CreateItem(olMailItem)

With objMail
    .Subject = Subject_N
    .To = To_N
    .cc = CC_N
   
    .Attachments.Add (Attach_N)
   
    .Body = Body_N
   
    .Send

End With 'objMail

Therefore, I tried to pass the olMailItem to the outlook, let the outlook do the sending like below.

Application:

Dim olApp As Outlook.Application
Set olApp = CreateObject("Outlook.Application")

Dim objMail As Outlook.MailItem
Set objMail = olApp.CreateItem(olMailItem)

With objMail
    .Subject = Subject_N
    .To = To_N
    .cc = CC_N
   
    .Attachments.Add (Attach_N)
   
    .Body = Body_N

End With 'objMail

Call olApp.SendNewMail(objMail)

Outlook(ThisOutlookSession):

Public Sub SendNewMail(objMail as olMailItem)
        objMail.Send
End Sub


However, it fails too. I found out once the olMailItem is created not in the outlook, the dialog will be still prompted. Even if I created another olMailItem, and copy its properties one by one, the trouble still exists.

So, only one way is left, pass the property one by one, let the outlook created the mail item. and send the mail itself like below.

Application:
Dim olApp As Outlook.Application
Set olApp = CreateObject("Outlook.Application")

Call olApp.SendNewMail(Subject_N, To_N, CC_N, Body_N, Attach_N)

Outlook(ThisOutlookSession):

 Public Sub SendNewMail(Subject_N As String, To_N As String, Optional CC_N As String = "", Optional Body_N As String = "", Optional Attach_N As String = "")
    Dim objMail As MailItem
    Set objMail = CreateItem(olMailItem)

    With objMail
        .Subject = Subject_N
        .To = To_N
        
        If CC_N <> "" Then
            .CC = CC_N
        End If
        
        If Body_N <> "" Then
            .Body = Body_N
        End If
        
        If Attach_N <> "" Then
            .Attachments.Add Attach_N
        End If
        
        .Send
        
    End With
    
End Sub


Finally, it works.