Adding Stuff to the Top of a Dictionary

Posted on November 9, 2016 by Dick Kusleika

I wrote a KwikOpen addin that I use about a million times a day. I ran into a little nagging problem. When I Save As’d a file from the addin, it never showed up on the recently opened list. I finally decided to track down the bug. A while back, I switched my custom class storage method from Collection to Dictionary. I don’t remember why, but I’m sure it was a fine reason. I ended up with this Add method

Public Sub Add(clsRcntFile As CRcntFile, Optional ByVal bToTop As Boolean = False)
'    If clsRcntFile.RcntFileID = 0 Then
'        clsRcntFile.RcntFileID = Me.Count + 1
'    End If

    If Not mdcRcntFiles.Exists(clsRcntFile.FullName) Then
        mdcRcntFiles.Add clsRcntFile.FullName, clsRcntFile
    End If

    'Set clsRcntFile.Parent = Me
'    If bToTop Then
'
'        mcolRcntFiles.Add clsRcntFile, CStr(clsRcntFile.RcntFileID), 1
'    Else
'        mcolRcntFiles.Add clsRcntFile, CStr(clsRcntFile.RcntFileID)
'    End If
'
End Sub

Public Sub Add(clsRcntFile As CRcntFile, Optional ByVal bToTop As Boolean = False)

' If clsRcntFile.RcntFileID = 0 Then

' clsRcntFile.RcntFileID = Me.Count + 1

' End If

If Not mdcRcntFiles.Exists(clsRcntFile.FullName) Then

mdcRcntFiles.Add clsRcntFile.FullName, clsRcntFile

End If

'Set clsRcntFile.Parent = Me

' If bToTop Then

' mcolRcntFiles.Add clsRcntFile, CStr(clsRcntFile.RcntFileID), 1

' Else

' mcolRcntFiles.Add clsRcntFile, CStr(clsRcntFile.RcntFileID)

' End If

End Sub

I have this optional argument, bToTop, so I can add it to the front of the list. But as you can see from the commented code at the bottom, that argument is basically ignored. Dictionaries don’t allow you to insert values into specific locations and that code no longer works.

So why a bug? Because I only store the most recent 2,000 files, and I’m at that limit, any Save As’d file would become 2,001 and not written to disk. When I’d go to open a file, it would read in from the file again and, of course, that recently saved file was not there.

Surely there’s a quick and easy method for pushing something to the top. Nope. All I could find was rewriting the whole Dictionary.

Public Sub Add(clsRcntFile As CRcntFile, Optional ByVal bToTop As Boolean = False)

    Dim dcTemp As Scripting.Dictionary
    Dim i As Long

    If Not mdcRcntFiles.Exists(clsRcntFile.FullName) Then
        If bToTop Then
            Set dcTemp = New Scripting.Dictionary
            dcTemp.Add clsRcntFile.FullName, clsRcntFile
            For i = 0 To mdcRcntFiles.Count - 1
                dcTemp.Add mdcRcntFiles.Keys(i), mdcRcntFiles.Items(i)
            Next i
            Set mdcRcntFiles = dcTemp
        Else
            mdcRcntFiles.Add clsRcntFile.FullName, clsRcntFile
        End If
    End If

End Sub

Public Sub Add(clsRcntFile As CRcntFile, Optional ByVal bToTop As Boolean = False)

Dim dcTemp As Scripting.Dictionary

Dim i As Long

If Not mdcRcntFiles.Exists(clsRcntFile.FullName) Then

If bToTop Then

Set dcTemp = New Scripting.Dictionary

dcTemp.Add clsRcntFile.FullName, clsRcntFile

For i = 0 To mdcRcntFiles.Count - 1

dcTemp.Add mdcRcntFiles.Keys(i), mdcRcntFiles.Items(i)

Next i

Set mdcRcntFiles = dcTemp

Else

mdcRcntFiles.Add clsRcntFile.FullName, clsRcntFile

End If

End Sub

In that code, I create a temporary Dictionary, dcTemp, put my Save As’d file in first, then fill in the rest, finally replacing the old Dictionary with the temporary one. That’s not exactly elegant, but it gets the job done. I tested it and found that the recently saved file was not on the top of the list. It was near the top, but I inserted it first, it should be at the top. Then I remembered that I read in Excel’s MRU before I read in my file. That means there are 50 files ahead of the one I just saved. No biggie, but it gave me an idea.

Instead of recreating the Dictionary, why don’t I just add it to the MRU? There are some websites about adding entries to the registry but that won’t work. Excel reads the registry when it opens and I wasn’t about to close and reopen the app. Another way to add a file to the MRU are to specify the arguments in the Open and SaveAs methods. I am saving a file. Now my Add method looks like this

Public Sub Add(clsRcntFile As CRcntFile)
        
    If Not mdcRcntFiles.Exists(clsRcntFile.FullName) Then
        mdcRcntFiles.Add clsRcntFile.FullName, clsRcntFile
    End If
    
End Sub

Public Sub Add(clsRcntFile As CRcntFile)

If Not mdcRcntFiles.Exists(clsRcntFile.FullName) Then

mdcRcntFiles.Add clsRcntFile.FullName, clsRcntFile

End If

End Sub

