Month: January 2019

Get selection formatting

Here is a nice and handy script to get all the main format for a range selection, that can be applied afterwards to same range (as template): 
Public Sub sFormatGet()
    Call fFormatGet(Selection)
End Sub

Public Function fRangeR1C1(ByVal oXlRng As Excel.Range, _
                           Optional ByVal oXlRef As Excel.Range = Nothing) As String
    Dim lgC As Long
    Dim lgR As Long
    Dim strRngR1C1 As String

    If oXlRef Is Nothing Then
        Set oXlRef = ActiveSheet.Cells(1, 1)
    End If

    lgR = oXlRng.Row
    lgC = oXlRng.Column

    fRangeR1C1 = strRngR1C1
End Function

Public Function fFormatGet(ByRef oXlRng As Excel.Range, _
                           Optional ByVal ReferenceStyle As XlReferenceStyle = xlA1) As Boolean
    If oXlRng Is Nothing Then
        Set oXlRng = Selection.Cells
    End If

    Dim oXlCell As Excel.Range
    Dim lgBorder As Long
    Dim iFileOut As Integer
    Dim bFormat As Boolean
    Dim bRange As Boolean
    Dim strRange As String

    Close
    iFileOut = VBA.FreeFile()
    Open VBA.Environ$("UserProfile") & "\Documents\" & "#Format.bas" For Output As #iFileOut
    
    Print #iFileOut, "Private Sub sFormatSet(ByVal xlWsh As Excel.Worksheet)"
    Print #iFileOut, "  'Dim oXlCell As Excel.Range"
    Print #iFileOut, ""
    Print #iFileOut, "  With xlWsh"
    
    For Each oXlCell In oXlRng.Cells
        bFormat = False
        bRange = False
        If oXlCell.MergeCells Then
            ' only if cell is the left-top most cell in merge area,...
            If oXlCell.MergeArea.Cells(1, 1).Address = oXlCell.Address Then
                bFormat = True
                oXlCell.MergeArea.Merge
                bRange = True
                strRange = ".Range(""" & oXlCell.MergeArea.Address & """)"
                
                'If ReferenceStyle = xlA1 Then
                '    strRange = .Formula
                'Else
                '    strRange = fRangeR1C1(oXlCell.MergeArea)
                'End If
            End If
        Else
            bFormat = True
            strRange = ".Cells(" & oXlCell.Row & ", " & oXlCell.Column & ")"
            
            'If ReferenceStyle = xlA1 Then
            '    strRange = .Formula
            'Else
            '    strRange = fRangeR1C1(oXlCell)
            'End If
        End If
        
        If bFormat Then
        Print #iFileOut, "    With " & strRange
        Print #iFileOut, "      .Merge"
        If oXlCell.Formula <> vbNullString Then
            'If ReferenceStyle = xlA1 Then
                Print #iFileOut, "      .Formula = " & VBA.Replace(oXlCell.Formula, """", """""")
            'Else
            '    Print #iFileOut, "      .Formula = " & VBA.Replace(oXlCell.FormulaR1C1, """", """""")
            'End If
        End If
        
        With oXlCell
            If .IndentLevel <> 0 Then
                Print #iFileOut, "    .IndentLevel = " & .IndentLevel
            End If
            
            With .Font
                Print #iFileOut, "      With .Font"
                Print #iFileOut, "        .Name = """ & .Name & """"
                Print #iFileOut, "        .Color = " & .Color
                Print #iFileOut, "        .Size = " & .Size
                If .Bold Then Print #iFileOut, "        .Bold = " & .Bold
                If .Italic Then Print #iFileOut, "        .Italic = " & .Italic
                If .Underline <> xlNone Then Print #iFileOut, "        .Underline = " & VBA.CBool(.Underline)
                If .Strikethrough Then Print #iFileOut, "        .Strikethrough = " & VBA.CBool(.Strikethrough)
                If .Subscript Then Print #iFileOut, "        .Subscript = " & VBA.CBool(.Subscript)
                If .Superscript Then Print #iFileOut, "        .Superscript = " & VBA.CBool(.Superscript)
                Print #iFileOut, "      End With"
            End With
            If .Hyperlinks.Count > 0 Then
                With .Hyperlinks(1)
                    Print #iFileOut, "    .Hyperlinks.Add(" & _
                        "               Anchor:=" & oXlCell & ", " & _
                        VBA.IIf(.Address = vbNullString, "", "               Address:=" & .Address & ", ") & _
                        VBA.IIf(.SubAddress = vbNullString, "", "               SubAddress:=" & .SubAddress & ", ") & _
                        VBA.IIf(.ScreenTip = vbNullString, "", "               ScreenTip:=" & .ScreenTip & ", ") & _
                        VBA.IIf(.TextToDisplay = vbNullString, "", "               TextToDisplay:=" & .TextToDisplay & ", ") & _
                        ")"
                End With
            End If
            Print #iFileOut, "      .NumberFormat = """ & .NumberFormat & """"
            Print #iFileOut, "      .Orientation = " & .Orientation
            Print #iFileOut, "      .ShrinkToFit = " & .ShrinkToFit
            
            With .Interior
                Print #iFileOut, "      With .Interior"
                If .ColorIndex <> xlNone Then Print #iFileOut, "        .ColorIndex = " & .ColorIndex
                If .PatternColor <> 0 Then Print #iFileOut, "        .PatternColor = " & .PatternColor
                If .Pattern <> xlNone Then Print #iFileOut, "        .Pattern = " & .Pattern
                Print #iFileOut, "      End With"
            End With
        End With
        
        For lgBorder = xlEdgeLeft To xlEdgeRight
            With oXlCell.Borders(lgBorder)
                Print #iFileOut, "      With .Borders(" & lgBorder & ")"
                Print #iFileOut, "        .LineStyle = " & .LineStyle
                'Print #iFileOut, "        .ThemeColor = " & .ThemeColor
                If .TintAndShade <> 0 Then Print #iFileOut, "        .TintAndShade = " & .TintAndShade
                If .Color <> 0 Then Print #iFileOut, "        .Color = " & .Color
                Print #iFileOut, "        .Weight = " & .Weight
                Print #iFileOut, "      End With"
            End With
        Next lgBorder
        Print #iFileOut, "    End With"
        Print #iFileOut, ""
        End If
    Next oXlCell
    
    Print #iFileOut, "  End With"
    Print #iFileOut, "End Sub"
    Close #iFileOut
End Function

Deep learning

Intro

I don’t know where this post will lead to (started the journey 01/21/19). The commitment is to get a Neuronal network add-in for Excel… limit time is end of 2019 (nothing bad would happen if goals could be achieved earlier). Absolutely, Excel is not the right tool to carry serious ANN -in terms of perfomance-, but, considering that all the computations can be shown in real time, and that you can mount a RAD model of every architecture, it should be considered among the better options to learn the subject from the basics. And the two final reasons where I finally arrive at: because I can do it, and because is so ubiquous that it does not limit to matematicians and IT people to play this things. If you want to make big stuff, you should consider other platforms and even other hardware… but that’s not my target and this is not your site if you have arrived here looking for other than Excel. Going to the business, from all the architectures that can be performed under the label of ANN, I’ll try to first pursue the ConvNet as they expose most of the algebra needed to perform the whole thing, so I hope it will be easier for me to adapt to other type of architectures. The final goal is to get a tool that can be good for any ANN model (considering the size limitations). This post should end fused with my previous post on Neuronal Network on Excel (task pending…).

Milestones

Expecifically I’m looking after the following goals:
  • NN activation functions (those exposed on the wikipedia article). Achieved 01/22/19
  • NN matrix algebra (multiplication, add/substraction, element-wise operations… with matrices/vectors). Half achieved, refactoring the MatLab translator module. Others should came from the JS translator.
  • NN neuron manipulation (add/delete/copy/move).
  • NN layer manipulation (add/delete/copy/move).
  • NN specific functions. Filter, Pool, stride, convolute, backpropagate,…
  • BMP/JPG import/export… someway achieved refactoring the ASCII Excel module.
As soon as each goal be achieved, then it will be converted to milestone. There’s one specific problem if this is to be done under Excel Environment… limits. For example, the >2K3 column limit of 16384 can hardly allow to show/represent more than a set of (72×72, RGB) bits in vectorized form in one worksheet. I still don’t have managed a way to overcome this limit, as I consider necessary to show the data on the cells, but surely will come to one (split neurons on different worksheets, aggregate inputs in 2D shape,…).

Other’s implementations that I can base the thing on…

Not an exhaustive list, and maybe not any usefull, but here is a recopilation of other software I’ve seen to perform NN tasks:
  • SNNS (Stuttgart Neural Network Simulator)
  • IMPLEMENTATION OF AN MS EXCEL TOOL FOR BACKPROPAGATION NEURAL NETWORK ALGORITHM IN ENVIRONMENTAL ENGINEERING EDUCATION (Selami DEMİR & others)
  • XLStat
  • deepExcel (even it’s satiric)

Bibliography

  • Andrew Ng specialization course -videos- Deeplearning.ai, on Coursera platform. Very instructive, tips are explained in a very clear form, so anyone, even with not a high level of maths, can follow. You need to know and understand algebra. Only one handicap, IMO, is that it’s focused on TensorFlow (Google) platform.
  • Jeremy Howard’s courses on fast.ai platform, online courses -also on Youtube– (and here a little trick if you’re to follow this course). To use on PyTorch, that seems to have its momentum by the end of 2018 and as a true OpenSource alternative can stay for long. Differences between them spotted here.
  • Geoffrey Hinton Machine Learning course (Collin McDonell’s youtube list). You will need a stronger math basement to follow this lessons.
  • Make Your Own Neural Network in Python book, by Tariq Rashid
  • Ian Goodfellow/Yoshua Bengio/Aaron Courville MIT book. A lot of algebra there (maybe a hard path to go if you’re to learn about NN).
  • Christopher Olah’s blog.
  • Andrej Karpathy’s blog
  • Andrew Trask’s blog
  • Emill Wallner’s blog and all the other stuff on FloydHub
  • https://pyrenn.readthedocs.io/en/latest/create.html
  • https://medium.com/@geek_kid
  • …
  • Youtube. You can drown before getting bored or quit out, so here is my ANN channel list on the topic to have all the videos I liked in the same place.

Other info

Moreover, some other projects on GitHub: On Medium there are a lot of interesting articles as well (I must confess that I personally get surprised of how people put a lot of creativity to achieve a goal that stands above most “expert” no-sayers): No Python performance on Excel?. Don’t worry, use Python in Excel and get the best of both worlds. Even on Google Sheets…

vtt to srt. Video subtittles

On the Cousera platform I downloaded the subtittles of the courses, but they only were offering the *.vtt file, which is a superset of the *.srt that MediaPlayerClassics handle for subs. I was on the need to convert all from vtt to srt, but did not want to go through all files, delete the heading and save as new file, so, here is a macro that “hardly” goes for each folder and gets the job done. 
Option Explicit
            
Function fFileLoad(ByRef strFullPathFile As String) As String()
    Dim iFile As Integer
    Dim lgLine As Long
    Dim aLine() As String
    Dim strLine As String

    iFile = VBA.FreeFile()
    Open strFullPathFile For Input Shared As #iFile
    Line Input #iFile, strLine
    Close #iFile
    'lgLine = 0
    'Do Until EOF(iFile)
        'lgLine = lgLine + 1
        'ReDim Preserve aLine(1 To lgLine)
        'aLine(lgLine) = VBA.Replace(strLine, vbLf, vbCrLf)
    'Loop
    aLine() = VBA.Split(strLine, vbLf)
    fFileLoad = aLine()
    Erase aLine()
End Function

Function fFoldersLoad(ByRef strPathBase As String) As String()
' get folders...
    Dim strPath As String
    Dim aFolder() As String
    Dim lgFolder As Long
    
    strPath = VBA.Dir(strPathBase, vbDirectory)
    lgFolder = 0
    Do
        If Not strPath Like ".*" Then
        If VBA.GetAttr(strPathBase & strPath) And vbDirectory Then
            lgFolder = lgFolder + 1
            ReDim Preserve aFolder(1 To lgFolder)
            aFolder(lgFolder) = strPathBase & strPath & "\"
        End If
        End If
        strPath = VBA.Dir
    Loop Until strPath = vbNullString

    fFoldersLoad = aFolder()
    Erase aFolder()
End Function

Function fFilesLoad(ByVal strPathBase As String, _
                    Optional ByVal strFilter As String = "*.*") As String()
' get Files...
    Dim strPath As String
    Dim aFile() As String
    Dim strFile As String
    Dim lgFile As Long
    
    strFile = VBA.Dir(strPathBase & strFilter, vbArchive)
    If strFile = vbNullString Then Exit Function
    lgFile = 0
    Do
        lgFile = lgFile + 1
        ReDim Preserve aFile(1 To lgFile)
        aFile(lgFile) = strPath & strFile
        strFile = VBA.Dir
    Loop Until strFile = vbNullString

    fFilesLoad = aFile()
    Erase aFile()
End Function

Function fVttToSrt(ByVal strFullPathFile As String) As Boolean
    Dim iFile As Integer
    Dim aLine() As String
    Dim lgLine As Long
    
    iFile = VBA.FreeFile()
    aLine() = fFileLoad(strFullPathFile)
    
    Open VBA.Replace(strFullPathFile, ".vtt", ".srt") For Output Shared As #iFile
    For lgLine = (LBound(aLine) + 2) To UBound(aLine)
        Print #iFile, aLine(lgLine)
    Next lgLine
    Close #iFile
End Function

Sub sVttToSrt()
    Dim aFile() As String
    Dim aFolder() As String
    Dim aSubFolder() As String
    Dim lgFolder As Long
    'Dim strFullPathFile As String
    Dim oFile As Variant
    Dim oFolder As Variant
    Dim oSubFolder As Variant
    Dim strPath As String
    Dim strPathBase As String
    Dim strFile As String
    Dim aLine() As String
    Dim lgLine As Long
    
    strPathBase = VBA.Environ$("UserProfile") & "\Downloads\" & "ANN\Andrew Ng_DeepLearning_Course\"
    Erase aFolder()
    aFolder() = fFoldersLoad(strPathBase)
    
    For Each oFolder In aFolder()
        strPathBase = VBA.CStr(oFolder)
        
        ' get subfolders
        Erase aSubFolder()
        aSubFolder() = fFoldersLoad(strPathBase)
        
        ' get files in root
        Erase aFile()
        aFile() = fFilesLoad(strPathBase, "*.vtt")
        If Not (Not aFile) Then
            For Each oFile In aFile()
                ' convert vtt to srt
                Call fVttToSrt(strPathBase & VBA.CStr(oFile))
            Next oFile
        End If
        
        ' go for subfolders
        If Not (Not aSubFolder) Then
            For Each oSubFolder In aSubFolder()
                strPathBase = VBA.CStr(oSubFolder)
                
                ' get files
                Erase aFile()
                aFile() = fFilesLoad(VBA.CStr(oSubFolder), "*.vtt")
                If Not (Not aFile) Then
                    For Each oFile In aFile()
                        ' convert vtt to srt
                        Call fVttToSrt(strPathBase & VBA.CStr(oFile))
                    Next oFile
                End If
            Next oSubFolder
        End If
    Next oFolder

End Sub
As mentioned, it’s not very sophisticated, but at least, finds the first subfolder structure in a folder, gets the files on the root and does the silly things to get the srt working on MPC. For a more advanced macro, that recursively gets all the folder structure, better look at this post.

Word to Excel (part 2)

In a past post I dealed with the needing of moving Word to Excel. Recently I needed to get all the tables from a bunch of Word documents inside Excel. The thing was that the Copy-PasteSpecial Format:=”Text” did not behaved as expected, as it did not paste as text but as an image. Uhm, we start to get into trouble. To get things worse, then I found that the paste operation was getting itself in problems when they mess with the screenupdating or the calculation… Excel getting into “Busy state”, so I set a “wait until Complete state” loop to solve this point. And then I realised the word tables, that came from a PDF that also came from a Word document had an caotic structure because the “translation” operations. Buf… to much to deal with (after we can get the table stuff). Here is the code that takes the tables from Word to Excel (as they come). Handy to use whenever we need Word To Excel data interchange. 
Public Sub read_word_document()
'!!!!!!!!!!!!!!!!!!!!!!!!!
    Dim DOC_PATH As String: DOC_PATH = ThisWorkbook.Path & "\"
'!!!!!!!!!!!!!!!!!!!!!!!!!
    Dim strFile As String
    Dim oXlApp As Excel.Application
    Dim oXlWbk As Excel.Workbook
    Dim oXlWbk0 As Excel.Workbook
    Dim oXlWsh As Excel.Worksheet
    Dim oXlWsh0 As Excel.Worksheet
    Dim oXlRng As Excel.Range
    Dim oXlTRow As Excel.Range
    Dim oXlTCol As Excel.Range
    Dim oXlCell As Excel.Range
    
    Dim oWdApp As Word.Application
    Dim oWdDoc As Word.Document
    Dim oWdTab As Word.Table
    Dim oWdTRow As Word.Row
    Dim oWdTCol As Word.Column
    Dim oWdCell As Word.Cell
    
    Dim lgTable As Long
    Dim bGetData As Boolean
    'Dim bSplitData As Boolean
    Dim lgR As Long
    Dim lgC As Long
    Dim strText As String
    Dim aData() As String
    Dim lgData As Long
    
'    On Error GoTo ErrHandler
    Set oWdApp = GetObject(, "Word.Application")
    'Set oWdApp = CreateObject("Word.Application")
    'oWdApp.Visible = False
    Do While oWdApp.Documents.Count > 0
        oWdApp.ActiveDocument.Close SaveChanges:=False
    Loop
    
    Set oXlApp = GetObject(, "Excel.Application")
    'Set oXlApp = CreateObject("Excel.Application")
    'oXlApp.Visible = False
    Set oXlWbk0 = oXlApp.ActiveWorkbook
     
    'lgR = 0
    strFile = VBA.Dir(DOC_PATH & "*.doc*")
    Do Until strFile = vbNullString
        Set oWdDoc = oWdApp.Documents.Open(Filename:=DOC_PATH & strFile, ReadOnly:=True)

        If oWdDoc.Tables.Count > 0 Then
            Set oXlWbk = oXlApp.Workbooks.Add() '.Open(fileName:=DOC_PATH & strFile, ReadOnly:=False)
            oXlWbk.SaveAs Filename:=DOC_PATH & VBA.Replace(strFile, ".doc", ".xls")
            
            lgR = 0
            Set oXlWsh0 = oXlWbk0.Sheets.Add
            oXlWsh0.Name = "#" & strFile
            oXlWsh0.Activate
            Set oXlRng = oXlWsh0.Range("A1")
            'oXlWsh0.Cells.ClearContents
            oXlRng.Select
            
            lgTable = 0 ' resume table
            For Each oWdTab In oWdDoc.Tables
                DoEvents

'                If vbNo = MsgBox("table " & lgTable & ", resume?", vbYesNo) Then Stop
'                On Error Resume Next
'                For Each oWdTRow In oWdTab.Rows
'                    If Err.Number = 5991 Then GoTo ExitTable
'                    If bGetData Then ' copy this data
'                        lgR = lgR + 1
'                        lgC = 0
'                        For Each oWdCell In oWdTRow.Cells
'                            lgC = lgC + 1
'                            If Not VBA.Trim$(oWdCell.Range.text) Like vbNullString Then
'                                oXlWsh.Cells(lgR, lgC).Value = oWdCell.Range.text
'                            End If
'                        Next oWdCell
'                    End If
'                Next oWdTRow
'ExitTable:
'                On Error GoTo 0
                'bSplitData = False
                lgTable = lgTable + 1
                Set oXlWsh = oXlWbk.Sheets.Add
                oXlWsh.Name = "H_" & lgTable
                oXlWsh.Activate
                Set oXlRng = oXlWsh.Range("A1")
                oXlRng.Select
                
                ' Copy table to Excel, then depurate
                oWdTab.Select
            
                On Error GoTo ErrWait
                oWdTab.Range.Copy
                oXlRng.Parent.Paste
                On Error GoTo 0
                
                'oXlRng.Parent.PasteSpecial Format:="Text", link:=False, DisplayAsIcon:=False
                Set oXlRng = oXlRng.Resize(oWdTab.Rows.Count, oWdTab.Columns.Count)
                With oXlRng
                    With .Cells
                        .UnMerge
                        .MergeCells = False
                        .WrapText = False
                        .VerticalAlignment = xlBottom
                        .Orientation = 0
                        .AddIndent = False
                        .IndentLevel = -1
                        .ShrinkToFit = False
                        .ReadingOrder = xlContext
                        
                        '.columnWidth = 14
                        '.RowHeight = 14
                        .Font.Size = 10
                        .Font.Name = "Calibri"
                    End With
                    
                    For Each oXlTRow In oXlRng.Rows
                        'bGetData = False
                        'For Each oXlCell In oXlTRow.Cells
                        '    If VBA.UCase$(oXlCell.Value) Like "*" Then
                        '        bGetData = True
                        '        Exit For
                        '    End If
                        'Next oXlCell
    
                        If bGetData Then ' copy this row
                            'bSplitData = True
                            lgR = lgR + 1
                            lgC = 0
                            For Each oXlCell In oXlTRow.Cells
                                'If Not IsEmpty(oXlCell.Value) Then
                                If Not VBA.Trim$(oXlCell.Value) Like vbNullString Then
                                    lgC = lgC + 1
                                    oXlWsh0.Cells(lgR, lgC).Value = oXlCell.Value
                                End If
                            Next oXlCell
                        End If
                    Next oXlTRow
                End With
            
                'If bSplitData Then lgR = lgR + 3
                Set oXlRng = oXlRng.Offset(oWdTab.Rows.Count + 2, 0)
            Next oWdTab
        End If
                    
        'Stop
        ' Delete all temp worksheets
        'oXlApp.DisplayAlerts = False
        'For Each oXlWsh In oXlWbk.Worksheets
        '    If oXlWsh.Name Like "H*" Then
        '        oXlWsh.Delete
        '    End If
        'Next oXlWsh
        'oXlApp.DisplayAlerts = True
        'Stop

        oWdDoc.Close SaveChanges:=False
        oXlWbk.Close SaveChanges:=False
        
        strFile = VBA.Dir
    Loop
'    oWdApp.Quit
     
    GoTo done
     
ErrWait:
'Stop
    Application.Wait ((Now + TimeValue("0:00:02")))
    Resume

ErrClose:
    On Error Resume Next
     
ErrHandler:
    Debug.Print Err.Description
    On Error GoTo 0

done:
    ' Move all worksheets that has "#" to new file
    Dim aArray As Variant
    
    lgData = -1
    Erase aData()
    For Each oXlWsh0 In oXlWbk0.Worksheets
        If oXlWsh0.Name Like "[#]*" Then
            lgData = lgData + 1
            ReDim Preserve aData(0 To lgData)
            aData(lgData) = oXlWsh0.Name
        End If
    Next oXlWsh0
    aArray = aData()
    oXlWbk0.Sheets(aArray).Move
End Sub

EXCEL VBA MULTITHREADING

This is another post I have started beeing inspired by posts on AnalystCave blog, and wanted to reach further from where he left it. There are some starting posts with info that worth to take a look before getting hands on dough: Continue reading “EXCEL VBA MULTITHREADING”

VBA FTP

Again, from AnalystCave blog, I’ve found an interesting post about how to perform download/upload via FTP protocol in VBA. We should rely on some API functions. The code presented here is 90% the same from the original post, but tidied a bit so it can be reused on a UserForm with ease. There’s only the need for 4 textboxes (userName, Password, Port, SeverHost IP address), and 2 more textboxes (linked one each to 2 listboxes/treebox) to deal with the archives both in the local drive and in the server. And buttons to Upload/Download and Cancel… and you have a clean interface to do FTP under VBA. Following are the common API functions and constants needed: 
Private Const FTP_TRANSFER_TYPE_UNKNOWN As Long = 0
Private Const INTERNET_FLAG_RELOAD As Long = &H80000000

Private Declare Function InternetOpenA Lib "wininet.dll" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Private Declare Function InternetConnectA Lib "wininet.dll" (ByVal hInternetSession As Long, ByVal sServerName As String, ByVal nServerPort As Long, ByVal sUsername As String, ByVal sPassword As String, ByVal lService As Long, ByVal lFlags As Long, ByVal lcontext As Long) As Long
Private Declare Function InternetCloseHandle Lib "wininet" (ByVal hInet As Long) As Long
Private Declare Function FtpGetFileA Lib "wininet.dll" (ByVal hConnect As Long, ByVal lpszRemoteFile As String, ByVal lpszNewFile As String, ByVal fFailIfExists As Long, ByVal dwFlagsAndAttributes As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Private Declare Function FtpPutFileA Lib "wininet.dll" (ByVal hFtpSession As Long, ByVal lpszLocalFile As String, ByVal lpszRemoteFile As String, ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean

VBA FTP Download Files

To download files via FTP protocol in VBA, use this code: 
Private Function FtpDownload(ByVal strRemoteFile As String, _
                             ByVal strLocalFile As String, _
                             ByVal strHost As String, _
                             ByVal lngPort As Long, _
                             ByVal strUser As String, _
                             ByVal strPass As String) As Boolean
' to download file from server:
    
    Dim hOpen As Long
    Dim hConn As Long
    Dim lgRetVal As Long

    hOpen = InternetOpenA("FTPGET", 1, vbNullString, vbNullString, 1)
    hConn = InternetConnectA(hOpen, strHost, lngPort, strUser, strPass, 1, 0, 2)
    
    If Not FtpGetFileA(hConn, _
                       strRemoteFile, _
                       strLocalFile, _
                       1, _
                       0, _
                       FTP_TRANSFER_TYPE_UNKNOWN Or INTERNET_FLAG_RELOAD, _
                       0) Then
        lgRetVal = VBA.MsgBox("Error while downloading file [" & strRemoteFile & "] from server", _
                              vbCritical, "W A R N I N G")
    End If

     'Close connections
    InternetCloseHandle hConn
    InternetCloseHandle hOpen
End Function
Syntax
strRemoteFile  A string path to the file on the remote FTP drive which you want to download e.g. “//home/user/text file.txt” strLocalFile  A string path to the file on the local drive which you want to save the remote file to e.g. “C:\text file.txt” strHost  A string with the FTP server name e.g. “192.168.0.100” or “myserver.domain.com”. lngPort  A number specifying the FTP port. 21 by default. strUser  A string with the FTP user name. strPass A string with the FTP user password.

Example

Now let us use the above VBA FTP Download procedure to download a file from our FTP server. 
Public Sub TestDownload()
    FtpDownload strRemoteFile:="//Download/file.txt", _
                strLocalFile:="C:\text file.txt", _
                strHost:="192.168.0.100", _
                lngPort:=21, _
                strUser:="username", _
                strPass:="password"
End Sub
VBA FTP Upload Files
To upload files from your local drive via FTP protocol in VBA, use this code: 
Private Function FtpUpload(ByVal strLocalFile As String, _
                           ByVal strRemoteFile As String, _
                           ByVal strHost As String, _
                           ByVal lngPort As Long, _
                           ByVal strUser As String, _
                           ByVal strPass As String) As Boolean
' to upload file to server:
    
    Dim hOpen As Long
    Dim hConn As Long
    Dim lgRetVal As Long

    hOpen = InternetOpenA("FTPGET", 1, vbNullString, vbNullString, 1)
    hConn = InternetConnectA(hOpen, strHost, lngPort, strUser, strPass, 1, 0, 2)

    If Not FtpPutFileA(hConn, _
                       strLocalFile, _
                       strRemoteFile, _
                       FTP_TRANSFER_TYPE_UNKNOWN Or INTERNET_FLAG_RELOAD, _
                       0) Then
        lgRetVal = VBA.MsgBox("Error while uploading file [" & strRemoteFile & "] to server", _
                              vbCritical, "W A R N I N G")
    End If

     'Close connections
    InternetCloseHandle hConn
    InternetCloseHandle hOpen
End Function

Syntax

strLocalFile  A string path to the file on the local drive which you want to upload e.g. “C:\text file.txt” strRemoteFile  A string path with the name of the upload file on the remote drive to e.g. “//home/user/text file.txt” strHost  A string with the FTP server name e.g. “192.168.0.100” or “myserver.domain.com”. lngPort  A number specifying the FTP port. 21 by default. strUser  A string with the FTP user name. strPass A string with the FTP user password.

Example

Public Sub TestUpload()
    FtpUpload strLocalFile:=VBA.Environ("UserProfile") & "\Documents\" & "file.txt", _
              strRemoteFile:="//Download/file.txt", _
              strHost:="192.168.0.100", _
              lngPort:=21, _
              strUser:="username", _
              strPass:="password"
End Sub

Download a file via VBA. Resume downloads

I’ve tried several ways to download a file, but none of them were truly convincing me, beeing the most promissing the URLDownloadToFile API function. But recently I found a post on the AnalystCave that rely on the InternetReadBinaryFile The use of this API functions got me thinking if I can control the download progress (for example, to resume a broken download, or throw it to perform on VBscript). The VBS option comes really handy, as can free Excel of the downloading process, and doesn’t require an InternetExplorer object, so it can be used also as a method to overcome ban situations and continue downloading. The lNumBytesToRead in the InternetReadBinaryFile function was very promissing, but did not manage to tame it to my requirements, so it looks like to resume a download will not be achieved via API functions. Anyway, googling a bit shows me that it could be done via XMLHTTP request (you had to tune the Range attribute… worth looking here,  here and here) There’s another option to download files described here. And following, the code that achieves the download resume: 

Private Sub ResumeDownload(ByVal strURL As String, _
                           ByVal sSaveToFile As String, _
                           Optional ByVal overWriteFile As Boolean = False, _
                           Optional ByVal lgFirstByteToRead As Long = 0, _
                           Optional ByVal lgBytesToRead As Long = 0)
    Dim oHTTP As Object
    Dim oStream As Object
    Dim sBuffer() As Byte
    Dim totalRead As Long
    
    'Const bufSize = 128
    
    Set oHTTP = CreateObject("MSXML2.ServerXMLHTTP")
    
    With oHTTP
        .Open "GET", strURL, False
        
        .setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
        .setRequestHeader "Range", VBA.CStr("bytes=" & lgFirstByteToRead & "-" & VBA.IIf(lgBytesToRead = 0, "", lgFirstByteToRead + lgBytesToRead)) ' retrieve only this bytes...
        .send ("")
        
        'wait
        Do While .Status = 200 And .readyState = 4
            DoEvents
        Loop
        
        If lgBytesToRead = 0 Then lgBytesToRead = VBA.Len(.responsetext)
        
        ReDim sBuffer(0 To lgBytesToRead - 1)
        
        Set oStream = CreateObject("ADODB.Stream")
        oStream.Open
        oStream.Type = 1
        
        'Do
        '    lgRetVal = InternetReadBinaryFile(hInternet, sBuffer(0), UBound(sBuffer) - LBound(sBuffer), lngDataReturned)
        '    If lngDataReturned = 0 Then Exit Do
        '
        '    If lngDataReturned < bufSize Then ReDim Preserve sBuffer(0 To lngDataReturned - 1)
            oStream.Write sBuffer
        '    ReDim sBuffer(0 To bufSize - 1)
        '    totalRead = totalRead + lngDataReturned
        '    'Application.StatusBar = "Downloading file. " & CLng(100 * totalRead / bufSize) & "% of " & totalRead & " KB downloaded"
        '    DoEvents
        'Loop While lngDataReturned <> 0
            
        'Application.StatusBar = "Download complete"
        oStream.SaveToFile sSaveToFile, IIf(overWriteFile, 2, 1)
        oStream.Close
    
        Dim iFileOut As Integer
        iFileOut = VBA.FreeFile()
        Open sSaveToFile For Binary As #iFileOut
        Put #iFileOut, , VBA.StrConv(.responsetext, vbFromUnicode)
        Close #iFileOut
    End With
End Sub
For the API methods, both discussed are shown here, activate the one you whish to try: 
Private Const INTERNET_FLAG_NO_CACHE_WRITE = &H4000000
Option Explicit

Private Const INTERNET_FLAG_NO_CACHE_WRITE = &H4000000
Private Const DOWNLOAD_OK As Long = 0
'Private Const E_OUTOFMEMORY As Long = &H8007000E
'Private Const INTERNET_OPEN_TYPE_PRECONFIG As Long = 0
'Private Const INTERNET_FLAG_EXISTING_CONNECT As Long = &H20000000
'Private Const INTERNET_OPEN_TYPE_DIRECT As Long = 1
'Private Const INTERNET_OPEN_TYPE_PROXY As Long = 3
'Private Const INTERNET_FLAG_RELOAD As Long = &H80000000
Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal lpszAgent As String, ByVal dwAccessType As Long, ByVal lpszProxyName As String, ByVal lpszProxyBypass As String, ByVal dwFlags As Long) As Long
Private Declare Function InternetOpenUrl Lib "wininet.dll" Alias "InternetOpenUrlA" (ByVal hInternetSession As Long, ByVal sUrl As String, ByVal sHeaders As String, ByVal lHeadersLength As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Function InternetReadBinaryFile Lib "wininet.dll" Alias "InternetReadFile" (ByVal hfile As Long, ByRef bytearray_firstelement As Byte, ByVal lNumBytesToRead As Long, ByRef lNumberOfBytesRead As Long) As Integer
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer

Sub TestDownload()
    Dim strPath As String
    strPath = VBA.Environ$("UserProfile") & "\Documents\" 'ThisWorkbook.Path
    'DownloadFile "https://analystcave.com/junk.txt", strPath & "junk.txt", True
    DownloadFile "https://www.planwallpaper.com/static/cache/76/ae/76aef16c40b4e4447233badc50b1845a.jpg", strPath & "image_https_2.jpg"
End Sub

Sub DownloadFile(ByVal sUrl As String, _
                 ByVal sSaveToFile As String, _
                 Optional ByVal overWriteFile As Boolean = False)
    Dim oStream As Object
    Dim hInternet As Long
    Dim hSession As Long
    Dim lngDataReturned As Long
    Dim sBuffer() As Byte
    Dim totalRead As Long
    Dim lgRetVal As Long
    
Stop    ' Method URLDownloadToFile
    'lgRetVal = URLDownloadToFile(0&, sUrl, sSaveToFile, 0&, 0)
    'If lgRetVal = DOWNLOAD_OK Then Exit Sub ' download completed
    
Stop    ' Method InternetReadBinaryFile
    Const bufSize = 128
    
    ReDim sBuffer(0 To bufSize - 1)
 
    hSession = InternetOpen("", 0, vbNullString, vbNullString, 0)
    If hSession Then
        hInternet = InternetOpenUrl(hSession, sUrl, vbNullString, 0, INTERNET_FLAG_NO_CACHE_WRITE, 0)
    End If
    Set oStream = CreateObject("ADODB.Stream")
    oStream.Open
    oStream.Type = 1
    
    If hInternet Then
        lngDataReturned = 0
        Do
            lgRetVal = InternetReadBinaryFile(hInternet, sBuffer(0), UBound(sBuffer) - LBound(sBuffer), lngDataReturned)
            If lngDataReturned = 0 Then Exit Do
            
            If lngDataReturned < bufSize Then ReDim Preserve sBuffer(0 To lngDataReturned - 1)
            oStream.Write sBuffer()
            ReDim sBuffer(0 To bufSize - 1)
            totalRead = totalRead + lngDataReturned
            Application.StatusBar = "Downloading file. " & CLng(100 * totalRead / bufSize) & "% of " & totalRead & " KB downloaded"
            DoEvents
        Loop While lngDataReturned <> 0
        
        Application.StatusBar = "Download complete"
        oStream.SaveToFile sSaveToFile, IIf(overWriteFile, 2, 1)
        oStream.Close
    End If
    Call InternetCloseHandle(hInternet)

    Set oStream = Nothing
End Sub
Also, dealing with downloads topic, I also liked this post.

Versioning files with VBA

I was wandering through the AnalystCave blog, and stumped on this topic. The add-in posted there was not fullfilling my requirements, so I decided to go a bit further, and then this came out: 
Public Sub sSaveNewVersion()
    MsgBox SaveNewVersion("yymmdd*###")
End Sub

Public Function SaveNewVersion(Optional ByVal strTemplate As String = "yymmdd*###") As String
' Recommended templates:
' yymmdd        991231
' hh.mm         2355
' hh.mm.ss      235545
' ###           027
' ##            27
' #             7
' yymmdd_###    991231_015
' yymmdd_hh.mm  991231_23.55
    
    Dim strFileName As String
    Dim strPath As String
    Dim strExtension As String
    Dim aNaming() As String
    Dim strMask As String
    Dim strLastVersion As String
    Dim strPrefix As String
    Dim strSuffix As String

    Dim strVersion As String
    Dim iIndex As Integer

    strPath = ActiveDocument.Path & "\"     ' ActiveWorkbook.Path
    strFileName = ActiveDocument.Name       ' ActiveWorkbook.Name
    'strFileName = "190104_this_is only a test#015.docx"
    
    aNaming() = VBA.Split(strFileName, ".")
    strExtension = aNaming(UBound(aNaming))
    
    strFileName = VBA.Mid$(strFileName, 1, VBA.Len(strFileName) - VBA.Len(strExtension) - 1)
    'iIndex = ...
    
    aNaming() = VBA.Split(strTemplate, "*")
    If LBound(aNaming) = UBound(aNaming) Then
        strPrefix = vbNullString
        strMask = fMask(aNaming(LBound(aNaming)), strSuffix)
        
        strLastVersion = VBA.Mid$(strFileName, VBA.InStrRev(strFileName, "#") + 1)
        strFileName = VBA.Mid$(strFileName, 1, VBA.Len(strFileName) - VBA.Len(strLastVersion) - 1)
        
        If strLastVersion Like strMask Then
        ' Rip off strLastVersion from strFileName
            strFileName = VBA.Mid$(strFileName, 1, InStr(1, strFileName, strLastVersion))
            If strLastVersion Like aNaming(UBound(aNaming)) Then
                ' Get index...
                strSuffix = fNewIndex(aNaming(LBound(aNaming)), VBA.CInt(strLastVersion) + 1)
            End If
        End If
    
    Else
        strMask = fMask(aNaming(LBound(aNaming)), strPrefix)
        strLastVersion = VBA.Mid$(strFileName, 1, VBA.Len(strMask))
        If strLastVersion Like strMask Then
            strFileName = VBA.Mid$(strFileName, VBA.Len(strMask) + 1 + 1)
            If strLastVersion Like aNaming(UBound(aNaming)) Then
                ' Get index...
                strPrefix = fNewIndex(aNaming(LBound(aNaming)), VBA.CInt(strLastVersion) + 1)
            End If
        End If

        strMask = fMask(aNaming(UBound(aNaming)), strSuffix)
        strLastVersion = VBA.Mid$(strFileName, VBA.InStrRev(strFileName, "#") + 1)
        
        If strLastVersion Like strMask Then
        ' Rip off strLastVersion from strFileName
            strFileName = VBA.Mid$(strFileName, 1, VBA.Len(strFileName) - VBA.Len(strLastVersion) - 1)
            If strLastVersion Like aNaming(UBound(aNaming)) Then
                ' Get index...
                strSuffix = fNewIndex(aNaming(UBound(aNaming)), VBA.CInt(strLastVersion) + 1)
            End If
        End If
    End If
    
    strFileName = strPath _
                & strPrefix _
                & "_" _
                & strFileName _
                & "#" _
                & strSuffix & _
                "." & strExtension
    
    'ActiveDocument.SaveAs strFileName ' ActiveWorkbook.SaveAs strFileName
End Function

Private Function fNewIndex(ByVal strTemplate As String, _
                           ByVal iIndex As Integer) As String
' Get new version index
    Dim strVersion As String
    
    strVersion = strTemplate
    If strVersion Like "*[#][#][#]*" Then
        strVersion = VBA.Replace(strVersion, "###", VBA.Format(iIndex, "000"))
    ElseIf strVersion Like "*[#][#]*" Then
        strVersion = VBA.Replace(strVersion, "##", VBA.Format(iIndex, "00"))
    ElseIf strVersion Like "*[#]*" Then
        strVersion = VBA.Replace(strVersion, "#", VBA.Format(iIndex, "0"))
    End If
    
    fNewIndex = strVersion
End Function

Private Function fMask(ByVal strTemplate As String, _
                       ByRef strVersion As String) As String
    Dim strMask As String
    Dim iIndex As Integer
    
    strMask = strTemplate
    strVersion = strTemplate
    If strVersion Like "*yyyy*" Then
        strVersion = VBA.Replace(strVersion, "yyyy", VBA.Format(VBA.Now(), "yyyy"))
        strMask = VBA.Replace(strMask, "yyyy", "####")
    ElseIf strVersion Like "*yy*" Then
        strVersion = VBA.Replace(strVersion, "yy", VBA.Format(VBA.Now(), "yy"))
        strMask = VBA.Replace(strMask, "yy", "##")
    End If
    If strVersion Like "*mmmm*" Then
        strVersion = VBA.Replace(strVersion, "mmmm", VBA.Format(VBA.Now(), "mmmm"))
        strMask = VBA.Replace(strMask, "mmmm", "####")
    ElseIf strVersion Like "*mmm*" Then
        strVersion = VBA.Replace(strVersion, "mmm", VBA.Format(VBA.Now(), "mmm"))
        strMask = VBA.Replace(strMask, "mmm", "###")
    ElseIf strVersion Like "*mm*" Then
        strVersion = VBA.Replace(strVersion, "mm", VBA.Format(VBA.Now(), "mm"))
        strMask = VBA.Replace(strMask, "mm", "##")
    End If
    If strVersion Like "*dd*" Then
        strVersion = VBA.Replace(strVersion, "dd", VBA.Format(VBA.Now(), "dd"))
        strMask = VBA.Replace(strMask, "dd", "##")
    ElseIf strVersion Like "*d*" Then
        strVersion = VBA.Replace(strVersion, "d", VBA.Format(VBA.Now(), "d"))
    End If
    If strVersion Like "*hh.mm*" Then
        strVersion = VBA.Replace(strVersion, "hh.mm", VBA.Format(VBA.Now(), "hh.mm"))
        strMask = VBA.Replace(strMask, "hh.mm", "##.##")
    ElseIf strVersion Like "*hh*" Then
        strVersion = VBA.Replace(strVersion, "HH", VBA.Format(VBA.Now(), "hh.mm"))
        strMask = VBA.Replace(strMask, "hh", "##")
    End If
    If strVersion Like "*ss*" Then
        strVersion = VBA.Replace(strVersion, "ss", VBA.Format(VBA.Now(), "ss"))
        strMask = VBA.Replace(strMask, "ss", "##")
    End If
    
    fMask = strMask
End Function
Hope you enjoy