Monday, 5 August 2013

VBA Modules: modAppsFirefox v3.04

NB: updated 2013-09-02 - v3 works with modProcedures

Read this for full information on these modules

Another deadly simple and endlessly useful module, lifted from Mr Excel.  Note that you can do a lot of things automatically with Firefox if you install the LastPass addon, which stores your site login information and automatically logs in to a site.  This means you can easily download a remote file from a web server somewhere just by opening the URL for the file using ff_GetDownload.  I don't think it's usually necessary to log in to the site first, LastPass will handle that, but it certainly doesn't do any harm, it just opens an extra FF tab.

When downloading a file, Firefox will save the actual filename.ext with 0 bytes as a placeholder, and create filename.ext.part which is the actual downloading file.  When FF completes the download, it'll delete the original filename.ext file, and rename the filename.ext.part file to filename.ext.  So when it's completed the download, filename.ext will instantly be > 0 bytes.

Code for Sleep:
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliSeconds As Long)

Private Const fwLoginURL As String = ""  'can be set to any site login

Public Sub Sleep_Test()
  Sleep 3000
  MsgBox "Hello"
End Sub

This uses code from modSpecialFolders to find the location of the user's Downloads folder but you can also hard-code the path if preferred.

I've never managed to get Internet Explorer to work in the same way, (un)surprisingly Microsoft just don't make it easy.  There's plenty of support online if you really must use IE, e.g. if your corporate policy doesn't permit LastPass for automatic logins.

'v3.04 2013-09-20 13:32

' Code is provided without warranty and can be stolen and amended as required.
'   Tom Parish
'   DGF Help Contact: see BPMHelpContact module

' modAppsFirefox
'   macros to load URL in Firefox, based on open source code:
'   Automatically determines standard Windows 7 Downloads folder location.
'   Specify custom Downloads folder location as Private Const below.
'   Save your site login details with the LastPass addon, and make sure it's
'   set to always autologin to the site.

' Additional modules required:
'   modFile v1.03
'   Code included from other modules:
'      [modSpecialFolders]

' Additional References required:
'   None

' External applications required:
'   Mozilla Firefox
'   LastPass Firefox Addon

'   v3.04   minor edit, variable name change in modFile
'   v3.03   ffGetSimultDownloads counts .part files in DLs folder
'   v3.02   always wait for completion if running outside office hours
'   v3.01   ffGetDownload = ffFileURL for queued downloads when max dl reached
'   v3.00   works with modProcedures
'   v2.01   ff_GetDownload: added ffLoginTime and improved ffSleepTime usage
'                           added ErrorHandlerNoFile
'   v2.00   transferred code from modSpecialFolders
'   v1.06   ff_GetDownload: bugfix, potentially .part file is newer
'   v1.05   ff_GetDownload: redesigned download completion detection
'           extended ffSleepTime
'           improved annotations
'   v1.04   added Private Const ffSleepTime
'   v1.03   ff_GetDownload: only waits for site login if necessary
'   v1.02   transferred ff_GetDownload from modForwin (was Forwin_GetDownload)
'   v1.01aa renamed modAppsFirefox
'   v1.01a  annotations only
'   v1.01   refers modSpecialFolders
'   v1.00   original code from source:

Option Explicit

Private Const ffSpecifyDownloadFolder As String = ""
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliSeconds As Long)

Private Const ffLoginTime As Long = 20000  'v2.01, 10s is too short to allow login and file transfer to begin
'!! if 1000ms causes issues, try a longer time
Private Const ffSleepTime As Long = 1000  'v1.05, ms, i.e. 10000ms = 10s

'NB: Firefox can only run N simultaneous downloads, must store further URLs as Download procedures
'!! may need to improve this by clearing completed downloads?  (i.e. run modProcedures.mp_Run_Procedures on sheets 1 and 2)
Public Const ffMaxSimultDownloads As Byte = 5       'v3.03 'v3.01
Private Const ffDownloadWaitTime As Long = 60000    'v3.01 - only if ffWaitForCompletion = True