The heavy lifting is done when I save the file

    Dim fd As FileDialog
    Dim clsRcntFile As CRcntFile
    Dim clsError As CError
    
    If Not gbDebug Then On Error GoTo ErrHandler
    Set clsError = New CError: clsError.SetLoc "USaveAs", "cmdOpen_Click"
    
    Set fd = Application.FileDialog(msoFileDialogSaveAs)
    
    fd.InitialFileName = Me.lbxPlaces.Value & ActiveWorkbook.Name
    
    Select Case ActiveWorkbook.FileFormat
        Case 50: fd.FilterIndex = 3
        Case 52: fd.FilterIndex = 2
        Case 56: fd.FilterIndex = 4
        Case Else: fd.FilterIndex = 1
    End Select
        
    fd.Show
    'fd.Execute
    
    If fd.SelectedItems.Count > 0 Then
        Application.DisplayAlerts = False
            ActiveWorkbook.SaveAs fd.SelectedItems(1), , , , , , , , True
        Application.DisplayAlerts = True
'        Set clsRcntFile = New CRcntFile
'        clsRcntFile.FullName = fd.SelectedItems(1)
'        Me.RcntFiles.Add clsRcntFile, True
    End If

Dim fd As FileDialog

Dim clsRcntFile As CRcntFile

Dim clsError As CError

If Not gbDebug Then On Error GoTo ErrHandler

Set clsError = New CError: clsError.SetLoc "USaveAs", "cmdOpen_Click"

Set fd = Application.FileDialog(msoFileDialogSaveAs)

fd.InitialFileName = Me.lbxPlaces.Value & ActiveWorkbook.Name

Select Case ActiveWorkbook.FileFormat

Case 50: fd.FilterIndex = 3

Case 52: fd.FilterIndex = 2

Case 56: fd.FilterIndex = 4

Case Else: fd.FilterIndex = 1

End Select

fd.Show

'fd.Execute

If fd.SelectedItems.Count > 0 Then

Application.DisplayAlerts = False

ActiveWorkbook.SaveAs fd.SelectedItems(1), , , , , , , , True

Application.DisplayAlerts = True

' Set clsRcntFile = New CRcntFile

' clsRcntFile.FullName = fd.SelectedItems(1)

' Me.RcntFiles.Add clsRcntFile, True

End If

That lone True out there is the AddToMru argument. By getting rid of the .Execute method and doing the SaveAs myself, I also got rid of a problem where overwriting an existing file caused two warning prompts. Now there’s no need for me to add it to my list (the commented out code at the bottom) because Excel adds it to its list and that’s what I read first.

KwikOpen Update

Posted on August 31, 2016 by Dick Kusleika

A year and a half ago, I decided that I was going to make a change to my KwikOpen add-in to get rid of recent files that no longer exist. Well, I finally got it done. No, it didn’t take that long to implement. The performance of the add-in has been fine so there wasn’t a pressing need. The other day, the addin seemed a little less peppy than usual and I thought it was time for a look.

I had 2,368 files in my MRU and 465 of them are dead links. That’s about 20% and it’s similar to the proportion I saw back in February 2015. Of the three options I listed at the bottom of my previous post, I chose none of them. Instead, I weeded out some files as I wrote them back out to disk.

Public Sub WriteToDisk()
    
    Dim sFile As String
    Dim lFile As Long
    Dim clsRcntFile As CRcntFile
    Dim aFiles(1 To 3000) As String
    Dim lFileCnt As Long
    Dim lWriteCnt As Long
        
    Const dWEEDLIMIT As Double = 0.9
    
    For Each clsRcntFile In Me
        lFileCnt = lFileCnt + 1
        If lFileCnt < Me.Count * dWEEDLIMIT Or clsRcntFile.Exists Then
            lWriteCnt = lWriteCnt + 1
            aFiles(lWriteCnt) = clsRcntFile.FullName
        End If
        If lWriteCnt >= UBound(aFiles) Then Exit For
    Next clsRcntFile
    
    sFile = Environ$("APPDATA") & "\Microsoft\Addins\" & msMRUFILE
    lFile = FreeFile
    
    Open sFile For Output As lFile
    Print #lFile, Join(aFiles, vbNewLine)
    Close lFile
    
End Sub

Public Sub WriteToDisk()

Dim sFile As String

Dim lFile As Long

Dim clsRcntFile As CRcntFile

Dim aFiles(1 To 3000) As String

Dim lFileCnt As Long

Dim lWriteCnt As Long

Const dWEEDLIMIT As Double = 0.9

For Each clsRcntFile In Me

lFileCnt = lFileCnt + 1

If lFileCnt < Me.Count * dWEEDLIMIT Or clsRcntFile.Exists Then

lWriteCnt = lWriteCnt + 1

aFiles(lWriteCnt) = clsRcntFile.FullName

End If

If lWriteCnt >= UBound(aFiles) Then Exit For

Next clsRcntFile

sFile = Environ$("APPDATA") & "\Microsoft\Addins\" & msMRUFILE

lFile = FreeFile

Open sFile For Output As lFile

Print #lFile, Join(aFiles, vbNewLine)

Close lFile

End Sub

The file names are written to the file with the most recent at the top – sort of. Because I’m using the built-in MRU as well as my own, it’s not exactly that way, but it’s close enough for government work. Instead of time stamping the entries, I decided to dump any nonexistent files that were near the bottom of the list. If a file is in the top 90% of the list, it stays regardless of whether it exists. If it’s in the bottom 10%, it only stays if it’s still where it was.

Iteration	Total Files	Orphaned Files
Beg.	2,368	465
1	2,250	345
2	2,226	321
3	2,225	320

Looking at the last 100 or so files, they’re mostly from 2014. I could cap this at 2,000 and probably not notice.

Searching Text Files in a Directory

Posted on August 17, 2015 by Dick Kusleika

I have several years of vendor invoices, in text file format, in some directories on a share. I need to search through these text files to find an order number, manifest number, or some other piece of information. I can’t search everything because it would take too long. And I don’t have control over the server, so if there is some indexing that could be done, I can’t do it. I’m stuck with good old VBA.

The folders are yyyymmdd (ex: 20150725 for July 25th) and corresponds to the invoice dates for any invoices in the file. Each file starts with a three letter abbreviation of the vendors name. Invoice date and vendor name are the only two pieces of information I can use to limit the search. The final piece of information is, of course, the search term. Here’s what the form looks like

I have a table of vendors and codes to populate the Vendor combobox. The QuickDate combobox populates the Date Range textboxes and contains common date ranges, namely, Last Month, This Month, Last Quarter, This Quarter, Last Year, This Year. I can change the dates to whatever I want if there isn’t a Quick Date that suits me. The Search Terms textbox takes a space separated list of terms to search for.

And now the fun part. The code. This converts the Quick Dates into real dates

Private Sub cbxQuick_Change()
    
    Dim dtStart As Date, dtEnd As Date
    
    Select Case Me.cbxQuick.Value
        Case "Last Month"
            dtStart = DateSerial(Year(Now), Month(Now) - 1, 1)
            dtEnd = DateSerial(Year(Now), Month(Now), 0)
        Case "This Month"
            dtStart = DateSerial(Year(Now), Month(Now), 1)
            dtEnd = DateSerial(Year(Now), Month(Now) + 1, 0)
        Case "Last Quarter"
            dtStart = DateSerial(Year(Now), Month(Now) - (((Month(Now) - 1) Mod 3) + 3), 1)
            dtEnd = DateSerial(Year(dtStart), Month(dtStart) + 3, 0)
        Case "This Quarter"
            dtStart = DateSerial(Year(Now), Month(Now) - (((Month(Now) - 1) Mod 3)), 1)
            dtEnd = DateSerial(Year(dtStart), Month(dtStart) + 3, 0)
        Case "Last Year"
            dtStart = DateSerial(Year(Now) - 1, 1, 1)
            dtEnd = DateSerial(Year(Now), 1, 0)
        Case "This Year"
            dtStart = DateSerial(Year(Now), 1, 1)
            dtEnd = DateSerial(Year(Now) + 1, 1, 0)
    End Select
    
    Me.tbxStartDate.Text = Format(dtStart, "mm/dd/yyyy")
    Me.tbxEndDate.Text = Format(dtEnd, "mm/dd/yyyy")
    
End Sub

Private Sub cbxQuick_Change()

Dim dtStart As Date, dtEnd As Date

Select Case Me.cbxQuick.Value

Case "Last Month"

dtStart = DateSerial(Year(Now), Month(Now) - 1, 1)

dtEnd = DateSerial(Year(Now), Month(Now), 0)

Case "This Month"

dtStart = DateSerial(Year(Now), Month(Now), 1)

dtEnd = DateSerial(Year(Now), Month(Now) + 1, 0)

Case "Last Quarter"

dtStart = DateSerial(Year(Now), Month(Now) - (((Month(Now) - 1) Mod 3) + 3), 1)

dtEnd = DateSerial(Year(dtStart), Month(dtStart) + 3, 0)

Case "This Quarter"

dtStart = DateSerial(Year(Now), Month(Now) - (((Month(Now) - 1) Mod 3)), 1)

dtEnd = DateSerial(Year(dtStart), Month(dtStart) + 3, 0)

Case "Last Year"

dtStart = DateSerial(Year(Now) - 1, 1, 1)

dtEnd = DateSerial(Year(Now), 1, 0)

Case "This Year"

dtStart = DateSerial(Year(Now), 1, 1)

dtEnd = DateSerial(Year(Now) + 1, 1, 0)

End Select

Me.tbxStartDate.Text = Format(dtStart, "mm/dd/yyyy")

Me.tbxEndDate.Text = Format(dtEnd, "mm/dd/yyyy")

End Sub

This makes sure a real date is entered, but provides for 6 or 8 digit date entry.

Private Sub tbxEndDate_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    
    If IsDate(Me.tbxEndDate.Value) Then
        tbxEndDate.Text = FormatDateTime(tbxEndDate.Value, vbShortDate)
    ElseIf Len(tbxEndDate.Text) = 6 Then
        tbxEndDate.Text = DateSerial(Right(tbxEndDate.Text, 2), Left(tbxEndDate.Text, 2), Mid(tbxEndDate.Text, 3, 2))
    ElseIf Len(tbxEndDate.Text) = 8 Then
        tbxEndDate.Text = DateSerial(Right(tbxEndDate.Text, 4), Left(tbxEndDate.Text, 2), Mid(tbxEndDate.Text, 3, 2))
    Else
        MsgBox "You must enter a valid date."
        Cancel = True
    End If