Private Const ffOffHrsMin As Byte = 9     'ALWAYS waits if Now < this
Private Const ffOffHrsMax As Byte = 18    'ALWAYS waits if Now > this
Private Const ffWEDay1 As String = "Sat"  'ALWAYS waits if running on Sat
Private Const ffWEDay2 As String = "Sun"  'change to Mon or "" as applicable to your country

Public ffCompleted As Boolean  'v3.00


'   Code from modSpecialFolders module:

Private Declare Function SHGetSpecialFolderLocation _
                         Lib "shell32" (ByVal hwnd As Long, _
                                        ByVal nFolder As Long, ppidl As Long) As Long

Private Declare Function SHGetPathFromIDList _
                         Lib "shell32" Alias "SHGetPathFromIDListA" _
                             (ByVal Pidl As Long, ByVal pszPath As String) As Long

Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal pvoid As Long)

Private Const CSIDL_INTERNET = &H1 'Internet Explorer (icon on desktop)
Private Const CSIDL_PROGRAMS = &H2 'Start Menu\Programs
Private Const CSIDL_CONTROLS = &H3 'My Computer\Control Panel
Private Const CSIDL_PRINTERS = &H4 'My Computer\Printers
Private Const CSIDL_PERSONAL = &H5 'My Documents
Private Const CSIDL_FAVORITES = &H6 '<user name>\Favorites
Private Const CSIDL_STARTUP = &H7 'Start Menu\Programs\Startup
Private Const CSIDL_RECENT = &H8 '<user name>\Recent
Private Const CSIDL_SENDTO = &H9 '<user name>\SendTo
Private Const CSIDL_BITBUCKET = &HA '<desktop>\Recycle Bin
Private Const CSIDL_STARTMENU = &HB '<user name>\Start Menu
Private Const CSIDL_DESKTOPDIRECTORY = &H10 '<user name>\Desktop
Private Const CSIDL_DRIVES = &H11 'My Computer
Private Const CSIDL_NETWORK = &H12 'Network Neighborhood
Private Const CSIDL_NETHOOD = &H13 '<user name>\nethood
Private Const CSIDL_FONTS = &H14 'Windows\fonts
Private Const CSIDL_TEMPLATES = &H15
Private Const CSIDL_COMMON_STARTMENU = &H16 'All Users\Start Menu
Private Const CSIDL_COMMON_PROGRAMS = &H17 'All Users\Programs
Private Const CSIDL_COMMON_STARTUP = &H18 'All Users\Startup
Private Const CSIDL_COMMON_DESKTOPDIRECTORY = &H19 'All Users\Desktop
Private Const CSIDL_APPDATA = &H1A '<user name>\Application Data
Private Const CSIDL_PRINTHOOD = &H1B '<user name>\PrintHood
Private Const CSIDL_LOCAL_APPDATA = &H1C '<user name>\Local Settings\Application Data (non roaming)
Private Const CSIDL_ALTSTARTUP = &H1D 'non localized startup
Private Const CSIDL_COMMON_ALTSTARTUP = &H1E 'non localized common startup
Private Const CSIDL_COOKIES = &H21
Private Const CSIDL_HISTORY = &H22
Private Const CSIDL_COMMON_APPDATA = &H23 'All Users\Application Data
Private Const CSIDL_WINDOWS = &H24 'Windows Directory
Private Const CSIDL_SYSTEM = &H25 'System Directory
Private Const CSIDL_PROGRAM_FILES = &H26 'C:\Program Files
Private Const CSIDL_MYPICTURES = &H27 'C:\Program Files\My Pictures
Private Const CSIDL_SYSTEMX86 = &H29 'x86 system directory on RISC
Private Const CSIDL_PROGRAM_FILESX86 = &H2A 'x86 C:\Program Files on RISC
Private Const CSIDL_PROGRAM_FILES_COMMON = &H2B 'C:\Program Files\Common
Private Const CSIDL_PROGRAM_FILES_COMMONX86 = &H2C 'x86 Program Files\Common on RISC
Private Const CSIDL_COMMON_TEMPLATES = &H2D 'All Users\Templates
Private Const CSIDL_COMMON_DOCUMENTS = &H2E 'All Users\Documents
Private Const CSIDL_COMMON_ADMINTOOLS = &H2F 'All Users\Start Menu\Programs\Administrative Tools
Private Const CSIDL_ADMINTOOLS = &H30 '<user name>\Start Menu\Programs\Administrative Tools
Private Const CSIDL_CONNECTIONS = &H31 'Network and Dial-up Connections
Private Const MAX_PATH = 260
Private Const NOERROR = 0