End Sub

Private Sub tbxEndDate_Exit(ByVal Cancel As MSForms.ReturnBoolean)

If IsDate(Me.tbxEndDate.Value) Then

tbxEndDate.Text = FormatDateTime(tbxEndDate.Value, vbShortDate)

ElseIf Len(tbxEndDate.Text) = 6 Then

tbxEndDate.Text = DateSerial(Right(tbxEndDate.Text, 2), Left(tbxEndDate.Text, 2), Mid(tbxEndDate.Text, 3, 2))

ElseIf Len(tbxEndDate.Text) = 8 Then

tbxEndDate.Text = DateSerial(Right(tbxEndDate.Text, 4), Left(tbxEndDate.Text, 2), Mid(tbxEndDate.Text, 3, 2))

Else

MsgBox "You must enter a valid date."

Cancel = True

End If

End Sub

And the big one, the actual search. This is pretty long and needs to be refactored, but it works for now.

Private Sub cmdSearch_Click()
    
    Dim vaTerms As Variant
    Dim i As Long, j As Long
    Dim aFolders() As String
    Dim sFolder As String, sFile As String, lFile As Long
    Dim lCnt As Long
    Dim dtFolder As Date
    Dim sText As String
    
    Const sPATH As String = "\\yourserver\rawdata\"
        
    Me.lbxResults.Clear
    
    ReDim aFolders(1 To 1000)
    sFolder = Dir(sPATH & "*", vbDirectory)
        
    'get a list of folders in the date range
    Do While Len(sFolder) > 0
        If Len(sFolder) = 8 Then
            dtFolder = DateSerial(Left$(sFolder, 4), Mid$(sFolder, 5, 2), Right$(sFolder, 2))
            If dtFolder >= CDate(Me.tbxStartDate.Text) And dtFolder <= CDate(Me.tbxEndDate.Text) Then
                lCnt = lCnt + 1
                aFolders(lCnt) = sFolder
                sFolder = Dir
            End If
        End If
        sFolder = Dir
    Loop
    
    ReDim Preserve aFolders(1 To lCnt)
        
    lCnt = 0
    vaTerms = Split(Me.tbxSearch.Text, Space(1))
    
    'Make a dummy result
    Me.lbxResults.AddItem vbNullString
    
    For i = LBound(aFolders) To UBound(aFolders)
        sFolder = sPATH & aFolders(i) & "\"
        sFile = Dir(sFolder & Me.cbxVendor.Value & "*.IN?")
                
        Do While Len(sFile) > 0
            'Show the current folder as a result
            Me.lbxResults.Column(0, 0) = sFolder & sFile
            Me.Repaint
            
            'Open the file and read in all the text
            lFile = FreeFile
            Open sPATH & aFolders(i) & "\" & sFile For Binary As lFile
                sText = Space$(LOF(lFile))
                Get #1, , sText
            Close lFile
            
            'Loop through the space separated search terms and see if
            'they're in the file
            For j = LBound(vaTerms) To UBound(vaTerms)
                If InStr(1, sText, vaTerms(j), vbTextCompare) > 0 Then
                    'This is the animation part
                    Me.lbxResults.AddItem vbNullString, 0
                    Me.lbxResults.TopIndex = 0
                    lCnt = lCnt + 1
                    DoEvents
                    Exit For
                End If
            Next j
                
            sFile = Dir
        Loop
    Next i
    
    'Get rid of the dummy
    Me.lbxResults.RemoveItem 0
    
End Sub

Private Sub cmdSearch_Click()

Dim vaTerms As Variant

Dim i As Long, j As Long

Dim aFolders() As String

Dim sFolder As String, sFile As String, lFile As Long

Dim lCnt As Long

Dim dtFolder As Date

Dim sText As String

Const sPATH As String = "\\yourserver\rawdata\"

Me.lbxResults.Clear

ReDim aFolders(1 To 1000)

sFolder = Dir(sPATH & "*", vbDirectory)

'get a list of folders in the date range

Do While Len(sFolder) > 0

If Len(sFolder) = 8 Then

dtFolder = DateSerial(Left$(sFolder, 4), Mid$(sFolder, 5, 2), Right$(sFolder, 2))

If dtFolder >= CDate(Me.tbxStartDate.Text) And dtFolder <= CDate(Me.tbxEndDate.Text) Then

lCnt = lCnt + 1

aFolders(lCnt) = sFolder

sFolder = Dir

End If

sFolder = Dir

Loop

ReDim Preserve aFolders(1 To lCnt)

lCnt = 0

vaTerms = Split(Me.tbxSearch.Text, Space(1))

'Make a dummy result

Me.lbxResults.AddItem vbNullString

For i = LBound(aFolders) To UBound(aFolders)

sFolder = sPATH & aFolders(i) & "\"

sFile = Dir(sFolder & Me.cbxVendor.Value & "*.IN?")

Do While Len(sFile) > 0

'Show the current folder as a result

Me.lbxResults.Column(0, 0) = sFolder & sFile

Me.Repaint

'Open the file and read in all the text

lFile = FreeFile

Open sPATH & aFolders(i) & "\" & sFile For Binary As lFile

sText = Space$(LOF(lFile))

Get #1, , sText

Close lFile

'Loop through the space separated search terms and see if

'they're in the file

For j = LBound(vaTerms) To UBound(vaTerms)

If InStr(1, sText, vaTerms(j), vbTextCompare) > 0 Then

'This is the animation part

Me.lbxResults.AddItem vbNullString, 0

Me.lbxResults.TopIndex = 0

lCnt = lCnt + 1

DoEvents

Exit For

End If

Next j

sFile = Dir

Loop

Next i

'Get rid of the dummy

Me.lbxResults.RemoveItem 0

End Sub

It takes about 60 seconds per month to search the files. That’s a long time so it’s necessary to entertain the user while he waits. The top entry in the results listbox is whatever the current file is. It rapidly changes the display as it loops through the folder. When there’s a hit, that file becomes the second entry and any prior hits move down. This little animation lets the user know that it’s still working and gives him a list of what hits have been found already.

You can download SearchTextFiles.zip

Document Not Saved Error on ExportAsFixedFormat

Posted on July 14, 2015 by Dick Kusleika

Recently, I was accusing ExportAsFixedFormat of causing a problem with some code. It turned out to not be the culprit. But I was suspicious because I very often get a Document Not Saved runtime error when I export to PDF in a loop. When I get that error, I can click Debug and F5, and it happily continues until it errors again. Of course, watching something loop eighty-six times to make sure it doesn’t error kind of defeats the purpose of the loop. Today, I took a stand.

I have this code that changes the page fields on a pivot table and exports a range. The result is eighty-six PDFs in a folder that I sew together into one big report. There are two page fields, so there are two loops. Here’s the inner loop.

For Each rCell In .Range(.Cells(vaRows(i), 2), .Cells(vaRows(i), 2).End(xlDown)).Cells
    pt.PivotFields("Final").CurrentPage = rCell.Value
                    
    wshDashFuelCust.Range("AK7").Resize(62, 4).ExportAsFixedFormat xlTypePDF, sPath & rCell.Value & "_" & aProducts(i)
    DoEvents
Next rCell

For Each rCell In .Range(.Cells(vaRows(i), 2), .Cells(vaRows(i), 2).End(xlDown)).Cells

pt.PivotFields("Final").CurrentPage = rCell.Value

wshDashFuelCust.Range("AK7").Resize(62, 4).ExportAsFixedFormat xlTypePDF, sPath & rCell.Value & "_" & aProducts(i)

DoEvents

Next rCell

You see my pathetic DoEvents attempt at avoiding the error. The error stops on the ExportAsFixedFormat line, so the DoEvents doesn’t actually help. When the error happens, a .tmp file is left in the directory. And when I do the Debug, F5 thing, the .tmp file stays there forever. Clearly this is a temporary file that would someday become a PDF if not for this error.

The .tmp file is my evidence that the processed finished. I can ignore the error and as long as there is no temp file, I’ll know the error never occurred. I rewrote the loop thusly:

For Each rCell In .Range(.Cells(vaRows(i), 2), .Cells(vaRows(i), 2).End(xlDown)).Cells
    pt.PivotFields("Final").CurrentPage = rCell.Value
                    
    Do
        On Error Resume Next
            Kill sPath & Dir(sPath & "*.tmp")
            wshDashFuelCust.Range("AK7").Resize(62, 4).ExportAsFixedFormat xlTypePDF, sPath & rCell.Value & "_" & aProducts(i)
        On Error GoTo 0
    Loop While Len(Dir(sPath & "*.tmp")) > 0
    
    DoEvents
Next rCell

For Each rCell In .Range(.Cells(vaRows(i), 2), .Cells(vaRows(i), 2).End(xlDown)).Cells

pt.PivotFields("Final").CurrentPage = rCell.Value

On Error Resume Next

Kill sPath & Dir(sPath & "*.tmp")

wshDashFuelCust.Range("AK7").Resize(62, 4).ExportAsFixedFormat xlTypePDF, sPath & rCell.Value & "_" & aProducts(i)

On Error GoTo 0

Loop While Len(Dir(sPath & "*.tmp")) > 0

DoEvents

Next rCell

As long as there’s a file with a tmp extension, I keep trying to export. The Kill statement needs to be inside the On Error because there won’t be anything to Kill the first time.

After a rigorous test of one time, it worked. I should have put a little loop counter in there to see how many times it errored. And maybe to exit out in case it gets into an infinite loop situation.

Weeding the KwikOpen Garden

Posted on February 11, 2015 by Dick Kusleika

A little less than a year ago, I said

Why 1,000 files? I don’t know. We’ll see how the performance holds up. I’ve been using it for three days and my text file is only up to 58 files – the 50 Excel stores plus eight additional. I guess it will take a bit longer to get to 1,000 than I thought, but I think it will be clear when there are too many and I can pare it down.

I hit 1,000 files a few days ago. Performance? Not even an issue. I upped it to 2000 and have been humming along nicely. The only downside is when I’m not on my machine and have to navigate the File Open dialog like an animal.