Private Function SpecFolder(ByVal lngFolder As Long) As String
Dim lngPidlFound As Long
Dim lngFolderFound As Long
Dim lngPidl As Long
Dim strPath As String

strPath = Space(MAX_PATH)
lngPidlFound = SHGetSpecialFolderLocation(0, lngFolder, lngPidl)
If lngPidlFound = NOERROR Then
    lngFolderFound = SHGetPathFromIDList(lngPidl, strPath)
    If lngFolderFound Then
        SpecFolder = Left$(strPath, _
                           InStr(1, strPath, vbNullChar) - 1)
    End If
End If
CoTaskMemFree lngPidl
End Function

Sub Test_OpenFireFoxNewTab()
  OpenInFireFoxNewTab ""
End Sub

Sub OpenInFireFoxNewTab(url As String)
'v2.00 2013-08-09 11:59
  Dim pathFireFox As String
  pathFireFox = SpecFolder(CSIDL_PROGRAM_FILES) & "\Mozilla Firefox\firefox.exe" 'v1.01
  If Dir(pathFireFox) = "" Then pathFireFox = "C:\Program Files (x86)\Mozilla Firefox\firefox.exe"
  If Dir(pathFireFox) = "" Then pathFireFox = "C:\Program Files\Mozilla Firefox\firefox.exe"
  If Dir(pathFireFox) = "" Then
    MsgBox "FireFox Path Not Found", vbCritical, "Macro Ending"
    Exit Sub
  End If
  Shell """" & pathFireFox & """" & " -new-tab " & url, vbHide
End Sub

Function ff_GetDownload(ByVal ffFileURL As String, ByVal ffFileExt As String _
    , Optional ByVal ffNewFileName As String, Optional ByVal ffWaitForCompletion As Boolean) As String
'v3.04 2013-09-20 13:32
'launches FireFox, logs in to web server, downloads Filename.FileExt
'then renames to specified [ffNewFileName] OR [cDefaultFilename].[ffFileExt]
'reports back new path & filename (NB: default is [userpath]\Downloads\[cDefaultFilename].[ffFileExt])
'v3.00 can report back temporary filename for use with modProcedures

ffCompleted = False  'v3.00

Const ffLoginURL As String = ""  'optional, forces login before launching actual URL
Dim sCount As Byte  'counts and limits number of sleeps

On Error Resume Next  'validity checks done at end