I know there are some files in my MRU that no longer exist. I didn’t try to delete them, I just let them stay in the list until I tried to open one and it said it didn’t exist. At the point, the code would allow me to navigate to its new location. I wanted to see how many files were no longer there.

Public Sub FindMissing()
        
    Dim clsRcntFiles As CRcntFiles
    Dim clsRcntFile As CRcntFile
    Dim lCnt As Long
    
    Set clsRcntFiles = New CRcntFiles
    clsRcntFiles.Fill
    
    For Each clsRcntFile In clsRcntFiles
        If Len(Dir(clsRcntFile.FullName)) = 0 Then
            Debug.Print clsRcntFile.FullName
            lCnt = lCnt + 1
        End If
    Next clsRcntFile
    
    Debug.Print lCnt
    
End Sub

Public Sub FindMissing()

Dim clsRcntFiles As CRcntFiles

Dim clsRcntFile As CRcntFile

Dim lCnt As Long

Set clsRcntFiles = New CRcntFiles

clsRcntFiles.Fill

For Each clsRcntFile In clsRcntFiles

If Len(Dir(clsRcntFile.FullName)) = 0 Then

Debug.Print clsRcntFile.FullName

lCnt = lCnt + 1

End If

Next clsRcntFile

Debug.Print lCnt

End Sub

This told me that it couldn’t find 234 files. That’s a lot. I really need a way to weed those files out of my MRU.

When I first wrote this code, I checked to see if the file existed before I added it to the listbox on the userform. If the file didn’t exist at that location, it didn’t get added to the listbox. If it didn’t get added to the listbox, it didn’t get written back out to the MRU. This culled the list nicely, but presented a problem pretty early on. A couple of days into using my new creation, I typed in a file name that I new I had recently opened. I didn’t remember that I moved that file to a different file. Of course, I go no results when I typed in the name even though I was certain I should have.

Once I realized why, I decided that having files disappear was not good for my psyche. It would be better to show the file, select it, then get a message that it didn’t exist. I removed the code that checked whether the file exists and didn’t implement anything that would remove files from the list short of clicking on them. Basically, I pushed that problem into the future. Well, the future is now. With 20% of my MRUs missing, I suppose it’s time to take a smarter tack.

I’m faced with a design decision. I need missing files to hang around for at least some amount of time, but not forever. Here are some choices I’ve been considering:

Time stamps: I could time stamp each entry with the “last open date”. Entries less than one month old are never deleted. Missing entries older than one month get deleted automatically. The dissonance I experienced searching for a missing file that I was sure wasn’t missing occurred because I had had that file open within the last few days. I don’t think I would have the same experience with a file that I’d opened last month. Instead, I would assume I was misremembering as opposed to being crazy. I like the fact that this happens automatically – with no user intervention. I don’t like the fact that I have to store the date. My file goes from a clean, simple list to a data structure.
Marking missing files: I could put an asterisk in front of files in the listbox that were missing. That way I would know what was missing and could click on them to clean them up, even if I didn’t intend to open them at that time. As I type this option, I hate it even more. Distracting myself with pointless housekeeping while I’m trying to get something done is a terrible idea.
Cleanup utility: I could make a separate utility that the user could periodically run. It would list the missing files and allow the user to “find” any of them that he thinks is important and remove the rest. I wouldn’t have to touch any existing code or data for this, which is a positive. It’s not automatic like the #1, which is a negative.

I’ll probably go with #1, but I haven’t decided yet.

Find Your Dropbox Folder in VBA

Posted on May 5, 2014July 20, 2018 by Dick Kusleika

Here’s a function to get the location of the Dropbox folder:

Public Function DropBox() As String
    
    Dim DropboxHostFile As String
    Dim DropboxHostFileNumber As Long
    Dim Base64EncodedPath As String
    Dim TempXMLDocument As MSXML2.DOMDocument60
    Dim Base64XMLNode As MSXML2.IXMLDOMElement
    
    DropboxHostFile = Environ("appdata") & "\Dropbox\host.db"
    DropboxHostFileNumber = FreeFile
    
    Open DropboxHostFile For Input As DropboxHostFileNumber
    Base64EncodedPath = Input$(LOF(DropboxHostFileNumber), DropboxHostFileNumber)
    Close DropboxHostFileNumber
    
    Set TempXMLDocument = New MSXML2.DOMDocument60
    Set Base64XMLNode = TempXMLDocument.createElement("b64")
    Base64XMLNode.DataType = "bin.base64"
    Base64XMLNode.Text = Split(Base64EncodedPath, vbLf)(1)
    
    DropBox = StrConv(Base64XMLNode.nodeTypedValue, vbUnicode)
    
End Function

Public Function DropBox() As String

Dim DropboxHostFile As String

Dim DropboxHostFileNumber As Long

Dim Base64EncodedPath As String

Dim TempXMLDocument As MSXML2.DOMDocument60

Dim Base64XMLNode As MSXML2.IXMLDOMElement

DropboxHostFile = Environ("appdata") & "\Dropbox\host.db"

DropboxHostFileNumber = FreeFile

Open DropboxHostFile For Input As DropboxHostFileNumber

Base64EncodedPath = Input$(LOF(DropboxHostFileNumber), DropboxHostFileNumber)

Close DropboxHostFileNumber

Set TempXMLDocument = New MSXML2.DOMDocument60

Set Base64XMLNode = TempXMLDocument.createElement("b64")

Base64XMLNode.DataType = "bin.base64"

Base64XMLNode.Text = Split(Base64EncodedPath, vbLf)(1)

DropBox = StrConv(Base64XMLNode.nodeTypedValue, vbUnicode)

End Function

According to Reinaldo there is a host.db file in the Roaming directory that stores this information. The Environ("appdata") function returns the Roaming directory in Win7. I open host.db and read in the text. Then I create a new XML document, thanks to Tim Hastings, to write in the Base64 text and read out the byte data that is converted to Unicode. There’s two lines in my host.db file, so I split on vbLf and only use the second line.

Here’s what it would look like if I wrote this function and didn’t want to poke my eyes out afterward.

Public Function DropBox() As String
    
    Dim sFile As String
    Dim lFile As Long
    Dim sPath As String
    Dim xDoc As MSXML2.DOMDocument60
    Dim xNode As MSXML2.IXMLDOMElement
    
    sFile = Environ("appdata") & "\Dropbox\host.db"
    lFile = FreeFile
    
    Open sFile For Input As lFile
    sPath = Input$(LOF(lFile), lFile)
    Close lFile
    
    Set xDoc = New MSXML2.DOMDocument60
    Set xNode = xDoc.createElement("b64")
    xNode.DataType = "bin.base64"
    xNode.Text = Split(sPath, vbLf)(1)
    
    DropBox = StrConv(xNode.nodeTypedValue, vbUnicode)
    
End Function

Public Function DropBox() As String

Dim sFile As String

Dim lFile As Long

Dim sPath As String

Dim xDoc As MSXML2.DOMDocument60

Dim xNode As MSXML2.IXMLDOMElement

sFile = Environ("appdata") & "\Dropbox\host.db"

lFile = FreeFile

Open sFile For Input As lFile

sPath = Input$(LOF(lFile), lFile)

Close lFile

Set xDoc = New MSXML2.DOMDocument60

Set xNode = xDoc.createElement("b64")

xNode.DataType = "bin.base64"

xNode.Text = Split(sPath, vbLf)(1)

DropBox = StrConv(xNode.nodeTypedValue, vbUnicode)

End Function

KwikOpen Addin

Posted on April 25, 2014March 21, 2017 by Dick Kusleika

I’ve been using this recent files userform for quite a while now and I like it. I haven’t added Eric’s comment yet (and for no good reason), but I’m going to in the next version. I don’t know if that solves the Sharepoint problem or just the ChDrive problem as neither are problems for me.

Here are my two problems:
Not enough recent files. I’m shocked – SHOCKED – at how often 50 recent files is not enough. It’s usually when I have to open a whole bunch of very similar files that I will never open again, but that clean out my recent files list. I decided to, sort of, maintain my own list. Because I use class modules *ahem* changing things to maintain my own list was pretty easy. I had to change how I fill the CRcntFiles class, but everything that consumes that class downstream just works. Here’s the new Fill method in CRnctFiles.

Public Sub Fill()
    
    Dim rf As RecentFile
    Dim clsRcntFile As CRcntFile
    Dim sFile As String, lFile As Long
    Dim vaFiles As Variant
    Dim i As Long
    
    For Each rf In Application.RecentFiles
        Set clsRcntFile = New CRcntFile
        clsRcntFile.FullName = rf.Path
        Me.Add clsRcntFile
    Next rf
    
    sFile = ThisWorkbook.Path & Application.PathSeparator & msMRUFILE
    lFile = FreeFile
    Open sFile For Input As lFile
    
    vaFiles = Split(Input$(LOF(lFile), lFile), vbNewLine)
    
    Close lFile
    
    For i = LBound(vaFiles) To UBound(vaFiles)
        If Len(vaFiles(i)) > 0 Then
            Set clsRcntFile = Nothing
            Set clsRcntFile = Me.RcntFileByFullName(vaFiles(i))
            
            If clsRcntFile Is Nothing Then
                Set clsRcntFile = New CRcntFile
                clsRcntFile.FullName = vaFiles(i)
                Me.Add clsRcntFile
            End If
        End If
    Next i
        
End Sub

Public Sub Fill()

Dim rf As RecentFile

Dim clsRcntFile As CRcntFile

Dim sFile As String, lFile As Long

Dim vaFiles As Variant

Dim i As Long

For Each rf In Application.RecentFiles

Set clsRcntFile = New CRcntFile

clsRcntFile.FullName = rf.Path

Me.Add clsRcntFile

Next rf

sFile = ThisWorkbook.Path & Application.PathSeparator & msMRUFILE

lFile = FreeFile

Open sFile For Input As lFile

vaFiles = Split(Input$(LOF(lFile), lFile), vbNewLine)

Close lFile

For i = LBound(vaFiles) To UBound(vaFiles)

If Len(vaFiles(i)) > 0 Then

Set clsRcntFile = Nothing

Set clsRcntFile = Me.RcntFileByFullName(vaFiles(i))

If clsRcntFile Is Nothing Then

Set clsRcntFile = New CRcntFile

clsRcntFile.FullName = vaFiles(i)