If ffGetCurrentSimultDownloads < ffMaxSimultDownloads Then  'v3.01
    'download this file
    'launch web server in FF (automatic login is handled with LastPass addon)
        If ffLoginURL <> "" Then
            modAppsFirefox.OpenInFireFoxNewTab ffLoginURL
        'wait for LastPass to log in
            Sleep ffLoginTime
        End If
    'launch URL to download (FF will automatically download files to user's specified Downloads folder)
    Dim dCreatedDate As Double
        dCreatedDate = Now()  'records date & time file creation was started, prevents false "newset file" matches
        modAppsFirefox.OpenInFireFoxNewTab ffFileURL
    'minimum pause for LastPass to log in to site, and file transfer to begin
    '!! take care: if this causes the wrong file to be detected, increase ffLoginTime
        Sleep ffLoginTime
    'get file name for NEWEST file in Downloads folder
    'Firefox creates file.ext.part AND file.ext
        Dim pthDL As String, ffDownloadingFile As String
        pthDL = ffSpecifyDownloadFolder  'can specify path as Private Const
        If pthDL = "" Then pthDL = Replace(SpecFolder(CSIDL_PERSONAL), "\Documents", "\Downloads\") 'also adds trailing slash
        ffDownloadingFile = modFile.mfLoopThroughFilesInAFolder(mfPath:=pthDL, mfNewestFile:=True, mfNewestFileNewerThan:=dCreatedDate)  'v3.04
        If ffDownloadingFile = "" Then
        'newest file not found, wait then try again
            sCount = sCount + 1
            Sleep ffSleepTime
            If sCount < 10 Then GoTo FindNewestFile  'prevent endless loop
        End If
        If ffDownloadingFile = "" Then GoTo ErrorHandlerNoFile
        ffDownloadingFile = Replace(ffDownloadingFile, ".part", "")  'catch potential errors due to .part file being newer
    'whilst downloading, file.ext placeholder will exist with 0 bytes, file.ext.part is temporary downloading file
    'on completion, file.ext wil be deleted, then file.ext.part will be renamed, so file.ext will be >0 bytes
    'v3.02 regardless of user setting, always wait for completion if running outside office hours
    If ffWaitForCompletion = True _
    Or Hour(Now()) < ffOffHrsMin _
    Or Hour(Now()) >= ffOffHrsMax _
    Or Format(Now(), "Ddd") = ffWEDay1 _
    Or Format(Now(), "Ddd") = ffWEDay2 _
        Dim f1 As Double
    On Error Resume Next
        f1 = FileLen(ffDownloadingFile)
        Do While f1 = 0
        'when download completes, ffDownloadingFile is deleted (i.e. error) then reappears with f1 > 0
            f1 = FileLen(ffDownloadingFile)
    On Error GoTo 0
        ffCompleted = True
    'rename downloaded file if specified
    'NB: renaming .csv to .xls will cause you problems!
        If ffNewFileName <> "" Then
        'use specified filename
            ff_GetDownload = ffNewFileName
        'use default download filename
            Const cDefaultFilename As String = "Downloaded Web Server Report."  ' & ffFileExt
            Const cPrd As String = "."
            ffFileExt = Replace(LCase(ffFileExt), cPrd, "")
            ff_GetDownload = cDefaultFilename & ffFileExt
        End If
    'before renaming download file, kill target filename, if it exists
        If Dir(ff_GetDownload) <> "" Then Kill ff_GetDownload
    'rename/move downloaded file
        Name ffDownloadingFile As ff_GetDownload
    'validity check to confirm download completed
        If Dir(ff_GetDownload) = "" Then
        'downloaded file doesn't exist, something went wrong
            MsgBox "Downloaded file not found", vbCritical, "Error in ff_GetDownload"
            GoTo ErrorHandlerNoFile
        End If
    Else  'ffWaitForCompletion = False AND during business hours
    'don't wait, store the first N download procedures for processing later
    'NB: capture this in parent macro
        ff_GetDownload = ffDownloadingFile
    'NB: ff_GetDownload <> ffNewFileName
    End If

'too many simultaneous downloads already, store this download URL for later
'NB: must capture this in parent macro
    ff_GetDownload = ffFileURL

End If

On Error GoTo 0
Exit Function

ff_GetDownload = ""
End Function

Function ffGetCurrentSimultDownloads() As Byte
'v3.03 2013-09-13 11:05
'counts .part files in Downloads folder
'Firefox can only run ffMaxSimultDownloads

Dim pthDL As String
Const ffDLpartfile As String = ".part"
pthDL = ffSpecifyDownloadFolder  'can specify path as Private Const
If pthDL = "" Then pthDL = Replace(SpecFolder(CSIDL_PERSONAL), "\Documents", "\Downloads\") 'also adds trailing slash
ffGetCurrentSimultDownloads = modFile.mfLoopThroughFilesInAFolder(mfPath:=pthDL _
    , mfSearchString:=ffDLpartfile, mfCountMatches:=True)

End Function

No comments:

Post a Comment