Me.Add clsRcntFile

End If

Next i

End Sub

First, I read in the 50 Excel most recently used files. Then I read in the 1,000 most recently used files that I store in a text file, weeding out the duplicates as I go. The advantage of continuing to use the Excel MRU is that I can leverage its pinning feature. I don’t have to write my own pinning bullshit – if you want to pin something, do it via Excel and it will always be in the MRU. Awesome.

Why 1,000 files? I don’t know. We’ll see how the performance holds up. I’ve been using it for three days and my text file is only up to 58 files – the 50 Excel stores plus eight additional. I guess it will take a bit longer to get to 1,000 than I thought, but I think it will be clear when their are too many and I can pare it down.

Next I need a way to write the files back to the text file. When the userform closes, the CRcntFiles.WriteToDisk method is called.

Public Sub WriteToDisk()
    
    Dim sFile As String
    Dim lFile As Long
    Dim clsRcntFile As CRcntFile
    Dim aFiles(1 To 1000) As String
    Dim lCnt As Long
    
    lCnt = 0
    For Each clsRcntFile In Me
        lCnt = lCnt + 1
        If lCnt > UBound(aFiles) Then Exit For
        aFiles(lCnt) = clsRcntFile.FullName
    Next clsRcntFile
    
    sFile = ThisWorkbook.Path & Application.PathSeparator & msMRUFILE
    lFile = FreeFile
    
    Open sFile For Output As lFile
    Print #lFile, Join(aFiles, vbNewLine)
    Close lFile
    
End Sub

Public Sub WriteToDisk()

Dim sFile As String

Dim lFile As Long

Dim clsRcntFile As CRcntFile

Dim aFiles(1 To 1000) As String

Dim lCnt As Long

lCnt = 0

For Each clsRcntFile In Me

lCnt = lCnt + 1

If lCnt > UBound(aFiles) Then Exit For

aFiles(lCnt) = clsRcntFile.FullName

Next clsRcntFile

sFile = ThisWorkbook.Path & Application.PathSeparator & msMRUFILE

lFile = FreeFile

Open sFile For Output As lFile

Print #lFile, Join(aFiles, vbNewLine)

Close lFile

End Sub

I lazily write 1,000 lines to the disk even if I don’t have that many. I mean efficiently, not lazily. The text file is 6KB, so I’m not losing sleep over it. I would be pretty trivial to Redim Preserve that after I’ve filled it up, so I supposed I’ll do that after the alpha test.

And other than a few minor tweaks, that’s the only changes I had to make. If that’s not a case for using class modules, I don’t know what is. My userform consumes a CRcntFiles class. It doesn’t care how that class gets filled up or where the list comes from. I could change to storing those recent files in the registry, in an XML file, or tattooed to my back. As long as I can get them into a CRcntFiles instance, the rest of the code is happy.

Save As is jealous of Open. My next problem is that while I can quickly open a recent file, I can’t quickly save a file to a recent place. This is primarily a problem when I open attachments in Outlook. It stores an opened attachment in the Temp folder and when I choose Save As, that’s the folder it starts me in. Nuts to that. If you download this add-in, you’ll also see that I’ve hooked up a SaveAs userform to Ctrl+Shift+S. It’s got a few problems too (it prompts to replace a file twice), but you can try it if you like.

You can download KwikOpen.zip

Sending Images via WinSCP

Posted on February 11, 2014February 9, 2014 by Dick Kusleika

Since my recent move to Digital Ocean for hosting, I’ve had to make a change to how I upload images for this blog. I used to create an FTP file and a batch file, but as far as I know that doesn’t support SFTP. I’m using WinSCP to transfer files manually and learned that it has a command line interface. I made a procedure called SendViaSCP to replace my SendViaFTP.

Public Sub SendViaSCP(vFname As Variant)


    Dim aScript() As String

    Dim i As Long
    ReDim aScript(1 To 4 + UBound(vFname))
    aScript(1) = "option batch abort"

    aScript(2) = "option confirm off"

    aScript(3) = "open sftp://username:password@000.000.000.000"

    aScript(UBound(aScript)) = "exit"
    For i = LBound(vFname) To UBound(vFname)

        aScript(3 + i) = "put " & Dir(vFname(i)) & " /home/wordpress/public_html/blogpix/"

    Next i
    Open "winscpup.txt" For Output As #1

    Print #1, Join(aScript, vbNewLine)

    Close #1
    Shell "winscpup.bat"

End Sub

The vFname arguments is a variant array that holds all of the files I selected from Application.GetOpenFileName. The aScript array holds three lines of setup, a line for each file, and an exit line.

The commands are joined together and written to a batch file and the batch file is run. It doesn’t solve the problem that Billkamm and Haines solved of having your username and password in a batch file, but I can live with it.

You might be wondering why I don’t just use the file upload functions in WordPress. What fun would that be?

Daily Dose of Excel

Haphazardly Posted Excel Information and Other Stuff

Category: File Operations

Adding Stuff to the Top of a Dictionary

KwikOpen Update

Searching Text Files in a Directory

Document Not Saved Error on ExportAsFixedFormat

Weeding the KwikOpen Garden

Find Your Dropbox Folder in VBA

KwikOpen Addin

Sending Images via WinSCP