tag:blogger.com,1999:blog-18005184230979198892024-02-07T21:54:07.574+00:00ExcellerandoA programmer's scrapbook devoted to Microsoft Excel and its embedded language, Visual Basic for Applications.Nigel Heffernanhttp://www.blogger.com/profile/08954578765691578714noreply@blogger.comBlogger28125tag:blogger.com,1999:blog-1800518423097919889.post-52656814883742341062015-07-03T11:20:00.000+01:002015-08-20T12:19:33.616+01:00A Fishy Tale of Report Support
<BR />
Not, strictly speaking, an Excel post at all: but I thought I'd share this with you anyway.
<BR /><BR />
From time to time, I have to cover the support work on a large reporting system which serves Excel files out through a web portal. We're running something between five hundred and a thousand distinct reports.
<BR /><BR />
Here's an edited - heavily redacted! - transcript of a typical support call, with the details changed to protect commercial confidentiality, and the fundamental concepts entirely unaltered:
<BR />
<PRE><BR />
Fish: "Hi, Aquarium Support Desk?"
Support: "Hello, this is the Aquarium Support Desk, can I help you?"
Fish: "It's the water"
Support: "There's something wrong with your water?"
Fish: "Yes, there's something wrong with the water: can you help?"<BR />
Support: * Thinks * I could ask what's wrong with the water, again...
Support: ...But it's going to be quicker to get the testing kit and go there myself<BR />
Support: "Which tank are you in?"
Fish: "Yes, I have a problem with the water"
Support: "I need to run some tests, can you tell me which tank has a problem with the water"
Fish: "Thanks, how long will it take you to fix this?"
Support: "I don't know which one of the 450 tanks of water in this building has a problem, and I need to know which tank to test"
Fish: "It's a problem with the water, can you tell me how long it'll be?"
Support: "Are there any identifying marks on your tank?"
</PRE>
<BR />
There's no 'punchline'... So lets stop right there, and nail the mistake before the repetition gets tedious.
<BR /><BR />
<B>The Fish has no concept for 'Tank' and the support technician doesn't realise that nothing AT ALL is communicated in any question or statement centred on 'tank' and 'location'. </B>
<BR /><BR />
Maybe if Support used the word 'Aquarium', they'd get a response; and maybe not - some people have a distinct vocabulary for their work, and the concepts embedded in their work can only be communicated in that exact language (Oracle administrators are the most extreme example) - but it's entirely possible that the fish has NO vocabulary for, and no concept of, a distinct body of water with a boundary container.
<BR /><BR />
That's not to say the fish is stupid - I'd like to see how long *you* would last on a tropical reef, and your attempts at breathing when immersed in water are, quite frankly, embarrassing - and anyway, the problem was never going to be solved by being 'smarter' than the fish.
<BR /><BR />
The problem is going to be solved by being smarter than a support technician who doesn't see that that a gap in communication isn't going to be fixed by throwing more questions down the the same hole: asking for more details about the tank won't work, no matter how many questions you ask, if 'Tank' is a concept you can't communicate at all.
<BR /><BR />
So here's the 'fix': ask a question centred on a concept the user will understand, with answers that will 'leak' location information:
<PRE><BR />
Support: * Mutters, almost as if he or she doesn't want to be heard *
Support: "It's the 4%@#ing octopus again"
Support: * Asks, clearly and politely: *
Support: "Is there an octopus in the tank adjacent to yours?"
Fish: "There's a Pacific blue-ringed female so sunward..."
Fish: "And a tuberculate pelagic octopus next to the source of vibration I complained about last week"<BR />
Support: "Tank 224. I'll be right over with the testing kit"
</PRE>
<BR />
Something else for you to ponder: the 'user experience' here is that Support asked no end of irrelevant questions that elucidated nothing except their own cluelessness, and they took their own sweet time to get to work on the problem.
<BR /><BR />
And the first thing the user will see is support faffing around with a testing kit, when they've already been told, repeatedly, that there's something wrong with the water.
<BR /><BR />
Support isn't a technical skill, it's about communication and manipulation. And if you are wondering how this fishy tale is relevant: <B>more than half the time expended by support technicians in speaking to the users consists of failed attempts to identify the specific report that the user needed fixing.</B>.
<BR /><BR />
So anyone who builds reports - or Excel applications - and releases them for widespread use needs to be labelling-up *every* sheet with the app or report name, and filling in a 'Settings' or 'about this report' or 'documentation' sheet that the user can be guided to by first-line support. Or by you.
<BR /><BR />
<H3>And the moral is:</H3>
The most important piece of information that your application, worksheet, or report can communicate to a support technician is an unambiguous identifying name; and, better still, a location.
<BR />
<BR />
<BR />
Meanwhile, I will buy you beer if you can bring a toxic blue-ringed octopus into today's technical explanations to the users.
<BR />
<BR />
<BR />
Nigel Heffernanhttp://www.blogger.com/profile/08954578765691578714noreply@blogger.com0tag:blogger.com,1999:blog-1800518423097919889.post-1989316483595866952015-01-25T19:05:00.000+00:002015-01-23T19:26:20.736+00:00Trusted Locations: a source of misleading error messages<BR />
When's the last time you ran some VBA that opened a spreadsheet over the network? Or even on your own local temp folder?
<BR /><BR />
If you're working in Office 2010 or 2013, you might just have seen this error message:
<BR /><BR />
<H3>Office has detected a problem with this file. To help protect your computer this file cannot be opened.</H3>
<BR /><BR />
...But you open the file yourself, manually, and it's fine. Readable, no error messages on open, maybe contains VBA macros and COM controls and you get a warning message, but not corrupted or obviously malicious.
<BR /><BR />
You *might* see a message about content disabled, or the 'Trust Centre'.
<BR /><BR />
What's actually happened is that the 'Trust Centre' ('Trust Center' in American English) needs a manual intervention to add the folder containing your file, and to label it as a safe location.
<BR /><BR />
Microsoft have published instructions on doing this here:
<BR /><BR />
<A HREF="https://support.office.com/en-au/article/Add-remove-or-change-a-trusted-location-7ee1cdc2-483e-4cbb-bcb3-4e7c67147fb4">Support.Office.com: Add, remove, or change a trusted location</A>
<BR /><BR />
That's great if it's just you, but unhelpful if you write applications that open Excel files. But, before I show you the VBA to automate away that annoyance, here's a short code snippet for opening Excel files safely in a separate 'sanitised' instance of Excel.exe:
<BR />
<CODE Lang="VB"><PRE>
<BR />
Application.ShowStartupDialog = False
With New Excel.Application
On Error Resume Next
.ShowStartupDialog = False
.Visible = False
.EnableCancelKey = xlDisabled
.UserControl = False
.Interactive = False
.EnableEvents = False
'If .Calculation <> xlCalculationManual Then
' .Calculation = xlCalculationManual
'End If
'.CalculateBeforeSave = False
.DisplayAlerts = False
.AutomationSecurity = msoAutomationSecurityForceDisable
On Error Resume Next
For i = 1 To .AddIns.Count
If .AddIns(i).IsOpen Then
.AddIns(i).Installed = False
End If
Next i
For i = 1 To .COMAddIns.Count
.COMAddIns(i).Connect = False
If Not .COMAddIns(i).Object Is Nothing Then
.COMAddIns(i).Object.Close
.COMAddIns(i).Object.Quit
End If
Next i
On Error GoTo ErrAppExit
.Workbooks.Open FileName = strFile, _
UpdateLinks:=False, _
ReadOnly:=True, _
Password:=vbNullString, _
Notify:=False, _
AddToMRU:=False
' **** Your code to work on the file goes here ****
' **** Set all objects to Nothing before exiting ****
For i = .Workbooks.Count To 1 Step -1
.Workbooks(i).Close
Next i
ErrAppExit:
On Error Resume Next
If Err.Number > 0 Then
StatusMessage = "#ERROR " & Err.Number & ": " & Err.Description & sError
End If
.Quit
End With 'New Excel.Application
<BR />
</PRE></CODE>
<BR />
The Trust Centre is annoying, but you might want to take *some* precautions when opening files from a bad neighborhood. Especially if others will use your VBA code to open files from places you never heard of.
<BR /><BR />
Whatever. Here's the code to set a trusted location which I posted in StackOverflow a couple of days ago:
<BR /><BR />
<H2>TrustThisFolder(): Excel VBA Code to Add a Folder to the 'Trusted Folders' Registry List.</H2>
<BR /><BR />
<CODE Lang="VB"><PRE>
<BR />
Private Sub TrustThisFolder(Optional FolderPath As String, _
Optional TrustSubfolders As Boolean = True, _
Optional TrustNetworkFolders As Boolean = False, _
Optional sDescription As String)
' Add a folder to the 'Trusted Locations' list so that your project's VBA can
' open Excel files without raising errors like "Office has detected a problem
' with this file. To help protect your computer this file cannot be opened."
' Ths function has been implemented to fail silently on error: if you suspect
' that users don't have permission to assign 'Trusted Location' status in all
' locations, reformulate this as a function returning True or False
' Nigel Heffernan January 2015 http:\\Excellerando.blogspot.com
'
' Based on code published by Daniel Pineault in DevHut.net on June 23, 2010:
' www.devhut.net\2010\06\23\vbscript-createset-trusted-location-using-vbscript\
' **** **** **** **** THIS CODE IS IN THE PUBLIC DOMAIN **** **** **** ****
' UNIT TESTING:
'
' 1: Reinstate the commented-out line 'Debug.Print sSubKey & vbTab & sPath
' 2: Open the Immediate Window and run this command:
' TrustThisFolder "Z:\", True, True, "The user's home directory"
' 3: If "Z:\" is already in the list, choose another folder
' 4: Repeat step 2 or 3: the folder should be listed in the debug output
' 5: If it isn't listed, disable the error-handler and record any errors
'
On Error GoTo ErrSub
Dim sKeyPath As String
Dim oRegistry As Object
Dim sSubKey As String
Dim oSubKeys ' type not specified. After it's populated, it can be iterated
Dim oSubKey ' type not specified.
Dim bSubFolders As Boolean
Dim bNetworkLocation As Boolean
Dim iTrustNetwork As Long
Dim sPath As String
Dim sDate As String
Dim sDesc As String
Dim i As Long
Const HKEY_CURRENT_USER = &H80000001
bSubFolders = True
bNetworkLocation = False
If FolderPath = "" Then
FolderPath = FSO.GetSpecialFolder(2).Path
If sDescription = "" Then
sDescription = "The user's local temp folder"
End If
End If
If Right(FolderPath, 1) <> "\" Then
FolderPath = FolderPath & "\"
End If
sKeyPath = ""
sKeyPath = sKeyPath & "SOFTWARE\Microsoft\Office\"
sKeyPath = sKeyPath & Application.Version
sKeyPath = sKeyPath & "\Excel\Security\Trusted Locations\"
Set oRegistry = GetObject("winmgmts:\\.\root\default:StdRegProv")
' Note: not the usual \root\cimv2 for WMI scripting: the StdRegProv isn't in that folder
oRegistry.EnumKey HKEY_CURRENT_USER, sKeyPath, oSubKeys
For Each oSubKey In oSubKeys
sSubKey = CStr(oSubKey)
oRegistry.GetStringValue HKEY_CURRENT_USER, sKeyPath & "\" & sSubKey, "Path", sPath
'Debug.Print sSubKey & vbTab & sPath
If sPath = FolderPath Then
Exit For
End If
Next oSubKey
If sPath <> FolderPath Then
If IsNumeric(Replace(sSubKey, "Location", "")) Then
i = CLng(Replace(sSubKey, "Location", "")) + 1
Else
i = UBound(oSubKeys) + 1
End If
sSubKey = "Location" & CStr(i)
If TrustNetworkFolders Then
iTrustNetwork = 1
oRegistry.GetDWORDValue HKEY_CURRENT_USER, sKeyPath, "AllowNetworkLocations", iTrustNetwork
If iTrustNetwork = 0 Then
oRegistry.SetDWORDValue HKEY_CURRENT_USER, sKeyPath, "AllowNetworkLocations", 1
End If
End If
oRegistry.CreateKey HKEY_CURRENT_USER, sKeyPath & "\" & sSubKey
oRegistry.SetStringValue HKEY_CURRENT_USER, sKeyPath & "\" & sSubKey, "Path", FolderPath
oRegistry.SetStringValue HKEY_CURRENT_USER, sKeyPath & "\" & sSubKey, "Description", sDescription
oRegistry.SetDWORDValue HKEY_CURRENT_USER, sKeyPath & "\" & sSubKey, "AllowSubFolders", 1
End If
ExitSub:
Set oRegistry = Nothing
Exit Sub
ErrSub:
Resume ExitSub
End Sub
<BR />
</PRE></CODE>
<BR />
You will note that I acknowledge the original author, Daniel Pineault, who posted this code on DevHut.net in 2010: <a href="http://www.devhut.net\2010\06\23\vbscript-createset-trusted-location-using-vbscript\">VB Script to set a Trusted Location</a>
<BR /><BR />
This code has been widely-reposted without attribution: please don't do that, it's discourteous - if you, too, aspire to being recognised as an 'expert', this can only happen if you're working in a culture that acknowledges expertise; and you, and your courtesy to others, *are* that culture.
<BR /><BR />
<BR /><BR />
Nigel Heffernanhttp://www.blogger.com/profile/08954578765691578714noreply@blogger.com0tag:blogger.com,1999:blog-1800518423097919889.post-10301602524189591762015-01-18T19:25:00.000+00:002015-01-22T19:30:47.048+00:00Asterisk the Galling: Using The VBA InputBox() For Passwords
<H3>Using the VBA InputBox for passwords and hiding the user's keyboard input with asterisks.</H3>
<BR />
<BR />
This is another horrible hack, born from a requirement to stop storing Excel sheet and workbook passwords in the worksheets themselves, in the interests of security.
<BR />
<BR />
Experienced Excel developers, power users, IT security experts, and preserved rat brains floating in jars of formaldehyde might *just* be capable of reasoning-out one or two minor inconsistencies lurking in the logic of that statement.
<BR />
<BR />
However, I've still got to do it. And I can either create a VBA form and hope that the 'Password Chars' method exposed by some (but not all) textbox controls is reliable and secure, and can't be switched off by clever but misguided users; or just type the password into a standard VBA.Interaction InputBox() function.
<BR />
<BR />
Unfortunately, the InputBox function doesn't have a 'PasswordChars' option. So here's the simple and straightforward VBA code to do that, with the necessary API functions declared for both 64- and 32-bit environments:
<BR />
<CODE LANG="VB">
<PRE>
<BR />
Option Explicit
#If VBA7 And Win64 Then ' 64 bit Excel under 64-bit windows ' Use LongLong and LongPtr
Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
(ByVal hWnd1 As LongPtr, _
ByVal hWnd2 As LongPtr, _
ByVal lpsz1 As String, _
ByVal lpsz2 As String _
) As LongPtr
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As LongPtr, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByRef lParam As Any _
) As LongPtr
Private Declare PtrSafe Function SetTimer Lib "user32" _
(ByVal hwnd As LongPtr, _
ByVal nIDEvent As LongPtr, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As LongPtr _
) As Long
Public Declare PtrSafe Function KillTimer Lib "user32" _
(ByVal hwnd As LongPtr, _
ByVal nIDEvent As LongPtr _
) As Long
#ElseIf VBA7 Then ' 64 bit Excel in all environments ' Use LongPtr only, LongLong is not available
Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
(ByVal hWnd1 As LongPtr, _
ByVal hWnd2 As LongPtr, _
ByVal lpsz1 As String, _
ByVal lpsz2 As String _
) As LongPtr
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As LongPtr, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByRef lParam As Any _
) As LongPtr
Private Declare PtrSafe Function SetTimer Lib "user32" _
(ByVal hwnd As LongPtr, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function KillTimer Lib "user32" _
(ByVal hwnd As LongPtr, _
ByVal nIDEvent As Long) As Long
#Else ' 32 bit Excel
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
(ByVal hWnd1 As Long, _
ByVal hWnd2 As Long, _
ByVal lpsz1 As String, _
ByVal lpsz2 As String _
) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByRef lParam As Any _
) As Long
Private Declare Function SetTimer Lib "user32" _
(ByVal hwnd As Long, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As Long) As Long
Public Declare Function KillTimer Lib "user32" _
(ByVal hwnd As Long, _
ByVal nIDEvent As Long) As Long
#End If
Private Const PASSBOX_INPUT_CAPTION As String = "Password Required"
Private Const EM_SETPASSWORDCHAR As Long = &HCC
Private Const NV_INPUTBOX As Long = &H5000&
Public Function InputBoxPassword(Prompt As String, _
Optional Default As String = vbNullString, _
Optional XPos, Optional YPos, _
Optional HelpFile, Optional HelpContext _
) As String
On Error Resume Next
' Replicates the functionality of a VBA InputBox function, with the user's
' typed input displayed as asterisks. The 'Title' parameter for the dialog
' caption is hardcoded as "Password Required" in this implementation.
' REQUIRED function: TimerProcInputBox
' REQUIRED API declarations: FindWindow, FindWindowEx, SetTimer, KillTimer
' Nigel Heffernan, January 2015, HTTP://Excellerando.Blogspot.com
' **** **** **** *** THIS CODE IS IN THE PUBLIC DOMAIN **** **** **** ****
' Based on code posted by user 'manish1239' in Xtreme Visual Basic Talk in
' October 2003 http://www.xtremevbtalk.com/archive/index.php/t-112708.html
' Coding notes: we send the 'Set PasswordChar' message to the textbox edit
' window in the VBA 'InputBox' dialog. This isn't a straightforward task:
' InputBox is synchronous, a 'Modal Dialog' which leaves our application's
' VBA code in a waiting state at the exact moment we need to call the Send
' Message API function. So it runs by a delayed callback from an API Timer
' Warning: many of the 64-bit API declarations posted online are incorrect
' and *none* of them are correct for the pointer-safe Timer API Functions.
On Error Resume Next
SetTimer 0&, 0&, 10&, AddressOf TimerProcInputBox
InputBoxPassword = InputBox(Prompt, _
PASSBOX_INPUT_CAPTION, _
Default, _
XPos, YPos, _
HelpFile, HelpContext)
End Function
#If VBA7 And Win64 Then ' 64 bit Excel under 64-bit windows ' Use LongLong and LongPtr
' Note that wMsg is always the WM_TIMER message, which fits in a Long
Public Sub TimerProcInputBox(ByVal hwnd As LongPtr, _
ByVal wMsg As Long, _
ByVal idEvent As LongPtr, _
ByVal dwTime As LongLong)
On Error Resume Next
' REQUIRED for Function InputBoxPassword
' https://msdn.microsoft.com/en-US/library/windows/desktop/ms644907(v=vs.85).aspx
KillTimer hWndIbox, idEvent
Dim hWndIbox As LongPtr ' Handle to VBA InputBox
hWndIbox = FindWindowEx(FindWindow("#32770", PASSBOX_INPUT_CAPTION), 0, "Edit", "")
If hWndIbox <> 0 Then
SendMessage hWndIbox, EM_SETPASSWORDCHAR, Asc("*"), 0&
End If
End Sub
#ElseIf VBA7 Then ' 64 bit Excel in all environments ' Use LongPtr only
Public Sub TimerProcInputBox(ByVal hwnd As LongPtr, _
ByVal wMsg As Long, _
ByVal idEvent As LongPtr, _
ByVal dwTime As Long)
On Error Resume Next
' REQUIRED for Function InputBoxPassword
' https://msdn.microsoft.com/en-US/library/windows/desktop/ms644907(v=vs.85).aspx
Dim hWndIbox As LongPtr ' Handle to VBA InputBox
KillTimer hwnd, idEvent
hWndIbox = FindWindowEx(FindWindow("#32770", PASSBOX_INPUT_CAPTION), 0, "Edit", "")
If hWndIbox <> 0 Then
SendMessage hWndIbox, EM_SETPASSWORDCHAR, Asc("*"), 0&
End If
End Sub
#Else ' 32 bit Excel
Public Sub TimerProcInputBox(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal idEvent As Long, _
ByVal dwTime As Long)
On Error Resume Next
' REQUIRED for Function InputBoxPassword
' https://msdn.microsoft.com/en-US/library/windows/desktop/ms644907(v=vs.85).aspx
Dim hWndIbox As Long ' Handle to VBA InputBox
KillTimer hwnd, idEvent
hWndIbox = FindWindowEx(FindWindow("#32770", PASSBOX_INPUT_CAPTION), 0&, "Edit", "")
If hWndIbox <> 0 Then
SendMessage hWndIbox, EM_SETPASSWORDCHAR, Asc("*"), 0&
End If
End Sub
#End If
</PRE>
</CODE>
<BR />
<BR />
Share and enjoy.
<BR />
<BR />
Nigel Heffernanhttp://www.blogger.com/profile/08954578765691578714noreply@blogger.com0tag:blogger.com,1999:blog-1800518423097919889.post-55763338503864427162014-12-06T13:31:00.000+00:002015-07-30T15:11:43.641+01:00Writing an Excel range to a csv file: optimisations and unicode compatibility<BR />
I posted some <A HREF="http://excellerando.blogspot.co.uk/2012/08/join-and-split-functions-for-2.html">VBA code to Split and Join 2D arrays using optimised string-handling</A> a while ago: here's a function using the same logic to write an array to a csv file.
<BR />
<BR />
There's some interesting surprises in this kind of simple operation when you meet Unicode characters - and I found out that the horrible hack that I use for reading Excel ranges into complex SQL queries via csv files has some problems when the file contains (say) Arabic company names.
<BR />
<BR />
Without going into too much detail, VBA is internally unicode-compliant (strings using 'wide' chars encoding each character in two bytes have been there since well before the turn of the century) but Excel assumes that the outside world runs on ANSI code, or UTF encodings that require a code page. This makes life difficult when you're writing to a file, and reading it again with something else out of Redmond that can manage Unicode text, but hasn't *quite* got it right with the things that other Microsoft products do with this 'We speak Unicode but the outside world is ANSI' thing.
<BR />
<BR />
If you do need more detail (and actually, you probably do; there's a lot of misconceptions around and those of us who work in the Microsoft Office 'stack' have some of the most annoying ones), I recommend a quick re-read of Joel Spolsky's blog post: <A HREF="http://www.joelonsoftware.com/articles/Unicode.html">The Absolute Minimum Every Software Developer Absolutely, Positively Must Know About Unicode and Character Sets</A>.
<BR />
<BR />
Other stuff: If you call the function repeatedly with the same file name, it'll check that the file's unchanged since the last 'ArrayToCSVfile' write, using an Adler-32 checksum on the file contents. If it's still the same data, it'll bail out. <B>This is *embarrassing* if you're reusing the file name for different data</B>, so be sure to delete the pre-existing files in your calling function if you do that.
<BR />
<BR />
And so, without further ado:
<BR />
<BR />
<H2>Writing an Excel range to a csv file</H2>
<BR />
<CODE Lang="VB">
<PRE>
Public Function ArrayToCSVfile(ByRef InputArray As Variant, _
ByVal FilePath As String, _
Optional ByVal CoerceText As Boolean = True _
) As Long
' Output an array to a csv file and returns the row count.
' CoerceText=TRUE will encapsulate all items, numeric or not, in quote marks.
' This code handles unicode, and outputs a file that can be read by Microsoft
' ODBC and OLEDB database drivers.
' The first row is assumed to be a list of unique column names. Non-unique or
' blank names are replaced by the F0, F1, F2... sequential names generated by
' widely-used database engines (including MS-Access, JET & OLEDB text drivers)
' Blank rows after the last data row are not written to file.
' The function stores checksums of every file that it writes; we do not over-
' write a pre-existing file if a check on the file name discovers a record in
' the checksum list, and a check on the file contents shows that it still has
' the same checksum. There's an overhead to this preliminary file 'read' of a
' pre-existing file (our VBA implementation of the Adler32 hash can only read
' 25 Mbytes per second) but this is much faster than an uneccessary overwrite
On Error Resume Next
' Coding note: we're not doing any string-handling in VBA.Strings: allocating
' deallocating and (especially!) concatenating are SLOW. We are using the VBA
' Join and Split functions ONLY. Feel free to optimise further by declaring a
' faster set of string functions from the Kernel if you want to.
'
' Other optimisations: type pun. Byte Arrays are interchangeable with strings
' Some of our loops through these arrays have a 'step' of 2. This optimises a
' search-andreplace for ANSI chars in an array of 2-byte unicodes.
' ** THIS CODE IS IN THE PUBLIC DOMAIN **
' Nigel Heffernan Excellerando.Blogspot.com
Dim COMMA As String
Dim BLANK As String
Dim EOROW As String
COMMA = ChrW$(44)
BLANK = ChrW$(13) & ChrW$(10) & ChrW$(13) & ChrW$(10)
EOROW = ChrW$(13) & ChrW$(10)
Dim i As Long
Dim j As Long
Dim k As Long
Dim i_LBound As Long
Dim i_UBound As Long
Dim j_LBound As Long
Dim j_UBound As Long
Dim k_lBound As Long
Dim k_uBound As Long
Dim iCheckSum As Long
Dim iRowCount As Long
Dim hndFile As Long
Dim arrBytes() As Byte
Dim arrTemp1() As String
Dim arrTemp2() As String
Dim arrTemp3(0 To 2) As String
Dim strBlankRow As String
Dim boolSkipRow As Boolean
Dim boolNumeric As Boolean
Dim strHeader As String
Dim arrHeader() As Byte
Static FileCheckSums As Scripting.Dictionary
If FileCheckSums Is Nothing Then
Set FileCheckSums = New Scripting.Dictionary
End If
If Len(VBA.FileSystem.Dir(FilePath)) <> 0 Then
iCheckSum = FileCheckSum(FilePath)
If FileCheckSums(FilePath) = iCheckSum Then
ArrayToCSVfile = -1
Exit Function ' The file's unchanged since we last created it.
Else
VBA.FileSystem.Kill FilePath
End If
End If
i_LBound = LBound(InputArray, 1)
i_UBound = UBound(InputArray, 1)
j_LBound = LBound(InputArray, 2)
j_UBound = UBound(InputArray, 2)
ReDim arrTemp1(i_LBound To i_UBound)
ReDim arrTemp2(j_LBound To j_UBound)
' We start with a 2-byte 'Wide' char. This coerces all subsequent operations to unicode
arrTemp3(0) = ChrW$(34) ' Encapsulating quote
arrTemp3(1) = vbNullString ' The field value will go here
arrTemp3(2) = ChrW$(34) ' Encapsulating quote
' Special handling for the header row. Not optimised, but it's only one row
i = i_LBound
For j = j_LBound To j_UBound
arrTemp3(1) = ChrW(70) & j ' Columns must have a unique header. Default F0, F1...
If IsError(InputArray(i, j)) Then
' no action
ElseIf IsNull(InputArray(i, j)) Then
' no action
ElseIf IsEmpty(InputArray(i, j)) Then
' no action
ElseIf Len(InputArray(i, j)) = 0 Then
' no action
Else
If IsDate(InputArray(i, j)) Then
arrTemp3(1) = Round(CDbl(CVDate(InputArray(i, j))), 8)
Else
arrBytes = CStr(InputArray(i, j))
For k = LBound(arrBytes) To UBound(arrBytes) Step 2
Select Case arrBytes(k)
Case 10, 13, 9, 44, 160 ' replaces CR, LF, Tab, Comma, and non-breaking
arrBytes(k) = 32 ' spaces with the standard ANSI space character
Case 34
arrBytes(k) = 39
End Select
Next k
arrTemp3(1) = arrBytes
End If
End If
arrTemp2(j) = Join(arrTemp3, vbNullString)
' Remove duplicated field names
For k = j_LBound To j - 1 Step 1
If StrComp(arrTemp2(k), arrTemp2(j), vbTextCompare) = 0 Then
arrTemp2(j) = ChrW(34) & "F" & j & ChrW(34) ' Non-unique: revert to default
Exit For
End If
Next k
Next j
arrTemp1(i) = Join(arrTemp2, COMMA)
' Data body. This is heavily optimised to avoid VBA.String functions with allocations
For i = 1 + i_LBound To i_UBound
boolSkipRow = True
For j = j_LBound To j_UBound
If IsEmpty(InputArray(i, j)) Then 'This condition is so common that we separate it out into its
arrTemp2(j) = vbNullString 'own IF...THEN clause & subordinate the rest into nested IFs
Else
If IsError(InputArray(i, j)) Then
arrTemp2(j) = vbNullString '' was #ERROR
ElseIf IsNull(InputArray(i, j)) Then
arrTemp2(j) = vbNullString
ElseIf Len(InputArray(i, j)) = 0 Then
arrTemp2(j) = vbNullString
Else
boolSkipRow = False ' This is definitely a non-blank row
If IsDate(InputArray(i, j)) Then
arrTemp2(j) = InputArray(i, j) ' Safer to Round(CDbl(CVDate(InputArray(i, j))), 8)
' but that's costly for performance. You are better
' off trusting Range.Value2 to create input arrays.
Else
arrBytes = CStr(InputArray(i, j))
For k = LBound(arrBytes) To UBound(arrBytes) Step 2
Select Case arrBytes(k)
Case 10, 13, 9, 44, 160 ' replace CR, LF, Tab, Comma,   with space
If arrBytes(k + 1) = 0 Then arrBytes(k) = 32
Case 34
If arrBytes(k + 1) = 0 Then arrBytes(k) = 39
End Select
Next k
arrTemp2(j) = arrBytes
arrBytes = vbNullString
End If
End If
End If ' isempty
Next j
If boolSkipRow Then
arrTemp1(i) = vbNullString
iRowCount = iRowCount - 1
Else
If CoerceText Then ' encapsulate all fields in quotes
For j = j_LBound To j_UBound
arrTemp3(1) = arrTemp2(j)
arrTemp2(j) = Join$(arrTemp3, vbNullString)
Next j
Else
For j = j_LBound To j_UBound
arrBytes = arrTemp2(j)
boolNumeric = True
For k = LBound(arrBytes) To UBound(arrBytes) Step 2
If arrBytes(k) < 45 Or arrBytes(k) > 57 Then
boolNumeric = False
Exit For
End If
Next k
If boolNumeric Then
For k = 1 + LBound(arrBytes) To UBound(arrBytes) Step 2
If arrBytes(k) <> 0 Then
boolNumeric = False
Exit For
End If
Next k
End If
arrBytes = vbNullString
If Not boolNumeric Then
arrTemp3(1) = arrTemp2(j)
arrTemp2(j) = Join(arrTemp3, vbNullString)
End If
Next j
End If
arrTemp1(i) = Join(arrTemp2, COMMA)
End If
Next i
iRowCount = i + iRowCount - 2
If iRowCount < 1 Then
iRowCount = 0 ' Note: this count excludes the header
End If
' **** WHY THIS IS COMMENTED OUT **** **** **** **** **** **** **** ****
'
' Microsoft ODBC and OLEDB database drivers cannot read the field names from
' the header when a unicode byte order mark (&HFF & &HFE) is inserted at the
' start of the text by Scripting.FileSystemObject 'Write' methods. Trying to
' work around this by writing byte arrays will fail; FSO 'Write' detects the
' string encoding automatically, and won't let you hack around it by writing
' the header as UTF-8 (or 'Narrow' string) and appending the rest as unicode
'
' (Yes, I tried some revolting hacks to get around it: don't *ever* do that)
'
' **** **** **** **** **** **** **** **** **** **** **** **** **** **** ****
'
' With FSO.OpenTextFile(FilePath, ForWriting, True, TristateTrue)
' .Write Join(arrTemp1, EOROW)
' .Close
' End With ' textstream object from objFSO.OpenTextFile
'
' **** **** **** **** **** **** **** **** **** **** **** **** **** **** ****
' **** WHY WE 'PUT' A BYTE ARRAY INSTEAD OF A VBA STRING VARIABLE **** ****
'
' Put #hndFile, , StrConv(Join(arrTemp1, EOROW), vbUnicode)
' Put #hndFile, , Join(arrTemp1, EOROW)
'
' If you pass unicode, Wide or UTF-16 string variables to PUT, it prepends a
' Unicode Byte Order Mark to the data which, when written to your file, will
' render the field names illegible to Microsoft's JET ODBC and ACE-OLEDB SQL
' drivers (which can actually read unicode field names, if the helpful label
' isn't in the way). However, the 'PUT' statements write a Byte array as-is.
'
' **** **** **** **** **** **** **** **** **** **** **** **** **** **** ****
arrBytes = Join(arrTemp1, EOROW)
' Remove empty rows after the data: this is so common in arrays from Excel
' ranges that the performance penalty is acceptable (one big allocation in
' the Redim Preserve statement) but you may prefer to comment out the code
' We *could* do a Replace on BLANK to get internal blank rows as well, but
' I don't trust the unicode handling and the performance penalty is higher
k_lBound = LBound(arrBytes)
k_uBound = UBound(arrBytes)
For k = k_uBound - 1 To k_lBound Step -1
If arrBytes(k) <> 0 Then
If Not (arrBytes(k) = 10 Or arrBytes(k) = 13) Then
Exit For
End If
End If
Next k
ReDim Preserve arrBytes(k_lBound To k + 1)
hndFile = FreeFile
Open FilePath For Binary As #hndFile
Put #hndFile, , arrBytes
Close #hndFile
FileCheckSums(FilePath) = StringCheckSum(arrBytes)
Erase arrBytes
ArrayToCSVfile = iRowCount
ExitSub:
On Error Resume Next
Erase arrTemp1
Erase arrTemp2
Exit Function
ErrSub:
Resume ExitSub
End Function
</PRE>
</CODE>
<BR />
<BR />
You'll need this, too: the file and string checksum functions called in the code.
<BR />
<BR />
<H2>A VBA implementation of the Adler-32 checksum, running on byte arrays instead of using VBA string-handling.</H2>
<BR />
This includes another Heffernan Horrible Hack: the VBA Long Integer data type doesn't go up tp 2³², it's a signed integer for ±2³¹. So there's a wraparound at 2³¹-1, which feels rather quaint in this modern age of 64-bit LongLong integers.
<BR />
<BR />
However, there is old-worlde quaintness, and there's mediæval barbarism: the final operation of an Adler-32 hashing function is a multiplication that can and does blow past 2³², and I'm using a Floating-point double to do it. If my castle is ever threatened by a mob of peasants with pitchforks and torches, I might encapsulate that in a conditional-compilation block on #VBA7, with a proper LongLong integer in the 64-bit block and the barbarism confined to the #Else block.
<BR />
<BR />
<CODE Lang="VB">
<PRE>
Public Function StringCheckSum(ByRef ByteArray() As Byte) As Long
Application.Volatile False
' Returns an Adler32 checksum of a string: typically a large file's contents
' Note that the VBA Long Integer data type is *not* a 32-bit integer, it's a
' signed integer with a range of ± (2^31) -1. So our return value is signed
' and return values exceeding +2^31 -1 'wraparound' and restart at -2^31 +1.
' Test your results. Some data sets (especially repeating dates) have double
' digit collision rates, and you'll need to find a different hash algorithm.
' Coding Notes:
' What, didn't you know that a Byte Array and a string are type-compatible?
' This is intended for use in VBA, and not for use on the worksheet. Use the
' setting 'Option Private Module' to hide CheckSum from the function wizard
' Author: Nigel Heffernan, May 2006 http://excellerando.blogspot.com
' Acknowledgements and thanks to Paul Crowley, who recommended Adler-32
' Please note that this code is in the public domain. Mark it clearly, with
' the author's name, and segregate it from any proprietary code if you need
' to assert ownership & commercial confidentiality on your proprietary code
Const LONG_LIMIT As Long = (2 ^ 31) - 1
Const MOD_ADLER As Long = 65521
Dim a As Long
Dim b As Long
Dim i As Long
Dim dblOverflow As Double
Dim i_LBound As Long
Dim i_UBound As Long
a = 1
b = 0
i_LBound = LBound(ByteArray)
i_UBound = UBound(ByteArray)
For i = i_LBound To i_UBound
a = (a + ByteArray(i)) Mod MOD_ADLER
b = (b + a) Mod MOD_ADLER
Next i
' Using a float in an integer calculation? We can get away with it, because
' the float error for a VBA double is < ±0.5 with numbers smaller than 2^32
dblOverflow = (1# * b * MOD_ADLER) + a
If dblOverflow > LONG_LIMIT Then ' wraparound 2^31 to 1-(2^31)
Do Until dblOverflow < LONG_LIMIT
dblOverflow = dblOverflow - LONG_LIMIT
Loop
StringCheckSum = 1 + dblOverflow - LONG_LIMIT
Else
StringCheckSum = b * MOD_ADLER + a
End If
End Function
Public Function FileCheckSum(strFilePath As String) As Long
Application.Volatile False
On Error Resume Next
'Return an ADLER-32 checksum from a file
' Throttle repeated calls using static variables. WARNING
' this assumes the file hasn't changed in the last 500 ms
Static LastFile As String
Static LastCall As Single
Static LastHash As Long
If LastFile = strFilePath Then
If VBA.Timer - LastCall < 0.5 Then
FileCheckSum = LastHash
Exit Function
Else
LastCall = VBA.Timer
End If
Else
LastFile = strFilePath
LastCall = VBA.Timer
End If
Dim hndFile As Long
Dim arrBytes() As Byte
Dim lenData As Long
hndFile = FreeFile
Open strFilePath For Binary As #hndFile
ReDim arrBytes(0 To LOF(hndFile) - 1)
Get #hndFile, , arrBytes
Close #hndFile
FileCheckSum = StringCheckSum(arrBytes)
Erase arrBytes
LastHash = FileCheckSum
End Function
</PRE>
</CODE>
<BR />
<BR />
Share and enjoy.
<BR />
<BR />
<SMALL>I should thank the estimable Paul Crowley for showing me the Adler-32 algorith, years ago, and much else besides; but a gentleman aficionado of algrorithmic elegance might prefer to dissociate himself from such abuses.</SMALL>
<BR />
<BR />
<BR />
<BR />
Nigel Heffernanhttp://www.blogger.com/profile/08954578765691578714noreply@blogger.com0tag:blogger.com,1999:blog-1800518423097919889.post-24841043151155612402014-11-18T17:41:00.000+00:002014-11-18T17:45:13.455+00:00In the absence of interesting content, a filler pieceWe don't always get to write good code: sometimes we have the job of thanking someone for their contribution, telling them truthfully and cheerfully: "No, really: it couldn't *possibly* be improved!", and gaffer-taping it together with comprehensible variable declarations and a bit of code-readability work.
<BR /><BR />
Here's a function that will help you with that:
<CODE Lang="VB">
<PRE>'
Public Function f(Optional Filler As Variant = "") As Double
Application.Volatile False
' Function always returns zero - its only purpose is to 'pad out' expressions for readability
' An option to suppress VBA's habit of excising 'unnecessary' whitespace would be more useful
f = 0
' Coding Notes:
'
' If it is ever necessary for you to use this, leave the following note for your colleagues:
'
' "There is no hope for us. I am Bricking Up The House From Within."
'
' Code Enhancement: leave an acknowledgement in the code, naming someone you *really* dislike
End Function
</PRE>
</CODE>
Feel free to *not* acknowledge my contribution if you reuse this code.
<BR /><BR />
I do have an acknowledgement for my betters here: the apocalyptic phrase 'We Are Bricking Up The House From Within' originates from Adrian Bott, well known and much-esteemed as @Cavalorn.
<BR /><BR />
He's not a developer: he's a published author of Fantasy and Horror.
<BR /><BR />Nigel Heffernanhttp://www.blogger.com/profile/08954578765691578714noreply@blogger.com0tag:blogger.com,1999:blog-1800518423097919889.post-8274595636408443672014-11-04T17:33:00.000+00:002015-01-22T19:52:42.726+00:00What's the most useful answer you've ever given?Last time I looked at Stack Overflow, the most useful answer - or rather, the most read-and-endorsed answer - I've ever given was to a question about <B>copyright notices</B>.
<BR /><BR />
Maybe I'm in the wrong job, and there's better living to be made as an attorney (a Solicitor in England) than being a spreadsheet-basher.
<BR /><BR />
Anyway, the question (and my answer to it) was deleted long ago, so I'll put it here for posterity:
<BR /><BR />
<BLOCKQUOTE>
<H2>Do you put copyright notices in your (proprietary) code? </H2>
<BR />
The better-organised companies have a copyright notice, pre-generated and added automatically to the header of every code module.
<BR /><BR />
If your employer isn't sufficiently clued-up to ask you, don't bother asking them. It'll be seen as troublemaking, and you'll be blamed for something - anything! - and everything.
<BR /><BR />
Yes, big companies really do think that way.
<BR /><BR />
Meanwhile, put a friendly notice into your code modules and classes to help more junior developers, who might not be aware that (say) code you copied off MSDN or an API published on the web (or some friendly blogger) is almost certainly encumbered with a GPL or CopyLeft License:
<CODE Lang='VB'>
<PRE>
<BR />
' Nigel Heffernan, [xxx dept, xxxyyy company, London] October 2009
' This code is adapted from material in the Public Domain
' (April 2009 Excellerando.Blogspot.com).
'
' It is unencumbered by copyrights and patents and we can use it freely,
' but we can only assert our own Intellectual Property rights on derived
' works: the original work remains free for public use.
'
' If you contribute distinctive features and original concepts, take care
' to segregate your source code and clearly mark it with our registered
' company name and a link to our copyright license warning.
</PRE>
</CODE>
<BR /><BR />
There is, of course, the old standby:
<BR />
<CODE Lang='VB'>
<PRE>
<BR />
If you were thinking of making an unauthorised copy and using it outside the company, don't.
We have a dimly-lit bunker, deep underground, with row upon row of incubation tanks,
each one holding an Intellectual Property Lawyer in a nutrient solution of neurotoxic
venom and the even-numbered isotopes of plutonium that no-one wanted to use in their
nuclear weapons. If you use this software without authorisation, we will decant them
off, one a day, every day, and let them loose with an unlimited legal budget until
you are nothing but a radioactive hole in the ground surrounded by safety warnings
and foreclosure notices.
 Also, the moment when they open their eyes and stare at you is CREEPY.
</PRE>
</CODE>
<BR />
<BR />
I believe there is a older version by Neil Gaiman (a fantasy author, not a coder) with something about bat-winged horrors of the outer darkness.
</BLOCKQUOTE>
<BR />
<BR />
I worry that mentioning 'Plutonium' has put me on some kind of watchlist, and someday it's going to be difficult to board airliners. But that's all just fine: we're all so much safer because of it, and you're probably on a list too, just for reading this page.
<BR /><BR />
Let me know if you get targeted advertising offering to sell you any, its *really* unfair on the delivery guy.<BR /><BR />
<BR />
<BR />
Nigel Heffernanhttp://www.blogger.com/profile/08954578765691578714noreply@blogger.com0tag:blogger.com,1999:blog-1800518423097919889.post-43493385059591745492014-09-18T15:27:00.001+01:002014-11-24T19:02:47.953+00:00A Horrible Hack: Complex SQL Queries on Excel Data<BR /><H4>
A Cautionary Tale of things that no developer should ever see or do, with diversions and digressions into failures of business logic, workarounds and worse-arounds, budget fairies, business analysts, and scrofulous pilgrims seeking miraculous healing in the elevator lobby. </H4>
<BR /><BR /><BR />
From time to time it necessary to perform a Horrible Hack. A hack that might have tolerable snippets of code, or even pretty nifty ones; but it's a Horrible Hack if the whole thing, taken as a whole, ought to be buried in a hole - and this post show you the code for one of them.
<BR /><BR />
The task is deceptively simple: perform SQL queries on data sets that happens to be in Excel. Because vlookup can only do so much, and Pivot tables aren't flexible enough, and WHY AREN'T YOU DOING THIS IN A PROPER DATABASE INSTEAD OF KLUDGING?
<BR /><BR />
Well, the answer to that is: <I>"It's a prototype, and it's on the stack for the database developers to get it done properly"</I>. Except that it's still running in Excel, a year or so later, and the database guys aren't going to touch it. Ever. Because the SQL is too complex for them, or it wasn't invented here, or maybe you don't have the staffing budget for human sacrifice or whatever propitiates the wrath of database administrators.
<BR /><BR />
Other reasons: the data for our report exists in multiple systems, not all of them expose a SQL interface, and the *only* export format that they have in common in they can spit out .xls files. And some of the config data (exception lists) only exists in an Excel sheet on a Sharepoint server. Yes, we'd like that to live in a proper table in a named application with a relational database: and no, nobody's going to build it. Ever. Not 'til Hell freezes over and the magic budget fairy brings you a dedicated infrastructure spend and three business analysts bearing gold, detailed system specifications, and signoff from managers so senior that queues of pilgrims wait outside the executive elevator lobby, hoping for the chance to touch the hem of their suits and cure themselves of scrofula.
<BR /><BR />
And this is where Horrible Hacks come from, on the user side: business requirements that emerge from a need to work around blockages and other anomalies in the business processes we serve in our software.
<BR /><BR />
But to be truly horrible, a Horrible Hack needs an additional layer of complexity arising from the need to work around a fundamental failure in the technical platform. And yes, we have *just* the thing: Microsoft's SQL drivers for Excel are unstable. You can't just connect to an Excel workbook - closed or open - with an OLEDB session using the publicly-available Excel driver; nor can you do so with ODBC ISAM drivers - they all have memory leaks, and they will all crash the host application if you run them often enough. So Excel data isn't directly available to complex SQL.
<BR /><BR />
So... How bad can it get?
<BR /><BR />
Well, we start by grabbing the data from closed workbooks using SQL sent to the Excel OLEDB driver. We can *just* get away with it by closing the connections immediately. If I was paranoid, I'd run this in 'shelled' separate sessions of Excel.exe - but that really is too much work for an app that's going to be replaced by the grown-ups in a proper Dev team, right?
<BR /><BR />
We save that data as text files in a temporary folder.
<BR /><BR />
And read those files, just as if they were tables in a database, using SQL and the Microsoft Jet Text OLEDB driver.
<BR /><BR />
Yes, you heard that correctly: we're using JET SQL. It's a peculiar dialect of SQL... And if you want to get clever with the data-grabbing phase, and filter the data you grab from the source range, you'll need to know the arcane conventions for naming the 'table' in your query with a '$' depending on whether it's a named range or a sheet, or a range address. Oh, and bracketing it. Mustn't forget bracketing.
<BR /><BR />
But once we get beyond that, and you're just querying the 'tables' you've created in that temp folder, it's actually pretty straightforward. Unions, joins, aliasing tables into subqueries, conditional logic (IF statements, JET SQL doesn't support CASE): the whole of SQL is there for you.
<BR /><BR />
Excel is actually a pretty good SQL editor - if you have a well-written text-grabber to read the range you're writing SQL in - because moving blocks of text around and marking-up with background shading is really, really easy. And the smart kids will have a range marked up as 'Test SQL' with a 'GetRecordset' function behind the 'Test It!' button that returns the full error strings from the database engine, which includes the syntax errors and line numbers.
<BR /><BR />
Oh, and you can use Excel Formulas to feed in parameters, especially start and end dates: my advice is 'Be sparing with that', but it's just too damned convenient. I would suggest formatting any text that does that in red, just so that you know. I would also recommend casting your dates to doubles, and be *very* defensive about nulls and type errors.
<BR /><BR />
Here's what I mean by 'defensive': a sample of a straightforward JET SQL query with embedded dates from Excel formulae...
<BR />
<PRE>
<BR />
SELECT
[Workbook Group],
IIF( [Region] IS NULL, '', [Region]) AS [Region],
IIF([File ID] IS NULL, 0, CDBL([File ID])) AS [File ID],
[File Name],
IIF([Timepoint] IS NULL, NULL, (CDATE([Timepoint])) ) AS [EventTime],
IIF([Timepoint] IS NULL, NULL, (CDATE([Timepoint])) + (5/24)) AS [EventTimePlusNA],
IIF([Timepoint] IS NULL, NULL, (CDATE([Timepoint])) + (4/24)) AS [EventTimePlusNA1],
IIF([Timepoint] IS NULL, NULL, (CDATE([Timepoint])) - (7/24)) AS [EventTimeMinusAsia],
[Reason],
[Owner],
CDBL(CDATE([Expiry])) AS [Expiry],
[Standard Reason]
FROM
(
SELECT *
FROM [Signoff Exceptions$]
WHERE [File ID] IS NOT NULL
AND [Expiry] IS NOT NULL
AND [Reason] IS NOT NULL
AND [Owner] IS NOT NULL
AND (
(ISDATE([Timepoint]) AND AND AND AND AND NOT ([Timepoint] IS NULL OR [Timepoint] = 0 ))
OR ([Standard Reason] LIKE 'No Reportable%' AND ([Timepoint] IS NULL OR [Timepoint] = 0 OR [Timepoint] LIKE 'ALL' OR [Timepoint] ='' ))
)
) AS tFile
WHERE
( [TimePoint] IS NULL
OR IIF(ISDATE([TimePoint]),
( CDBL(CDATE([Timepoint])) >= CDBL(CDATE(41595))
AND CDBL(CDATE([Timepoint])) <= CDBL(CDATE(41622))
),
FALSE
)
)
AND
(
IIF(ISDATE([Expiry]), CDBL(CDATE([Expiry])) >= CDBL(CDATE(41900)), TRUE)
)
AND [File ID] IS NOT NULL
</PRE>
<BR /><BR />
Alert readers will spot the '$' dollar sign on the table name. Yes, this is a SQL query sent to the data grabber, filtering the data before we save it to a .csv text file in the 'database' folder with the other 'tables'. We could've just sent the range name 'Signoff Exceptions$' directly to the data grabber:
<BR />
<PRE>
arrData = GetDataFromClosedWorkbook(strFilePath, 'Signoff Exceptions$', "", ReadHeaders:=True)
</PRE>
<BR />
As opposed to:
<BR />
<PRE>
arrData = GetDataFromClosedWorkbook(strFilePath, 'Signoff Exceptions$', "", ReadHeaders:=True)
</PRE>
<BR />
<BR />
The real SQL - actually querying the tables we've created - can be as simple as you like:
<BR />
<PRE>
<BR />
SELECT
IIF(tP.[File ID] IS NULL, '(Unknown)', tP.[Workbook Group]) AS [Workbook Group],
IIF(tP.[File ID] IS NULL, '*WARNING* FILE ID ' & tX.[File ID] & ' NOT FOUND ', '') & tX.[File Name] AS [File Name],
tX.[File ID],
tX.[Region],
IIF(tX.[EventTime] IS NULL, 'ALL',
CDBL( CDATE(tX.[EventTime]) )
) AS [Event Time],
tX.[Reason],
tX.[Owner],
IIF(tX.[Expiry] IS NULL, NULL, CDBL(CDATE(tX.[Expiry]))) AS [Exemption Expiry],
[Standard Reason]
FROM
(SELECT * FROM [tblExemptions.csv] WHERE [File ID] <> 'Type=Text' AND [File ID] IS NOT NULL ) AS tX
LEFT JOIN (SELECT * FROM [tblPatterns.csv] WHERE [File ID] <> 'Type=Text' AND [File ID] IS NOT NULL ) AS tP
ON tX.[File ID] = tP.[File ID]
WHERE
tX.[Standard Reason] NOT LIKE 'No Reportable%'
ORDER BY
tP.[Workbook Group],
tX.[File Name],
IIF(tX.[Expiry] IS NULL, NULL, CDATE(tX.[Expiry]))
</PRE>
<BR /><BR />
The SQL can also be as complicated as you like, and that's what this is all about: we're doing data queries in SQL because the logic we need to implement is far, far too complex for the user tools provided in a desktop application. Excel's good, and pivoting is remarkably good, but it's good for tasks within the reach of people without formal training in structured data.
<BR /><BR />
Which brings us to the next part: presentation and the User Experience...
<BR /><BR />
One thing you won't see here, because I'm only posting the code, is Rule 1 of Horrible Hacks: Horrible under the surface, but a clean, crisp, beautiful interface. The uglier your plumbing, the prettier the faucets, the basin and the bidet... And *this* one went out with the interface design equivalent of gold-plated crystal faucets and a four-piece chamber orchestra playing for you as the Personal Assistant checks the loofah for *exactly* the right degree of scratchiness while running the bath to the perfect temperature.
<BR /><BR />
OK. Lets get started.There's a big red button and all it does is call 'Grab the data' and 'Run the reports':
<BR /><PRE>
<BR />
Public Sub RunReports()
FetchSourceData
SignoffTimestamp
ReportAcceptances
ReportExemptions
ReportSignoffsALL
ReportSummary
ThisWorkbook.Names("Report_TimezoneDescription").RefersToRange.Value = "All timestamps are " & TimeZone
ThisWorkbook.Names("Datestamp_LastRun").RefersToRange.Value = Now()
Application.Calculate
End Sub
</PRE>
<BR /><BR />
Not very informative... But the point is, we try and keep individual functions simple. And we segregate our code: this is from the application's custom module - the reports are in here, as is FetchSourceData (the 'grabber) because they're all custom code for this specific app.
<BR /><BR />
There's a separate module called 'basExcelSQL', and that contains all the generic SQL-reading and ADODB-connecting code that gets reused whenever I have to try this stunt again. And yes, I do, and did.
<BR /><BR />
SO lets look at the 'report' functions, using the Exemptions report as a sample:
<BR />
<PRE>
<BR />
Public Sub ReportExemptions()
Application.StatusBar = "Exemptions report..."
Dim SQL As String
Dim rst As ADODB.Recordset
Dim rng As Excel.Range
Dim j As Integer
Dim strSource As String
Set rng = ThisWorkbook.Names("Report_Exempted").RefersToRange
SQL = ReadRangeSQL(ThisWorkbook.Names("SQL_Exemption_List").RefersToRange)
rng.ClearContents
Set rst = FetchRecordset(SQL)
If rst Is Nothing Then
Exit Sub
End If
If rst.State <> 1 Then
Exit Sub
End If
' Write out the column headings
For j = 0 To rst.Fields.Count - 1
rng.Cells(1, j + 1) = rst.Fields(j).Name
Next j
If Not (rst.EOF And rst.BOF) Then
ArrayToRange rng.Cells(2, 1), ArrayTranspose(rst.GetRows)
rng.AutoFilter
End If
rst.Close
rst.ActiveConnection.Close
Set rst = Nothing
Application.StatusBar = False
End Sub
</PRE>
<BR /><BR />
Yes, I could parameterise it: and no, I didn't. All of the individual report functions look like this, because they all ended up getting customised - it's what this module's for, custom code - and this one got an extra function to diplay a timestamp and time-of-file in the report header, with a checked and updated hyperlink to the source file on the SharePoint folder. Other reports got custom formatting, special headers, and so on.
<BR /><BR />
We'll be looking at ReadRangeSQL and FetchRecordset later, with the rest of the 'basExcelSQL' module; the point here is that we have clean code on top of the Horrible Hack, and less-confident developers can easily reuse your code.
<BR /><BR />
So what does 'FetchSourceData' do? Well, it reads a table - not in SQL this time, we've got to start somewhere, so this is an Excel Range on a sheet called 'Settings' - listing the folders and the files...
<BR /><BR />
...EXCEPT that we're reading files dumped in folders by server-based applications, with date strings in the names. So we can look for a literal file name, or look for a wildcard search string, and pick out the most recently-saved file.
<PRE>
<BR />
Public Sub FetchSourceData()
Application.StatusBar = "Fetching source data..."
' Read each file in the 'TableNames' range into a local table
' In more detail:
' 1: If a pattern (wildcard '*') is used, use the most recent matching file
' 2: Write the data to a properly formatted csv file in a local temp folder
' 3: These named csv files are visible to the Microsoft Text ISAM as tables
' in a 'database' (the folder containing them) which supports MS JET SQL
Dim strSourceFolder As String
Dim strSourceFile As String
Dim strTable As String
Dim strRange As String
Dim dblLastImport As Double
Dim strFieldNames As String
Dim arrTables As Variant
Dim iRow As Integer
Dim varData As Variant
Dim strFilePath As String
Dim dblFileDate As Double
Dim maxFileDate As Double
Dim strFoundFile As String
Dim strUseFile As String
SheetSettings.Calculate
strSourceFolder = ThisWorkbook.Names("SourceFolder").RefersToRange.Value2
If InStr(1, strSourceFolder, "//") > 0 Then
If Right(strSourceFolder, 1) <> "/" Then
strSourceFolder = strSourceFolder & "/"
End If
Else
If Right(strSourceFolder, 1) <> "\" Then
strSourceFolder = strSourceFolder & "\"
End If
End If
' Parse out web folder paths
If Left(strSourceFolder, 5) = "http:" Then
strSourceFolder = Right(strSourceFolder, Len(strSourceFolder) - 5)
strSourceFolder = Replace(strSourceFolder, "%20", " ")
strSourceFolder = Replace(strSourceFolder, "%160", " ")
strSourceFolder = Replace(strSourceFolder, "/", "\")
End If
Application.StatusBar = "Fetching source data"
' Column 1: strTable = arrTables(iRow, 1) - the table name (csv filename) in the 'database' temp folder
' Column 2: strRange = arrTables(iRow, 2) - The range address, or a SQL string reading and filtering the range
' Column 3: strSource = arrTables(iRow, 3) - The file ( a literal name or a wildcard search term )
' The other columns are datestamps and status / error information
arrTables = ThisWorkbook.Names("TableNames").RefersToRange.Value2
For iRow = LBound(arrTables, 1) + 1 To UBound(arrTables, 1)
Application.StatusBar = "Fetching source data" & String((iRow Mod 3) + 1, ".")
strTable = ""
strTable = arrTables(iRow, 1)
If strTable <> "" Then
If IsError(arrTables(iRow, 2)) Then
arrTables(iRow, 2) = "#ERROR"
End If
strRange = arrTables(iRow, 2)
strSourceFile = arrTables(iRow, 3)
If IsDate(arrTables(iRow, 4)) Then
dblLastImport = arrTables(iRow, 4)
Else
dblLastImport = 0
End If
strFilePath = strSourceFolder & strSourceFile
If InStr(strSourceFile, "*") Then
' Identify the most recent file matching the pattern given in the TableNames list
maxFileDate = 0
strUseFile = ""
strFoundFile = ""
On Error GoTo ErrFolder
strFoundFile = Dir(strSourceFolder & strSourceFile)
On Error GoTo ErrSkipFile
Do While Len(strFoundFile) > 0
dblFileDate = 0
dblFileDate = VBA.FileSystem.FileDateTime(strSourceFolder & strFoundFile)
If dblFileDate > maxFileDate Then
strUseFile = strFoundFile
maxFileDate = dblFileDate
End If
strFoundFile = Dir
Loop
If Len(strUseFile) > 0 Then
strFilePath = strSourceFolder & strUseFile
ThisWorkbook.Names("TableNames").RefersToRange.Cells(iRow, 5) = strUseFile
End If
End If
On Error GoTo ErrFile
If Len(Dir(strFilePath)) = 0 Then
If Len(Dir(Folder(strSourceFolder), vbDirectory)) = 0 Then
Err.Raise -559038737, APP_NAME & ":FetchSourceData", "The Signoff Progress Report cannot be run because " & APP_NAME & " cannot find the data folder: " & vbCrLf & vbCrLf & "'" & Folder(strSourceFolder) & "'" & vbCrLf & vbCrLf & "Please use Windows Explorer to check that the folder exists, and check that you have permission to open files in it."
End If
Err.Raise -559038737, APP_NAME & ":FetchSourceData", "The Signoff Progress Report cannot be run because there is no file matching '" & strSourceFile & "' in this location: " & vbCrLf & vbCrLf & strFilePath & vbCrLf & vbCrLf & "Please open the folder and make sure that the source files for the report are in place."
End If
On Error GoTo ErrSub
' Record the datestamp of the file we've selected for loading
ThisWorkbook.Names("TableNames").RefersToRange.Cells(iRow, 6) = VBA.FileSystem.FileDateTime(strFilePath)
strFieldNames = ""
' read the data from the file
varData = GetDataFromClosedWorkbook(strFilePath, strRange, strFieldNames, True)
If IsEmpty(varData) Then
ArrayToFile varData, strTable, True, strFieldNames
ThisWorkbook.Names("TableNames").RefersToRange.Cells(iRow, 4) = "#NO DATA RETURNED BY THE QUERY"
ElseIf IsArray(varData) Then
' write the data to a properly formatted csv file in a local temp folder
ArrayToFile varData, strTable, True, strFieldNames
ThisWorkbook.Names("TableNames").RefersToRange.Cells(iRow, 4) = Now()
Erase varData
varData = Empty
Else
ThisWorkbook.Names("TableNames").RefersToRange.Cells(iRow, 4) = varData
varData = Empty
End If 'IsEmpty(varData) Then
End If ' strTable <> ""
Next iRow
Erase arrTables
ExitSub:
Application.StatusBar = False
Exit Sub
ErrSub:
Select Case MsgBox(Err.Description, vbCritical + vbAbortRetryIgnore + vbMsgBoxHelpButton, APP_NAME & ": Error fetching source data", Err.HelpFile, Err.HelpContext)
Case vbRetry
Resume
Case vbIgnore
Resume Next
Case vbAbort
End
Case Else
' undefined behaviour from 'Escape'
End
End Select
Resume ExitSub
ErrFile:
MsgBox Err.Description, vbApplicationModal, "Signoff Progress Report: missing data file"
'This error is fatal - bad file! - and we will halt execution.
End
ErrFolder:
MsgBox "Cannot retrieve file data from the following folder: " & vbCrLf & vbCrLf & strSourceFolder & vbCrLf & vbCrLf & "Windows returned the following error: ERROR " & Err.Number & ": " & Err.Description & vbCrLf & vbCrLf & "Check the folder in Windows Explorer, as the problem may be your access privileges.", vbCritical + vbMsgBoxHelpButton, APP_NAME & ": inaccessible data folder", Err.HelpFile, Err.HelpContext
'This error is fatal - bad data folder! - and we will halt execution.
End
ErrSkipFile:
' called from resilient code - we're scanning files in a folder, if it's unusable we'll just try the next file
Resume Next
End Sub
Public Function FilePath(strSharePointPath As String) As String
Application.Volatile False
' Translate sharepoint paths into their underlying filesystem addresses
FilePath = strSharePointPath
If Left(FilePath, 5) = "http:" Then
FilePath = Right(FilePath, Len(FilePath) - 5)
FilePath = Replace(FilePath, "%20", " ")
FilePath = Replace(FilePath, "%160", " ")
FilePath = Replace(FilePath, "/", "\")
End If
End Function
</PRE>
<BR /><BR />
Really, it's just a wrapper feeding parameters into GetDataFromClosedWorkbook, which reads data directly from Excel ranges, and for the ArrayToFile function which writes the extracted data into our 'table' files.
<BR /><BR />
WHich is to say: there is one complicated operation in there - reading and checking filenames out of a table - and the other operations are in clearly-named functions. Indirection, we call it.
<BR /><BR />
And so, without further ado (or ADODB), we reveal the code that does the heavy lifting, basExcelSQL:
<BR /><PRE>
<BR />
Option Explicit
Option Private Module
' ADODB data retrieval functions to support SQL queries against
' Excel data in the current workbook, and in closed workbooks
' Online reference for connection strings:
' http://www.connectionstrings.com/oracle#p15
' Online reference for ADO objects & properties:
' http://msdn.microsoft.com/en-us/library/ms678086(v=VS.85).aspx
Private m_objFSO As Object ' Scripting.FileSystemObject
Private m_strTempFolder As String
Private m_objConnText As ADODB.Connection
Private m_strConnText As String
Private Property Get objFSO() As Object
' Return a File System Object
On Error Resume Next
If m_objFSO Is Nothing Then
Set m_objFSO = CreateObject("Scripting.FileSystemObject") ' New Scripting.FileSystemObject
End If
If m_objFSO Is Nothing Then
Shell "Regsvr32.exe /s scrrun.dll", vbHide
Set m_objFSO = CreateObject("Scripting.FileSystemObject")
End If
Set objFSO = m_objFSO
End Property
Private Property Get TempSQLFolder() As String
m_strTempFolder = objFSO.GetSpecialFolder(2).ShortPath ' Scripting.TemporaryFolder
If Right(m_strTempFolder, 1) <> "\" Then
m_strTempFolder = m_strTempFolder & "\"
End If
m_strTempFolder = m_strTempFolder & "XLSQL"
If Not objFSO.FolderExists(m_strTempFolder) Then
objFSO.CreateFolder m_strTempFolder
End If
If Right(m_strTempFolder, 1) <> "\" Then
m_strTempFolder = m_strTempFolder & "\"
End If
TempSQLFolder = m_strTempFolder
End Property
Private Property Get connText() As ADODB.Connection
On Error Resume Next
' The Excel database drivers have problems when multiple instances of the Excel application
' are running, so we use a text driver to read csv files in a temporary folder. These files
' are populated from ranges specified for use as tables by the FetchXLRecordSet() function.
If objFSO Is Nothing Then
Exit Property
End If
On Error GoTo ErrSub
Set m_objConnText = New ADODB.Connection
' Specify and clear a temporary folder:
m_strTempFolder = objFSO.GetSpecialFolder(2).ShortPath ' Scripting.TemporaryFolder
If Right(m_strTempFolder, 1) <> "\" Then
m_strTempFolder = m_strTempFolder & "\"
End If
m_strTempFolder = m_strTempFolder & "XLSQL"
Application.DisplayAlerts = False
If Not objFSO.FolderExists(m_strTempFolder) Then
objFSO.CreateFolder m_strTempFolder
End If
If Right(m_strTempFolder, 1) <> "\" Then
m_strTempFolder = m_strTempFolder & "\"
End If
' JET OLEDB text driver connection string:
' Provider=Microsoft.Jet.OLEDB.4.0;Data Source=c:\txtFilesFolder\;Extended Properties="text;HDR=Yes;FMT=Delimited;MaxScanRows=;IMEX=1;";
' ODBC text driver connection string:
' Driver={Microsoft Text Driver (*.txt; *.csv)};Dbq=c:\txtFilesFolder\;Extensions=asc,csv,tab,txt;
m_strConnText = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & m_strTempFolder & ";"
m_strConnText = m_strConnText & "Extended Properties=" & Chr(34) & "text;HDR=Yes;IMEX=1;MaxScanRows=0" & Chr(34) & ";"
' SetTypeGuessRows
With m_objConnText
.CursorLocation = adUseClient
.CommandTimeout = 90
.ConnectionString = m_strConnText
.Mode = adModeRead
End With
If m_objConnText.State = adStateClosed Then
Application.StatusBar = "Connecting to the local Excel tables"
m_objConnText.Open
End If
Set connText = m_objConnText
ExitSub:
Application.StatusBar = False
Exit Property
ErrSub:
MsgBox "Error connecting to the Excel local data. Please contact Application Support.", vbCritical + vbApplicationModal, "Database connection failure!", 10
Resume ErrEnd
' Resume ExitSub
ErrEnd:
End ' Terminal error. Halt.
End Property
Public Sub CloseConnections()
On Error Resume Next
Set m_objConnText = Nothing
End Sub
Public Function FetchRecordset(SQL As String) As ADODB.Recordset
' Fetch records from the saved text files extracted by reading all those Excel ranges
' It is assumed that you know the arcane SQL conventions for the Microsoft TEXT driver
Dim rst As ADODB.Recordset
On Error Resume Next
Dim i As Integer
Dim iFrom As Integer
Set FetchRecordset = New ADODB.Recordset
With FetchRecordset
.CacheSize = 8
Set .ActiveConnection = connText
On Error GoTo ERR_ADO
.Open SQL, , adOpenStatic, , adCmdText + adAsyncFetch
i = 0
Do While .State > 1
i = (i + 1) Mod 3
Application.StatusBar = "Connecting to the database" & String(i, ".")
Application.Wait Now + (0.25 / 24 / 3600)
Loop
End With
Application.StatusBar = False
ExitSub:
Exit Function
ERR_ADO:
Dim strMsg
strMsg = vbCrLf & vbCrLf & "If this is a 'file' error, someone's got one of the source data files open: try again in a few minutes." & vbCrLf & vbCrLf & "Otherwise, please make a note of this error message and contact the Desktop Support team."
MsgBox "Error &H" & Hex(Err.Number) & ": " & Err.Description & strMsg, vbCritical + vbMsgBoxHelpButton, "Data retrieval error:", Err.HelpFile, Err.HelpContext
Resume ExitSub
End Function
Public Function FetchXLRecordSet(SQL As String, ParamArray TableNames()) As ADODB.Recordset
' This allows you to retrieve data from Excel ranges using SQL
' ...Using Range names directly, by copying the range data to .csv files in a temp
' folder...
' As the Excel OLEDB and ODBC database drivers have problems with multiple running
' instances of Excel, this function has been implemented to use a text driver. You
' need to pass additional parameters specifying each range you're using as a table
' so that the these ranges can be saved as csv files in the SQLXL temporary folder
' Note that your query must still use the naming conventions required by the Excel
' database drivers: http://www.connectionstrings.com/excel#20
' Sample usage:
'
' Set rst = FetchXLRecordSet(SQL, "TableAccountLookup", "TableCashMap")
'
' Where the query uses two named ranges, "TableAccountLookup" and "TableCashMap"
' as shown in this SQL statement:
'
' SELECT
' B.Legal_Entity_Name, B.Status,
' SUM(A.USD_Settled) As Settled_Cash
' FROM
' [TableAccountLookup] AS A,
' [TableCashMap] AS B
' WHERE
' A.Account IS NOT NULL
' AND B.Cash_Account IS NOT NULL
' AND A.Account = B.Cash_Account
' Group BY
' B.Legal_Entity_Name,
' B.Status
On Error Resume Next
Dim i As Integer
Dim iFrom As Integer
Dim strRange As String
Set FetchXLRecordSet = New ADODB.Recordset
With FetchXLRecordSet
.CacheSize = 8
Set .ActiveConnection = connText ' This recreates the database connection, and clears
' the temporary folder containing our csv data files
iFrom = InStr(8, SQL, "From", vbTextCompare) + 4
For i = LBound(TableNames) To UBound(TableNames)
strRange = ""
strRange = TableNames(i)
RangeToFile strRange
SQL = Left(SQL, iFrom) & Replace(SQL, strRange, strRange & ".csv", iFrom + 1, 1)
Next i
SQL = Replace(SQL, ".csv.csv", ".csv")
.Open SQL, , adOpenStatic, , adCmdText + adAsyncFetch
i = 0
Do While .State > 1
i = (i + 1) Mod 3
Application.StatusBar = "Connecting to the database" & String(i, ".")
Application.Wait Now + (0.25 / 24 / 3600)
Loop
End With
Application.StatusBar = False
End Function
Public Function ReadRangeSQL(SQL_Range As Excel.Range) As String
' Read a range into a string.
' Each row is delimited with a carriage-return and a line break.
' Empty cells are concatenated into the string as 'Tabs' of four spaces.
Application.Volatile False
Dim i As Integer
Dim j As Integer
Dim arrRows As Variant
Dim strRow As String
arrRows = SQL_Range.Value2
If InStr(TypeName(arrRows), "(") Then
For i = LBound(arrRows, 1) To UBound(arrRows, 1)
strRow = ""
For j = LBound(arrRows, 2) To UBound(arrRows, 2)
If Trim(arrRows(i, j)) = "" Then
arrRows(i, j) = " "
End If
strRow = strRow & arrRows(i, j)
Next j
strRow = RTrim(strRow)
If strRow <> "" Then
ReadRangeSQL = ReadRangeSQL & strRow & vbCrLf
End If
Next i
Erase arrRows
Else
ReadRangeSQL = CStr(arrRows)
End If
End Function
Public Sub RangeToFile(ByRef strRange As String)
' Output a range to a csv file in a temporary folder created by the connText function
' strRange specifies a range in the current workbook using the 'table' naming conventions
' specified for Excel OLEDB database drivers: http://www.connectionstrings.com/excel#20
' Note that the first row of the range is assumed to be a set of column names.
On Error Resume Next
If objFSO Is Nothing Then
Exit Sub
End If
Dim rng As Excel.Range
Dim strFile As String
Dim arrData As Variant
Dim iRow As Long
Dim jCol As Long
Dim strData As String
Dim strLine As String
strRange = Replace(strRange, "[", "")
strRange = Replace(strRange, "]", "")
If Right(strRange, 1) = "$" Then
strRange = Replace(strRange, "$", "")
Set rng = ThisWorkbook.Worksheets(strRange).UsedRange
Else
strRange = Replace(strRange, "$", "")
Set rng = Range(strRange)
End If
If rng Is Nothing Then
Exit Sub
End If
If objFSO Is Nothing Then
Exit Sub
End If
strFile = m_strTempFolder & strRange & ".csv"
If objFSO.FileExists(strFile) Then
objFSO.DeleteFile strFile, True
End If
If objFSO.FileExists(strFile) Then
Exit Sub
End If
arrData = rng.Value2
With objFSO.OpenTextFile(strFile, 2, True) ' ForReading = 1, ForWriting = 2, ForAppending = 8
' Header row:
strLine = ""
strData = ""
iRow = LBound(arrData, 1)
For jCol = LBound(arrData, 2) To UBound(arrData, 2)
strData = arrData(iRow, jCol)
strData = Replace(strData, Chr(34), Chr(39))
strData = Replace(strData, Chr(10), " ")
strData = Replace(strData, Chr(13), " ")
strData = strData & ","
strLine = strLine & strData
Next jCol
strLine = Left(strLine, Len(strLine) - 1) ' Trim trailing comma
If Len(Replace(Replace(strLine, Chr(34), ""), ",", "")) > 0 Then
.writeline strLine
End If
' Rest of the data
For iRow = LBound(arrData, 1) + 1 To UBound(arrData, 1)
strLine = ""
strData = ""
For jCol = LBound(arrData, 2) To UBound(arrData, 2)
If IsError(arrData(iRow, jCol)) Then
strData = "#ERROR"
Else
strData = arrData(iRow, jCol)
strData = Replace(strData, Chr(34), Chr(39))
strData = Replace(strData, Chr(10), " ") ' removing line breaks is not RFC 4180 compliant
strData = Replace(strData, Chr(13), " ") ' ...but the Excel driver will break if we don't
strData = Replace(strData, Chr(9), " ")
strData = Trim(strData)
End If
strData = Chr(34) & strData & Chr(34) & "," ' Enclosing by quotes coerces all values to text
strLine = strLine & strData
Next jCol
strLine = Left(strLine, Len(strLine) - 1) ' Trim trailing comma
If Len(Replace(Replace(strLine, Chr(34), ""), ",", "")) > 0 Then
.writeline strLine
End If
Next iRow
.Close
End With ' textstream object from objFSO.OpenTextFile
Erase arrData
Set rng = Nothing
End Sub
Public Sub ArrayToFile(ByRef arrData As Variant, ByVal strName As String, Optional bTranspose As Boolean = False, Optional Header As String = "", Optional CoerceText As Boolean = True)
' Output an array to a csv file in a temporary folder created by the connText function
' arrRange is data from a range
' Note that the first row of the array is assumed to be a set of column names.
On Error Resume Next
Dim iRow As Long
Dim jCol As Long
Dim strData As String
Dim strLine As String
Dim strFile As String
Dim iOffset As Long
Dim arrHeaders As Variant
Dim i As Long
If objFSO Is Nothing Then
Exit Sub
End If
If Right(strName, 1) = "$" Then
strName = Left(strName, Len(strName) - 1)
End If
strFile = TempSQLFolder & strName & ".csv"
If objFSO.FileExists(strFile) Then
objFSO.DeleteFile strFile, True
End If
If objFSO.FileExists(strFile) Then
Exit Sub
End If
With objFSO.OpenTextFile(strFile, 2, True) ' ForReading = 1, ForWriting = 2, ForAppending = 8
' Header row:
strLine = ""
strData = ""
If Header <> "" Then
.writeline Header
iOffset = 0
If CoerceText Then
arrHeaders = Split(Header, ",")
For i = LBound(arrHeaders) To UBound(arrHeaders)
arrHeaders(i) = Chr(34) & "Type=Text" & Chr(34)
Next i
For i = 1 To 25
.writeline Join(arrHeaders, ",")
Next i
Erase arrHeaders
End If
Else
iOffset = 1
End If
If Not IsEmpty(arrData) Then
If bTranspose Then
If Header = "" Then
iRow = LBound(arrData, 1)
For jCol = LBound(arrData, 1) To UBound(arrData, 1)
If IsNull(arrData(jCol, iRow)) Then
strData = ""
ElseIf IsEmpty(arrData(jCol, iRow)) Then
strData = ""
Else
strData = arrData(jCol, iRow)
strData = Replace(strData, Chr(34), Chr(39))
strData = Replace(strData, Chr(10), " ")
strData = Replace(strData, Chr(13), " ")
If IsDate(strData) Then
strData = CDbl(CVDate(strData))
End If
End If
strData = strData & ","
strLine = strLine & strData
Next jCol
strLine = Left(strLine, Len(strLine) - 1) ' Trim trailing comma
If Len(Replace(Replace(strLine, Chr(34), ""), ",", "")) > 0 Then
.writeline strLine
End If
End If
' Rest of the data
For iRow = LBound(arrData, 2) + iOffset To UBound(arrData, 2)
strLine = ""
strData = ""
For jCol = LBound(arrData, 1) To UBound(arrData, 1)
If IsError(arrData(jCol, iRow)) Then
strData = "#ERROR"
ElseIf IsNull(arrData(jCol, iRow)) Then
strData = ""
ElseIf IsEmpty(arrData(jCol, iRow)) Then
strData = ""
Else
strData = arrData(jCol, iRow)
strData = Replace(strData, Chr(34), Chr(39))
strData = Replace(strData, Chr(10), " ") ' removing line breaks is not RFC 4180 compliant
strData = Replace(strData, Chr(13), " ") ' ...but the Excel driver will break if we don't
strData = Replace(strData, Chr(9), " ")
If IsDate(strData) Then
strData = CDbl(CVDate(strData))
End If
End If
strData = Trim(strData)
strData = Chr(34) & strData & Chr(34) & "," ' Enclosing by quotes coerces all values to text
strLine = strLine & strData
Next jCol
strLine = Left(strLine, Len(strLine) - 1) ' Trim trailing comma
If Len(Replace(Replace(strLine, Chr(34), ""), ",", "")) > 0 Then
.writeline strLine
End If
Next iRow
Else
If Header = "" Then
iRow = LBound(arrData, 1)
For jCol = LBound(arrData, 2) To UBound(arrData, 2)
If IsNull(arrData(iRow, jCol)) Then
strData = ""
ElseIf IsEmpty(arrData(iRow, jCol)) Then
strData = ""
Else
strData = arrData(iRow, jCol)
strData = Replace(strData, Chr(34), Chr(39))
strData = Replace(strData, Chr(10), " ")
strData = Replace(strData, Chr(13), " ")
If IsDate(strData) Then
strData = CDbl(CVDate(strData))
End If
End If
strData = strData & ","
strLine = strLine & strData
Next jCol
strLine = Left(strLine, Len(strLine) - 1) ' Trim trailing comma
If Len(Replace(Replace(strLine, Chr(34), ""), ",", "")) > 0 Then
.writeline strLine
End If
End If
' Rest of the data
For iRow = LBound(arrData, 1) + iOffset To UBound(arrData, 1)
strLine = ""
strData = ""
For jCol = LBound(arrData, 2) To UBound(arrData, 2)
If IsError(arrData(iRow, jCol)) Then
strData = "#ERROR"
ElseIf IsNull(arrData(iRow, jCol)) Then
strData = ""
ElseIf IsEmpty(arrData(iRow, jCol)) Then
strData = ""
Else
strData = arrData(iRow, jCol)
strData = Replace(strData, Chr(34), Chr(39))
strData = Replace(strData, Chr(10), " ") ' removing line breaks is not RFC 4180 compliant
strData = Replace(strData, Chr(13), " ") ' ...but the Excel driver will break if we don't
strData = Replace(strData, Chr(9), " ")
strData = Trim(strData)
If IsDate(strData) Then
strData = CDbl(CVDate(strData))
End If
End If
strData = Chr(34) & strData & Chr(34) & "," ' Enclosing by quotes coerces all values to text
strLine = strLine & strData
Next jCol
strLine = Left(strLine, Len(strLine) - 1) ' Trim trailing comma
If Len(Replace(Replace(strLine, Chr(34), ""), ",", "")) > 0 Then
.writeline strLine
End If
Next iRow
End If ' bTranspose
End If ' If Not IsEmpty(arrData) Then
.Close
End With ' textstream object from objFSO.OpenTextFile
End Sub
Public Function GetDataFromClosedWorkbook(ByVal SourceFile As String, _
ByVal SourceRange As String, _
Optional ByRef FieldNames As String = "", _
Optional ByVal ReadHeaders As Boolean = False, _
Optional ByVal LocalCopyLifetime As Double = 1#, _
Optional ByVal ForceRecopy As Boolean = False, _
Optional ByVal Asynchronous As Boolean = False) As Variant
Application.Volatile False
On Error GoTo ErrSub
' Read a Range in a closed workbook (which remains closed throughout the operation - we do not open the file in Excel)
' Returns a TRANSPOSED variant array, in which the first column will be the headers
' If your range is a worksheet, append "$" to the worksheet name
' If you set ReadHeaders=True, the first row of your data will be treated as the field names of a table; this means that you can pass
' a SQL query instead of a range or table name BUT the fierst row of your range will not be included in the returned variant array
' Note that we do not attempt to examine files on network folders: we always copy to a temporary folder
' - However, we'll only overwrite a pre-existing local copy if the pre-existing file is older than LocalCopyLifetime days
' - While the copy-to-local-folder operation in running in asynchronous mode, the function will return #WAITING FOR FILE TRANSFER
' Be warned, the ACE database drivers have serious stability issues and Excel will definitely crash a couple of times
' TO DO: modify parsing of 'Source Sheet' so that we can read a defined name or a range address
Dim objConnect As ADODB.Connection
Dim rst As ADODB.Recordset
Dim strConnect As String
Dim i As Long
Dim j As Long
Dim arrData As Variant
Dim TempFile As String
Dim strTest As String
Dim SQL As String
Dim iColCount As Long
Dim strPathFull As String
Dim strHeaders As String
If SourceFile = "" Then
Exit Function
End If
' Parse out web folder paths
If Left(SourceFile, 5) = "http:" Then
SourceFile = Right(SourceFile, Len(SourceFile) - 5)
SourceFile = Replace(SourceFile, "%20", " ")
SourceFile = Replace(SourceFile, "%160", " ")
SourceFile = Replace(SourceFile, "/", "\")
End If
strPathFull = SourceFile
If Len(Dir(SourceFile)) = 0 Then
GetDataFromClosedWorkbook = "#ERROR Source file not found"
Exit Function
End If
If objFSO Is Nothing Then
Exit Function
End If
TempFile = objFSO.GetSpecialFolder(2).Path & "\" & Filename(SourceFile)
If ForceRecopy Then
If Len(VBA.FileSystem.Dir(TempFile)) > 0 Then
VBA.FileSystem.Kill TempFile
End If
End If
If Not (Left(SourceFile, 3) = "C:\" Or Left(SourceFile, 3) = "D:\") Then
' Always copy to the local drive
If Len(VBA.FileSystem.Dir(TempFile)) > 0 Then
On Error Resume Next
If VBA.FileSystem.FileDateTime(TempFile) < VBA.FileSystem.FileDateTime(SourceFile) Then
VBA.FileSystem.Kill TempFile
ElseIf m_objFSO.GetFile(TempFile).dateLastAccessed < (Now - LocalCopyLifetime) Then
VBA.FileSystem.Kill TempFile
End If
End If
If Len(VBA.FileSystem.Dir(TempFile)) = 0 Then
If Asynchronous Then
Shell "cmd /c COPY " & Chr(34) & SourceFile & Chr(34) & " " & Chr(34) & TempFile & Chr(34), vbHide
GetDataFromClosedWorkbook = "#WAITING FOR FILE TRANSFER"
Exit Function
Else
VBA.FileSystem.FileCopy SourceFile, TempFile
End If
Else
SourceFile = TempFile
End If
End If
If InStr(1, SourceRange, "SELECT", vbTextCompare) > 0 And InStr(7, SourceRange, "FROM", vbTextCompare) > 1 Then
strHeaders = "HDR=Yes"
ElseIf ReadHeaders = True Then
strHeaders = "HDR=Yes"
Else
strHeaders = "HDR=No"
End If
' " & strHeaders & "
If Right(SourceFile, 4) = ".xls" Then '
' strConnect = "DRIVER={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & "ReadOnly=1;DBQ=" & Chr(34) & SourceFile & Chr(34) & ";" & ";Extended Properties=" & Chr(34) & "HDR=No;IMEX=1;MaxScanRows=0" & Chr(34) & ";"
strConnect = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Chr(34) & SourceFile & Chr(34) & ";Extended Properties=" & Chr(34) & "Excel 8.0;" & strHeaders & ";IMEX=1;MaxScanRows=0" & Chr(34) & ";"
'strConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Chr(34) & SourceFile & Chr(34) & ";Extended Properties=" & Chr(34) & "Excel 8.0;" & strHeaders & ";IMEX=1;MaxScanRows=0" & Chr(34) & ";"
ElseIf Right(SourceFile, 5) = ".xlsx" Then
strConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Chr(34) & SourceFile & Chr(34) & ";Extended Properties=" & Chr(34) & "Excel 12.0 Xml;" & strHeaders & ";IMEX=1;MaxScanRows=0" & Chr(34) & ";"
ElseIf Right(SourceFile, 5) = ".xlsm" Then
'strConnect = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & "ReadOnly=1;DBQ=" & SourceFile & ";" & Chr(34) & SourceFile & Chr(34) & ";" & ";Extended Properties=" & Chr(34) & "Excel 12.0;" & strHeaders & ";IMEX=1;MaxScanRows=0" & Chr(34) & ";"
strConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Chr(34) & SourceFile & Chr(34) & ";Extended Properties=" & Chr(34) & "Excel 12.0 Macro;" & strHeaders & ";IMEX=1;MaxScanRows=0" & Chr(34) & ";"
ElseIf Right(SourceFile, 5) = ".xlsb" Then
'strConnect = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & "ReadOnly=1;DBQ=" & SourceFile & ";" & Chr(34) & SourceFile & Chr(34) & ";" & ";Extended Properties=" & Chr(34) & "Excel 12.0;" & strHeaders & ";IMEX=1;MaxScanRows=0" & Chr(34) & ";"
' This ACE driver is unstable on xlsb files... But it's more likely to return a result, if you don't mind crashes:
strConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Chr(34) & SourceFile & Chr(34) & ";Extended Properties=" & Chr(34) & "Excel 12.0;" & strHeaders & ";IMEX=1;MaxScanRows=0" & Chr(34) & ";"
Else
GetDataFromClosedWorkbook = "#ERROR - file format not known"
End If
On Error GoTo ErrSub
'SetTypeGuessRows
Set objConnect = New ADODB.Connection
With objConnect
.ConnectionTimeout = 60
.CommandTimeout = 90
.Mode = adModeRead
.ConnectionString = strConnect
.Open
End With
Set rst = New ADODB.Recordset
With rst
.CacheSize = 8
.PageSize = 8
If InStr(1, SourceRange, "SELECT", vbTextCompare) > 0 And InStr(7, SourceRange, "FROM", vbTextCompare) > 1 Then
SQL = SourceRange
Else
.MaxRecords = 8192
SQL = "SELECT * FROM [" & SourceRange & "] "
End If
.Open SQL, objConnect, adOpenStatic, adLockReadOnly
End With
On Error Resume Next
For i = 0 To rst.Fields.Count - 1
FieldNames = FieldNames & rst.Fields(i).Name & ","
Next i
FieldNames = Left(FieldNames, Len(FieldNames) - 1)
If rst.EOF And rst.BOF Then
'no action
Else
Err.Clear
rst.MoveFirst
GetDataFromClosedWorkbook = rst.GetRows
If IsEmpty(GetDataFromClosedWorkbook) Then
rst.MoveFirst
GetDataFromClosedWorkbook = rst.GetRows
End If
If IsEmpty(GetDataFromClosedWorkbook) Then
rst.MoveFirst
ReDim arrTemp(0 To rst.Fields.Count - 1, 0 To rst.RecordCount)
i = 0
j = 0
Do Until rst.EOF
Err.Clear
If i > UBound(arrTemp, 2) Then
ReDim Preserve arrTemp(0 To rst.Fields.Count - 1, 0 To i)
End If
For j = 0 To rst.Fields.Count - 1
arrTemp(j, i) = rst.Fields(j).Value
If Err.Number = &HBCD Then
Exit For
End If
Next j
i = i + 1
If Err.Number <> &HBCD Then
rst.MoveNext
End If
If Err.Number <> &H80004005 And Err.Number <> 0 Then
Exit Do
End If
Loop
GetDataFromClosedWorkbook = arrTemp
Erase arrTemp
End If ' IsEmpty(GetDataFromClosedWorkbook)
End If ' rst.EOF And rst.BOF Then
ExitSub:
On Error Resume Next
rst.Close
objConnect.Close ' close the database connection
Set rst = Nothing
Set objConnect = Nothing
Exit Function
ErrSub:
If InStr(Err.Description, "not a valid name") Then
GetDataFromClosedWorkbook = "#ERROR '" & SourceRange & "' does not exist"
MsgBox "Cannot read the data from file: " & vbCrLf & vbCrLf & Err.Description & vbCrLf & vbCrLf & "It's possible that the file has been locked, but the most likely explanation is that the file doesn't contain the named sheet or range you're trying to read: check that you've saved the correct C7 report with the correct file name." & vbCrLf & vbCrLf & "If this error persists, please contact the Desktop Support team.", vbCritical, APP_NAME & ": data access error:"
ElseIf InStr(Err.Description, "Could not find the object '& SourceRange") Then
GetDataFromClosedWorkbook = "#ERROR '" & SourceRange & "' does not exist"
MsgBox Err.Description & vbCrLf & vbCrLf & "Please contact the Desktop Support team. This error probably means that source file is locked, or that the wrong file has been saved here: " & vbCrLf & vbCrLf & strPathFull, vbCritical, APP_NAME & ": file data error:"
ElseIf InStr(Err.Description, "Permission Denied") Then
GetDataFromClosedWorkbook = "#ERROR Access to file"
MsgBox "Cannot open the file: " & vbCrLf & vbCrLf & strPathFull & vbCrLf & vbCrLf & "Another user probably has this file open. Please wait a few minutes, and try again. If this error persists, please contact Desktop Support team.", vbCritical, APP_NAME & ": file access error:"
Else
GetDataFromClosedWorkbook = "#ERROR " & Err.Number & ": " & Err.Description
End If
Resume ExitSub
' # leave in place for debugging:
Resume
End Function
Public Function Filename(ByVal strPath As String) As String
strPath = Replace(strPath, "/", "\")
If strPath <> "" Then
Filename = StrReverse(Split(StrReverse(strPath), "\")(0))
End If
End Function
Public Function Folder(ByVal strPath As String) As String
strPath = Replace(strPath, "/", "\")
If strPath <> "" Then
Folder = Left(strPath, Len(strPath) - Len(Filename(strPath)))
End If
End Function
Public Sub SetTypeGuessRows()
On Error Resume Next ' necessary because there is no other way of checking the existence of a key
'http://msdn.microsoft.com/en-us/library/yfdfhz1b(v=vs.84).aspx
Dim objShell As Object
Set objShell = CreateObject("WScript.Shell")
Dim strKey As String
strKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Excel\ImportMixedTypes"
If objShell.RegRead(strKey) <> "Text" Then
objShell.RegWrite strKey, "Text", "REG_SZ"
End If
If objShell.RegRead(strKey) <> 0 Then
strKey = "HKEY_CURRENT_USER\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Excel\ImportMixedTypes"
objShell.RegWrite strKey, "Text", "REG_SZ"
strKey = "HKEY_CURRENT_CONFIG\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Excel\ImportMixedTypes"
objShell.RegWrite strKey, "Text", "REG_SZ"
End If
strKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Excel\TypeGuessRows"
If objShell.RegRead(strKey) <> 0 Then
objShell.RegWrite strKey, 0, "REG_DWORD"
End If
If objShell.RegRead(strKey) <> 0 Then
strKey = "HKEY_CURRENT_USER\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Excel\TypeGuessRows"
objShell.RegWrite strKey, 0, "REG_DWORD"
strKey = "HKEY_CURRENT_CONFIG\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Excel\TypeGuessRows"
objShell.RegWrite strKey, 0, "REG_DWORD"
End If
strKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Excel\MaxScanRows"
If objShell.RegRead(strKey) <> 0 Then
objShell.RegWrite strKey, 0, "REG_DWORD"
End If
If objShell.RegRead(strKey) <> 0 Then
strKey = "HKEY_CURRENT_USER\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Excel\MaxScanRows"
objShell.RegWrite strKey, 0, "REG_DWORD"
strKey = "HKEY_CURRENT_CONFIG\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Excel\MaxScanRows"
objShell.RegWrite strKey, 0, "REG_DWORD"
End If
strKey = "HKEY_LOCAL_MACHINE\Software\Microsoft\Jet\4.0\Engines\Excel\ImportMixedTypes"
If objShell.RegRead(strKey) <> "Text" Then
objShell.RegWrite strKey, "Text", "REG_SZ"
End If
If objShell.RegRead(strKey) <> 0 Then
strKey = "HKEY_CURRENT_USER\Software\Microsoft\Jet\4.0\Engines\Excel\ImportMixedTypes"
objShell.RegWrite strKey, "Text", "REG_SZ"
strKey = "HKEY_CURRENT_CONFIG\Software\Microsoft\Jet\4.0\Engines\Excel\ImportMixedTypes"
objShell.RegWrite strKey, "Text", "REG_SZ"
End If
strKey = "HKEY_LOCAL_MACHINE\Software\Microsoft\Jet\4.0\Engines\Excel\TypeGuessRows"
If objShell.RegRead(strKey) <> 0 Then
objShell.RegWrite strKey, 0, "REG_DWORD"
End If
If objShell.RegRead(strKey) <> 0 Then
strKey = "HKEY_CURRENT_USER\Software\Microsoft\Jet\4.0\Engines\Excel\TypeGuessRows"
objShell.RegWrite strKey, 0, "REG_DWORD"
strKey = "HKEY_CURRENT_CONFIG\Software\Microsoft\Jet\4.0\Engines\Excel\TypeGuessRows"
objShell.RegWrite strKey, 0, "REG_DWORD"
End If
strKey = "HKEY_LOCAL_MACHINE\Software\Microsoft\Jet\4.0\Engines\Excel\MaxScanRows"
If objShell.RegRead(strKey) <> 0 Then
objShell.RegWrite strKey, 0, "REG_DWORD"
End If
If objShell.RegRead(strKey) <> 0 Then
strKey = "HKEY_CURRENT_USER\Software\Microsoft\Jet\4.0\Engines\Excel\MaxScanRows"
objShell.RegWrite strKey, 0, "REG_DWORD"
strKey = "HKEY_CURRENT_CONFIG\Software\Microsoft\Jet\4.0\Engines\Excel\MaxScanRows"
objShell.RegWrite strKey, 0, "REG_DWORD"
End If
strKey = "HKEY_LOCAL_MACHINE\Software\Microsoft\Jet\4.0\Engines\Text\ImportMixedTypes"
If objShell.RegRead(strKey) <> "Text" Then
objShell.RegWrite strKey, "Text", "REG_SZ"
End If
If objShell.RegRead(strKey) <> 0 Then
strKey = "HKEY_CURRENT_USER\Software\Microsoft\Jet\4.0\Engines\Text\ImportMixedTypes"
objShell.RegWrite strKey, "Text", "REG_SZ"
strKey = "HKEY_CURRENT_CONFIG\Software\Microsoft\Jet\4.0\Engines\Text\ImportMixedTypes"
objShell.RegWrite strKey, "Text", "REG_SZ"
End If
strKey = "HKEY_LOCAL_MACHINE\Software\Microsoft\Jet\4.0\Engines\Text\TypeGuessRows"
If objShell.RegRead(strKey) <> 0 Then
objShell.RegWrite strKey, 0, "REG_DWORD"
End If
If objShell.RegRead(strKey) <> 0 Then
strKey = "HKEY_CURRENT_USER\Software\Microsoft\Jet\4.0\Engines\Text\TypeGuessRows"
objShell.RegWrite strKey, 0, "REG_DWORD"
strKey = "HKEY_CURRENT_CONFIG\Software\Microsoft\Jet\4.0\Engines\Text\TypeGuessRows"
objShell.RegWrite strKey, 0, "REG_DWORD"
End If
strKey = "HKEY_LOCAL_MACHINE\Software\Microsoft\Jet\4.0\Engines\Text\MaxScanRows"
If objShell.RegRead(strKey) <> 0 Then
objShell.RegWrite strKey, 0, "REG_DWORD"
End If
If objShell.RegRead(strKey) <> 0 Then
strKey = "HKEY_CURRENT_USER\Software\Microsoft\Jet\4.0\Engines\Text\MaxScanRows"
objShell.RegWrite strKey, 0, "REG_DWORD"
strKey = "HKEY_CURRENT_CONFIG\Software\Microsoft\Jet\4.0\Engines\Text\MaxScanRows"
objShell.RegWrite strKey, 0, "REG_DWORD"
End If
strKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Excel\ImportMixedTypes"
If objShell.RegRead(strKey) <> "Text" Then
objShell.RegWrite strKey, "Text", "REG_SZ"
End If
If objShell.RegRead(strKey) <> 0 Then
strKey = "HKEY_CURRENT_USER\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Excel\ImportMixedTypes"
objShell.RegWrite strKey, "Text", "REG_SZ"
strKey = "HKEY_CURRENT_CONFIG\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Excel\ImportMixedTypes"
objShell.RegWrite strKey, "Text", "REG_SZ"
End If
strKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Excel\TypeGuessRows"
If objShell.RegRead(strKey) <> 0 Then
objShell.RegWrite strKey, 0, "REG_DWORD"
End If
If objShell.RegRead(strKey) <> 0 Then
strKey = "HKEY_CURRENT_USER\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Excel\TypeGuessRows"
objShell.RegWrite strKey, 0, "REG_DWORD"
strKey = "HKEY_CURRENT_CONFIG\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Excel\TypeGuessRows"
objShell.RegWrite strKey, 0, "REG_DWORD"
End If
strKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Excel\MaxScanRows"
If objShell.RegRead(strKey) <> 0 Then
objShell.RegWrite strKey, 0, "REG_DWORD"
End If
If objShell.RegRead(strKey) <> 0 Then
strKey = "HKEY_CURRENT_USER\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Excel\MaxScanRows"
objShell.RegWrite strKey, 0, "REG_DWORD"
strKey = "HKEY_CURRENT_CONFIG\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Excel\MaxScanRows"
objShell.RegWrite strKey, 0, "REG_DWORD"
End If
strKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Text\ImportMixedTypes"
If objShell.RegRead(strKey) <> "Text" Then
objShell.RegWrite strKey, "Text", "REG_SZ"
End If
If objShell.RegRead(strKey) <> 0 Then
strKey = "HKEY_CURRENT_USER\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Text\ImportMixedTypes"
objShell.RegWrite strKey, "Text", "REG_SZ"
strKey = "HKEY_CURRENT_CONFIG\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Text\ImportMixedTypes"
objShell.RegWrite strKey, "Text", "REG_SZ"
End If
strKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Text\TypeGuessRows"
If objShell.RegRead(strKey) <> 0 Then
objShell.RegWrite strKey, 0, "REG_DWORD"
End If
If objShell.RegRead(strKey) <> 0 Then
strKey = "HKEY_CURRENT_USER\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Text\TypeGuessRows"
objShell.RegWrite strKey, 0, "REG_DWORD"
strKey = "HKEY_CURRENT_CONFIG\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Text\TypeGuessRows"
objShell.RegWrite strKey, 0, "REG_DWORD"
End If
strKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Text\MaxScanRows"
If objShell.RegRead(strKey) <> 0 Then
objShell.RegWrite strKey, 0, "REG_DWORD"
End If
If objShell.RegRead(strKey) <> 0 Then
strKey = "HKEY_CURRENT_USER\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Text\MaxScanRows"
objShell.RegWrite strKey, 0, "REG_DWORD"
strKey = "HKEY_CURRENT_CONFIG\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Text\MaxScanRows"
objShell.RegWrite strKey, 0, "REG_DWORD"
End If
strKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Text\ImportMixedTypes"
If objShell.RegRead(strKey) <> "Text" Then
objShell.RegWrite strKey, "Text", "REG_SZ"
End If
If objShell.RegRead(strKey) <> 0 Then
strKey = "HKEY_CURRENT_USER\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Text\ImportMixedTypes"
objShell.RegWrite strKey, "Text", "REG_SZ"
strKey = "HKEY_CURRENT_CONFIG\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Text\ImportMixedTypes"
objShell.RegWrite strKey, "Text", "REG_SZ"
End If
strKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Text\TypeGuessRows"
If objShell.RegRead(strKey) <> 0 Then
objShell.RegWrite strKey, 0, "REG_DWORD"
End If
If objShell.RegRead(strKey) <> 0 Then
strKey = "HKEY_CURRENT_USER\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Text\TypeGuessRows"
objShell.RegWrite strKey, 0, "REG_DWORD"
strKey = "HKEY_CURRENT_CONFIG\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Text\TypeGuessRows"
objShell.RegWrite strKey, 0, "REG_DWORD"
End If
strKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Text\MaxScanRows"
If objShell.RegRead(strKey) <> 0 Then
objShell.RegWrite strKey, 0, "REG_DWORD"
End If
If objShell.RegRead(strKey) <> 0 Then
strKey = "HKEY_CURRENT_USER\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Text\MaxScanRows"
objShell.RegWrite strKey, 0, "REG_DWORD"
strKey = "HKEY_CURRENT_CONFIG\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Text\MaxScanRows"
objShell.RegWrite strKey, 0, "REG_DWORD"
End If
Set objShell = Nothing
End Sub
</PRE>
<BR /><BR />
<BR /><BR />
You will also need basArrays, a grab bag of array-handling utilities. I've posted the full set elsewhere, but these are the array functions in use in the code above:
<BR /><BR />
<PRE>
Option Explicit
Option Private Module
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Any, _
Source As Any, _
ByVal Length As Long)
Public Sub ArrayToRange(rngTarget As Excel.Range, InputArray As Variant)
' Write an array to an Excel range in a single 'hit' to the sheet
' InputArray must be a 2-Dimensional structure of the form Variant(Rows, Columns)
' The target range is resized automatically to the dimensions of the array, with
' the top left cell used as the start point.
' This subroutine saves repetitive coding for a common VBA and Excel task.
' If you think you won't need the code that works around common errors (long strings
' and objects in the array, etc) then feel free to comment them out.
On Error Resume Next
'
' Author: Nigel Heffernan Http://Excellerando.blogspot.com
'
'
' This code is in the public domain: take care to mark it clearly, and segregate
' it from proprietary code if you intend to assert intellectual property rights
' or impose commercial confidentiality restrictions on your proprietary code
Dim rngOutput As Excel.Range
Dim iRowCount As Long
Dim iColCount As Long
Dim iRow As Long
Dim iCol As Long
Dim arrTemp As Variant
Dim iDimensions As Integer
Dim iRowOffset As Long
Dim iColOffset As Long
Dim iStart As Long
Application.EnableEvents = False
If rngTarget.Cells.Count > 1 Then
rngTarget.ClearContents
End If
Application.EnableEvents = True
If IsEmpty(InputArray) Then
Exit Sub
End If
If TypeName(InputArray) = "Range" Then
InputArray = InputArray.Value
End If
' Is it actually an array? IsArray is sadly broken so...
If InStr(TypeName(InputArray), "(") < 1 Then
rngTarget.Cells(1, 1).Value2 = InputArray
Exit Sub
End If
iDimensions = ArrayDimensions(InputArray)
If iDimensions < 1 Then
rngTarget.Value = CStr(InputArray)
ElseIf iDimensions = 1 Then
iRowCount = UBound(InputArray) - LBound(InputArray)
iStart = LBound(InputArray)
iColCount = 1
If iRowCount > (655354 - rngTarget.Row) Then
iRowCount = 655354 + iStart - rngTarget.Row
ReDim Preserve InputArray(iStart To iRowCount)
End If
iRowCount = UBound(InputArray) - LBound(InputArray)
iColCount = 1
' It's a vector. Yes, I asked for a 2-Dimensional array. But I'm feeling generous.
' By convention, a vector is presented in Excel as an array of 1 to n rows and 1 column.
ReDim arrTemp(LBound(InputArray, 1) To UBound(InputArray, 1), 1 To 1)
For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)
arrTemp(iRow, 1) = InputArray(iRow)
Next
With rngTarget.Worksheet
Set rngOutput = .Range(rngTarget.Cells(1, 1), rngTarget.Cells(iRowCount + 1, iColCount))
rngOutput.Value2 = arrTemp
Set rngTarget = rngOutput
End With
Erase arrTemp
ElseIf iDimensions = 2 Then
iRowCount = UBound(InputArray, 1) - LBound(InputArray, 1)
iColCount = UBound(InputArray, 2) - LBound(InputArray, 2)
iStart = LBound(InputArray, 1)
If iRowCount > (65534 - rngTarget.Row) Then
iRowCount = 65534 - rngTarget.Row
InputArray = ArrayTranspose(InputArray)
ReDim Preserve InputArray(LBound(InputArray, 1) To UBound(InputArray, 1), iStart To iRowCount)
InputArray = ArrayTranspose(InputArray)
End If
iStart = LBound(InputArray, 2)
If iColCount > (254 - rngTarget.Column) Then
ReDim Preserve InputArray(LBound(InputArray, 1) To UBound(InputArray, 1), iStart To iColCount)
End If
With rngTarget.Worksheet
Set rngOutput = .Range(rngTarget.Cells(1, 1), rngTarget.Cells(iRowCount + 1, iColCount + 1))
Err.Clear
Application.EnableEvents = False
rngOutput.Value2 = InputArray
Application.EnableEvents = True
If Err.Number <> 0 Then
For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)
For iCol = LBound(InputArray, 2) To UBound(InputArray, 2)
If IsNumeric(InputArray(iRow, iCol)) Then
' no action
Else
InputArray(iRow, iCol) = "" & InputArray(iRow, iCol)
InputArray(iRow, iCol) = Trim(InputArray(iRow, iCol))
End If
Next iCol
Next iRow
Err.Clear
rngOutput.Formula = InputArray
End If 'err<>0
If Err <> 0 Then
For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)
For iCol = LBound(InputArray, 2) To UBound(InputArray, 2)
If IsNumeric(InputArray(iRow, iCol)) Then
' no action
Else
If Left(InputArray(iRow, iCol), 1) = "=" Then
InputArray(iRow, iCol) = "'" & InputArray(iRow, iCol)
End If
If Left(InputArray(iRow, iCol), 1) = "+" Then
InputArray(iRow, iCol) = "'" & InputArray(iRow, iCol)
End If
If Left(InputArray(iRow, iCol), 1) = "*" Then
InputArray(iRow, iCol) = "'" & InputArray(iRow, iCol)
End If
End If
Next iCol
Next iRow
Err.Clear
rngOutput.Value2 = InputArray
End If 'err<>0
If Err <> 0 Then
For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)
For iCol = LBound(InputArray, 2) To UBound(InputArray, 2)
If IsObject(InputArray(iRow, iCol)) Then
InputArray(iRow, iCol) = "[OBJECT] " & TypeName(InputArray(iRow, iCol))
ElseIf IsArray(InputArray(iRow, iCol)) Then
InputArray(iRow, iCol) = Split(InputArray(iRow, iCol), ",")
ElseIf IsNumeric(InputArray(iRow, iCol)) Then
' no action
Else
InputArray(iRow, iCol) = "" & InputArray(iRow, iCol)
If Len(InputArray(iRow, iCol)) > 255 Then
' Block-write operations fail on strings exceeding 255 chars. You *have*
' to go back and check, and write this masterpiece one cell at a time...
InputArray(iRow, iCol) = Left(Trim(InputArray(iRow, iCol)), 255)
End If
End If
Next iCol
Next iRow
Err.Clear
rngOutput.Text = InputArray
End If 'err<>0
If Err <> 0 Then
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
iRowOffset = LBound(InputArray, 1) - 1
iColOffset = LBound(InputArray, 2) - 1
For iRow = 1 To iRowCount
If iRow Mod 100 = 0 Then
Application.StatusBar = "Filling range... " & CInt(100# * iRow / iRowCount) & "%"
End If
For iCol = 1 To iColCount
rngOutput.Cells(iRow, iCol) = InputArray(iRow + iRowOffset, iCol + iColOffset)
Next iCol
Next iRow
Application.StatusBar = False
Application.ScreenUpdating = True
End If 'err<>0
Set rngTarget = rngOutput ' resizes the range This is useful, *most* of the time
End With ' rngTarget.Worksheet
End If ' iDimensions
End Sub
Public Function ArrayTranspose(InputArray As Variant) As Variant
Dim arrOutput As Variant
Dim i As Long
Dim j As Long
Dim iMin As Long
Dim iMax As Long
Dim jMin As Long
Dim jMax As Long
iMin = LBound(InputArray, 1)
iMax = UBound(InputArray, 1)
jMin = LBound(InputArray, 2)
jMax = UBound(InputArray, 2)
ReDim arrOutput(jMin To jMax, iMin To iMax)
For i = iMin To iMax
For j = jMin To jMax
arrOutput(j, i) = InputArray(i, j)
Next j
Next i
ArrayTranspose = arrOutput
End Function
Private Function ArrayDimensions(arr As Variant) As Integer
'-----------------------------------------------------------------
' will return:
' -1 if not an array
' 0 if an un-dimmed array
' 1 or more indicating the number of dimensions of a dimmed array
'-----------------------------------------------------------------
' Retrieved from Chris Rae's VBA Code Archive - http://chrisrae.com/vba
' Code written by Chris Rae, 25/5/00
' Originally published by R. B. Smissaert.
' Additional credits to Bob Phillips, Rick Rothstein, and Thomas Eyde on VB2TheMax
Dim ptr As Long
Dim vType As Integer
Const VT_BYREF = &H4000&
'get the real VarType of the argument
'this is similar to VarType(), but returns also the VT_BYREF bit
CopyMemory vType, arr, 2
'exit if not an array
If (vType And vbArray) = 0 Then
ArrayDimensions = -1
Exit Function
End If
'get the address of the SAFEARRAY descriptor
'this is stored in the second half of the
'Variant parameter that has received the array
CopyMemory ptr, ByVal VarPtr(arr) + 8, 4
'see whether the routine was passed a Variant
'that contains an array, rather than directly an array
'in the former case ptr already points to the SA structure.
'Thanks to Monte Hansen for this fix
If (vType And VT_BYREF) Then
' ptr is a pointer to a pointer
CopyMemory ptr, ByVal ptr, 4
End If
'get the address of the SAFEARRAY structure
'this is stored in the descriptor
'get the first word of the SAFEARRAY structure
'which holds the number of dimensions
'...but first check that saAddr is non-zero, otherwise
'this routine bombs when the array is uninitialized
If ptr Then
CopyMemory ArrayDimensions, ByVal ptr, 2
End If
End Function
Public Function TableLookup(TableRange As Excel.Range, Optional ColumnLabel As String = "", Optional RowLabel As Variant = "", Optional IndexColumn As Long = 1, Optional Compare As VbCompareMethod = vbTextCompare) As Excel.Range
Application.Volatile False
On Error GoTo ErrSub
' For a contiguous data range having column labels in Row 1, return:
' The data range, excluding the header row, if no column and row labels are specified;
' The named data column, excluding the header, if a column label is supplied;
' The labelled data row, if a row label is supplied;
' The first data cell matching the column and row label, if both are supplied.
' The 'index' column containing data row labels is assumed to be 1 (the leftmost column) unless specified by IndexColumn
' If you're calling this repeatedly, consider coding up an indexed
' array with Scripting.Dictionary objects as row & column indices.
Dim rngData As Excel.Range
Dim rngCol As Excel.Range
Dim rngRow As Excel.Range
Dim rngCell As Excel.Range
Dim iRow As Long
Dim iCol As Long
Dim iRowCount As Long
Dim iColCount As Long
Dim arrColLabel As Variant
Dim arrRowLabel As Variant
iRowCount = TableRange.Rows.Count
iColCount = TableRange.Columns.Count
If iRowCount = 0 Then
Exit Function
End If
' Check for invalid Index column
If IndexColumn > TableRange.Worksheet.Columns.Count - TableRange.Column Then 'column is off the Right-Hand edge of the sheet
Err.Raise -1430594559, ThisWorkbook.VBProject.Name & ":" & "You can't specify column " & IndexColumn & " of your data range, it's off the right-hand edge of the worksheet." & vbCrLf & vbCrLf & "Please check your data range and your index column."
ElseIf IndexColumn + TableRange.Column < 1 Then 'column is off the Left-Hand edge of the sheet
Err.Raise -1430594559, ThisWorkbook.VBProject.Name & ":" & "You can't specify column " & IndexColumn & " of your data range, it's off the left-hand edge worksheet." & vbCrLf & vbCrLf & "Please check your data range and your index column."
End If
Set rngData = TableRange.Worksheet.Range(TableRange.Cells(2, 1), TableRange.Cells(iRowCount, iColCount))
' Orthogonal branches: however we do this, there will be some duplicated code
' This is coded up for readability: feel free to refactor for performance and
' remove any code you consider redundant - but *you* maintain it afterwards
If ColumnLabel = "" And RowLabel = "" Then
Set TableLookup = rngData
ElseIf ColumnLabel <> "" And RowLabel = "" Then ' return a column of data
arrColLabel = TableRange.Rows(1).Value2
For iCol = 1 To iColCount
If VBA.Strings.StrComp(ColumnLabel, arrColLabel(1, iCol), Compare) = 0 Then
Exit For
End If
Next iCol
Erase arrColLabel
If iCol > iColCount Then
Err.Raise -1430594559, ThisWorkbook.VBProject.Name & ":" & "TableName()", "The label '" & ColumnLabel & "' does not match anything in the header row of your data table '" & TableRange.Worksheet.Name & "!" & TableRange.Address & "'" & vbCrLf & vbCrLf & "Please check your data range and the column label"
Else
Set TableLookup = rngData.Columns(iCol)
End If
ElseIf ColumnLabel = "" And RowLabel <> "" Then ' return a row of data
arrRowLabel = rngData.Cols(IndexColumn).Value2
For iRow = 1 To iRowCount - 1
If IsNumeric(RowLabel) And IsNumeric(arrRowLabel(iRow, 1)) Then
'Numeric Comparison
If CDbl(RowLabel) = CDbl(arrRowLabel(iRow, 1)) Then
Exit For
End If
ElseIf IsDate(RowLabel) And IsDate(arrRowLabel(iRow, 1)) Then
' Date comparison
If CVDate(RowLabel) = CVDate(arrRowLabel(iRow, 1)) Then
Exit For
End If
Else
' string comparison
If VBA.Strings.StrComp(RowLabel, arrRowLabel(iRow, 1), Compare) = 0 Then
Exit For
End If
End If
Next iRow
Erase arrColLabel
If iRow >= iRowCount Then
Err.Raise -1160664095, ThisWorkbook.VBProject.Name & ":" & "TableName()", "The label '" & RowLabel & "' does not match anything in column " & IndexColumn & " of your data table '" & TableRange.Worksheet.Name & "!" & TableRange.Address & "'" & vbCrLf & vbCrLf & "Please check your data range and the row label"
Else
Set TableLookup = rngData.Rows(iRow)
End If
ElseIf ColumnLabel <> "" And RowLabel <> "" Then ' return a cell of data
arrColLabel = TableRange.Rows(1).Value2
For iCol = 1 To iColCount
If VBA.Strings.StrComp(ColumnLabel, arrColLabel(1, iCol), Compare) = 0 Then
Exit For
End If
Next iCol
Erase arrColLabel
If iCol > iColCount Then
Err.Raise -1430594559, ThisWorkbook.VBProject.Name & ":" & "TableName()", "The label '" & ColumnLabel & "' does not match anything in the header row of your data table '" & TableRange.Worksheet.Name & "!" & TableRange.Address & "'" & vbCrLf & vbCrLf & "Please check your data range and the column label"
End If
arrRowLabel = rngData.Cols(IndexColumn).Value2
For iRow = 1 To iRowCount - 1
If IsNumeric(RowLabel) And IsNumeric(arrRowLabel(iRow, 1)) Then
'Numeric Comparison
If CDbl(RowLabel) = CDbl(arrRowLabel(iRow, 1)) Then
Exit For
End If
ElseIf IsDate(RowLabel) And IsDate(arrRowLabel(iRow, 1)) Then
' Date comparison
If CVDate(RowLabel) = CVDate(arrRowLabel(iRow, 1)) Then
Exit For
End If
Else
' string comparison
If VBA.Strings.StrComp(RowLabel, arrRowLabel(iRow, 1), Compare) = 0 Then
Exit For
End If
End If
Next iRow
Erase arrColLabel
If iRow >= iRowCount Then
Err.Raise -1160664095, ThisWorkbook.VBProject.Name & ":" & "TableName()", "The label '" & RowLabel & "' does not match anything in column " & IndexColumn & " of your data table '" & TableRange.Worksheet.Name & "!" & TableRange.Address & "'" & vbCrLf & vbCrLf & "Please check your data range and the row label"
Else
Set TableLookup = rngData.Cells(iRow, iCol)
End If
End If
ExitSub:
Exit Function
ErrSub:
If Err.HelpContext = 0 Then
MsgBox "Error 0x" & UCase(Hex(Err.Number)) & ": " & Err.Description, vbExclamation + vbMsgBoxHelpButton, "Error in " & Err.Source
Else
MsgBox "Error 0x" & UCase(Hex(Err.Number)) & ": " & Err.Description, vbExclamation + vbMsgBoxHelpButton, "Error in " & Err.Source, Err.HelpFile, Err.HelpContext
End If
Resume ExitSub
Resume
End Function
</PRE>
<BR /><BR />
<BR /><BR />Nigel Heffernanhttp://www.blogger.com/profile/08954578765691578714noreply@blogger.com0tag:blogger.com,1999:blog-1800518423097919889.post-92103728147821533622014-09-18T11:37:00.001+01:002014-09-18T11:37:15.985+01:00Identifying The Time Zone in VBA, With Daylight SavingI've blogged about this elsewhere, but here's a short piece of code to extract the named time zone in VBA, and tell you your Daylight Saving status.<BR /><BR />
This particular function just returns a descriptive string; but the UTC offset in hours or minutes is available in the code, too.<BR /><BR />
Note the use of WMI Script: Windows Management Interface is quite chewy, and bloggers like 'Hey Scripting Guy!' who can explain it well are few and far between. I don't generally use it unless I have to because it is effectively undocumented, and therefore best left to a community of experts who are immersed in the 'folklore' of code that you can only learn from mistakes and shared knowledge. That, and it's slow.
<BR /><BR />
<PRE>
Public Function TimeZone() As String
Application.Volatile False
' returns a full descriptive string for the workstation's time zone
Dim objWMIService As Object
Dim objWin32_TimeZone As Object
Dim objWin32_ComputerSystem As Object
Dim strDescription As String
Dim strStandardName As String
Dim strDaylightName As String
Dim lngDaylightMins As Long
Dim lngUToffsetMins As Long
Dim boolDaylightInEffect As Boolean
Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
For Each objWin32_TimeZone In objWMIService.ExecQuery("Select * from Win32_TimeZone")
strDescription = objWin32_TimeZone.Description
strStandardName = objWin32_TimeZone.StandardName
strDaylightName = objWin32_TimeZone.DaylightName
TimeZone = ""
lngDaylightMins = objWin32_TimeZone.DaylightBias
For Each objWin32_ComputerSystem In objWMIService.ExecQuery("Select * From Win32_ComputerSystem")
boolDaylightInEffect = objWin32_ComputerSystem.DaylightInEffect
lngUToffsetMins = objWin32_ComputerSystem.CurrentTimeZone
Next objWin32_ComputerSystem
If boolDaylightInEffect = False Then
TimeZone = strDescription & " (" & strStandardName & ")"
ElseIf lngDaylightMins = -60 Then
TimeZone = strDescription & " with daylight saving: '" & strDaylightName & "' as " & strStandardName & " + 1 hour"
ElseIf lngDaylightMins < 0 Then
TimeZone = strDescription & " with daylight saving: '" & strDaylightName & "' as " & strStandardName & " + " & -1 * lngDaylightMins / 60 & " hours"
ElseIf lngDaylightMins > 0 Then
TimeZone = strDescription & " with daylight saving: '" & strDaylightName & "' as " & strStandardName & " - " & lngDaylightMins / 60 & " hours"
ElseIf lngDaylightMins = 60 Then
TimeZone = strDescription & " with daylight saving: '" & strDaylightName & "' as " & strStandardName & " - 1 hour"
End If
If boolDaylightInEffect = False Then
' no further action: name is UTC
ElseIf lngUToffsetMins = 60 Then
TimeZone = "UTC + 1 hour" & ": " & TimeZone & ""
ElseIf lngUToffsetMins = -60 Then
TimeZone = "UTC - 1 hour" & ": " & TimeZone & ""
ElseIf lngUToffsetMins > 0 Then
TimeZone = "UTC + " & lngUToffsetMins / 60 & " hours" & ":" & TimeZone & ""
ElseIf lngUToffsetMins < 0 Then
TimeZone = "UTC - " & -1 * lngUToffsetMins / 60 & " hours" & ": " & TimeZone & ""
End If
Next
End Function
</PRE>Nigel Heffernanhttp://www.blogger.com/profile/08954578765691578714noreply@blogger.com0tag:blogger.com,1999:blog-1800518423097919889.post-71535268236162185822014-09-18T11:23:00.000+01:002014-09-18T11:23:29.760+01:00VBA to check 'User is in group'It's a common question: is the user in this group? Or rather: is the user allowed to do this?
<BR /><BR />
Now VBA and Excel are *not* secure platforms, so you really shouldn't use this for sensitive information and operations - get this set up properly at the database, or in the target application - but you may well be using NT groups, quite legitimately, to direct your users into different tasks and data sets, rather than using Excel as the security layer.
<BR /><BR />
I'm pretty sure I've posted this on StackOverflow, some or other year ago; but this is as good a place for it as any.
<BR /><BR />
I've attached a User Long Name function, because you'll almost always find yourself using this in applications that are aware of the user's network ID.
<BR /><BR />
As always, watch out for Blogspot rendering an unwanted line break.
<BR /><BR />
<PRE>
Public Function UserIsInGroup(GroupName As String, Optional Username As String, Optional Domain As String) As Boolean
' Returns TRUE if the user is in the named NT Group.
' If user name is omitted, current logged-in user's login name is assumed.
' If domain is omitted, current logged-in user's domain is assumed.
' User name can be submitted in the form 'NETWORK/UserName' - this will run slightly faster
' Does not raise errors for unknown user: they are not in the group and the function returns false.
'
' Sample Usage: UserIsInGroup( "Domain Users" )
Dim strUsername As String
Dim objGroup As Object
Dim objUser As Object
Dim objNetwork As Object
UserIsInGroup = False
If Username = "" Then
Set objNetwork = CreateObject("WScript.Network")
strUsername = objNetwork.UserDomain & "/" & objNetwork.Username
Else
strUsername = Username
End If
strUsername = Replace(strUsername, "\", "/")
If InStr(strUsername, "/") Then
' No action: Domain has already been supplied in the user name
Else
If Domain = "" Then
Set objNetwork = CreateObject("WScript.Network")
Domain = objNetwork.UserDomain
End If
strUsername = Domain & "/" & strUsername
End If
Set objUser = GetObject("WinNT://" & strUsername & ",user")
If objUser Is Nothing Then
' Insert error-handler here if you want to report an unknown user name
Else
For Each objGroup In objUser.Groups
If GroupName = "" Then
Debug.Print objGroup.Name
End If
If GroupName = objGroup.Name Then
UserIsInGroup = True
Exit For
End If
Next objGroup
End If
Set objNetwork = Nothing
Set objGroup = Nothing
Set objUser = Nothing
End Function
Public Function UserLongName(ByVal strUserID As String) As String
Application.Volatile False
On Error GoTo ErrSub
Dim strDomain As String
If strUserID = "" Then
Exit Function
End If
If InStr(2, strUserID, "(", vbBinaryCompare) > 0 Then
Exit Function
End If
strUserID = Replace(strUserID, "\", "/")
If InStr(strUserID, "/") Then
UserLongName = GetObject("WinNT://" & strUserID).FullName
Else
strDomain = CreateObject("wscript.Network").UserDomain
UserLongName = GetObject("WinNT://" & strDomain & "/" & strUserID).FullName
End If
ExitSub:
Exit Function
ErrSub:
Resume ExitSub
End Function
</PRE>Nigel Heffernanhttp://www.blogger.com/profile/08954578765691578714noreply@blogger.com0tag:blogger.com,1999:blog-1800518423097919889.post-70206659370958861562014-09-01T16:55:00.000+01:002014-09-17T17:20:45.911+01:00An automated 'Copy down' for the formulas in the top row of a range
Here's a common case: you have a regular data import into a sheet, and the columns to the right of the 'landing pad' contain formulae performing calculations on that data.
<BR /><BR />
However, this calculation only needs to be performed once, it's the same for every row, and you don't want it dragging down the performance of the whole workbook when you recalculate it for unrelated data updates...
<BR /><BR />
...So you take the formulae in the first row, copy them down, calculate the lot, and replace all those copied-down formulae with the results as static values.
<BR /><BR />
Not included here: the number of rows varies, so you need to vary the depth of the adjacent calculation range.
<BR /><BR />
<BR /><BR />
<PRE>
Attribute VB_Name = "basCopyCalc"
Option Explicit
' Nigel Heffernan Jan 2009
' Proof-of-concept for an enhanced 'CopyDown' macro
Public Sub CopyCalc(TargetRange As Excel.Range, _
Optional NoRecopy As Boolean = False, _
Optional SkipHeader As Boolean = False, _
Optional SuppressErrors As Boolean = False)
' Copy the formulae in the first row into all rows of the range
' Calculate the entire range
' Overwrite all formulae in the range (except for the first row) with the calculated values
' NoRecopy: The overwrite with static values is skipped if the optional NoRecopy parameter is set TRUE
' SkipHeader: Common 'use-case' of a range being a table with a header row, and the first row of formulae being row 2
' SuppressErrors: You are strongly advised to set this TRUE whenever VBA user-defined functions are present in the formulae
' Note that noncontiguous ranges will be processed one area at a time, with each subrange copying down its own first row
If SuppressErrors Then
On Error GoTo ErrSub
Else
On Error Resume Next
End If
Dim lngXLCalculation As Excel.XlCalculation
Dim boolScreenUpdate As Boolean
Dim boolEnableEvents As Boolean
Dim rng As Excel.Range
Dim lngRow As Long
If TargetRange Is Nothing Then
Exit Sub
End If
If SkipHeader = True Then
lngRow = 2
Else
lngRow = 1
End If
boolScreenUpdate = Application.ScreenUpdating
boolEnableEvents = Application.EnableEvents
If Application.Calculation <> xlCalculationManual Then
Application.Calculation = xlCalculationManual
End If
If Application.EnableEvents = True Then
Application.EnableEvents = False
End If
For Each rng In TargetRange.Areas
With rng
If .Rows.Count > 1024 Then
If Application.ScreenUpdating = True Then
Application.ScreenUpdating = False
End If
End If
If .Rows.Count > lngRow Then
' Copy down formulae
.Formula = .Rows(lngRow).Formula
.Calculate
' Overwrite with static values
If Not NoRecopy Then
.Worksheet.Range(.Cells(lngRow + 1, 1), .Cells(.Rows.Count, .Columns.Count)).Value2 = .Worksheet.Range(.Cells(lngRow + 1, 1), .Cells(.Rows.Count, .Columns.Count)).Value2
End If
End If
End With
Next rng
ExitSub:
On Error Resume Next ' this code must run, no matter what happens
' Restore prior application settings
If Application.ScreenUpdating <> boolScreenUpdate Then
boolScreenUpdate = Application.ScreenUpdating
End If
If Application.EnableEvents <> boolEnableEvents Then
Application.EnableEvents = boolEnableEvents
End If
Exit Sub
ErrSub:
Dim strMsg As String
strMsg = ""
strMsg = strMsg & "The CopyCalc operation on range '" & rng.Worksheet.Name & "'!" & rng.Address & " failed: "
strMsg = strMsg & vbCrLf & vbCrLf
strMsg = strMsg & "Excel error " & Err.Number & ": " & Error.Description
strMsg = strMsg & vbCrLf & vbCrLf
strMsg = strMsg & "There may be an error in the formulas you are attempting to copy. Try a manual copy and see if you can fix the formulas. If this is a system problem, or a macro error, contact support."
If Err.HelpContext <> 0 Then
MsgBox strMsg, vbCritical + vbMsgBoxHelpButton, ThisWorkbook.Name & "CopyCalc Error:", Err.HelpFile, Err.HelpContext
Else
MsgBox strMsg, vbCritical, ThisWorkbook.Name & "CopyCalc Error:"
End If
Resume ExitSub
Exit Sub
' DEBUGGING ONLY: you can only reach this statement by a manual 'Set Next Statement'
' use it to identify the bad line if you've placed a breakpoint in the error-handler
Resume
End Sub
</PRE>Nigel Heffernanhttp://www.blogger.com/profile/08954578765691578714noreply@blogger.com0tag:blogger.com,1999:blog-1800518423097919889.post-45917950560336170522014-08-31T16:24:00.000+01:002014-09-17T17:23:26.068+01:00Reading a closed Excel workbook using ADODB
Here's a rough code sample (check for line breaks!) for reading closed Excel files:
<PRE>
Public Function GetDataFromClosedWorkbook(ByVal SourceFile As String, _
ByVal SourceRange As String, _
Optional ByRef FieldNames As String = "", _
Optional ByVal SkipHeaders As Boolean = False, _
Optional ByVal LocalCopyLifetime As Double = 1#, _
Optional ByVal ForceRecopy As Boolean = False, _
Optional ByVal Asynchronous As Boolean = False) As Variant
Application.Volatile False
On Error GoTo ErrSub
' Read a Range in a closed workbook (which remains closed throughout the
' operation - we do not open the file in Excel.exe)
' Returns a TRANSPOSED 2-dimensional variant array, in which the first column will be the headers
' If your range is a worksheet, append "$" to the worksheet name
' If your range is a defined set of cells on a worksheet, use this format:
' Sheet_Name$B1:G1024 (spaces are OK in the worksheet name)
' If you're using workbook-level named range, just supply the name
' If you're querying a csv file, don't bother with a sheet or range name. The filename is the 'table'
' SkipHeaders = TRUE means that the top row of your data range will NOT be
' treated as part of the data to be returned
' Set SkipHeaders=True if you pass the parameter SourceRange as
' a SQL query instead of a range or table name
' FieldNames will be populated by a comma-delimited string containing
' the field names if SkipHeaders is True
' Note that we do not attempt to examine files on network folders: we always copy to a temporary folder
' - However, we'll only overwrite a pre-existing local copy if the pre-existing
' file is older than LocalCopyLifetime days
' - While the copy-to-local-folder operation in running in asynchronous mode,
' the function will return #WAITING FOR FILE TRANSFER
Dim objFSO As Object ' late-binding: imperfect, but it means we can drag-and-drop this sheet without creating references
Dim objConnect As Object ' ADODB.Connection
Dim rst As Object ' ADODB.Recordset
Dim strConnect As String
Dim i As Long
Dim j As Long
Dim arrData As Variant
Dim TempFile As String
Dim strTest As String
Dim SQL As String
Dim iColCount As Long
Dim strPathFull As String
Dim strHeaders As String
If SourceFile = "" Then
Exit Function
End If
' **** Parse out web folder paths ' **** **** **** **** **** **** **** **** **** **** **** ****
If Left(SourceFile, 5) = "http:" Then
SourceFile = Right(SourceFile, Len(SourceFile) - 5)
SourceFile = Replace(SourceFile, "%20", " ")
SourceFile = Replace(SourceFile, "%160", " ")
SourceFile = Replace(SourceFile, "/", "\")
End If
strPathFull = SourceFile
If Len(Dir(SourceFile)) = 0 Then
ReDim arrTemp(1 To 1, 1 To 1)
arrTemp(1, 1) = "#ERROR Source file not found"
GetDataFromClosedWorkbook = arrTemp
Erase arrTemp
Exit Function
End If
' **** Copy remote files to the local drive: **** **** **** **** **** **** **** **** **** **** ****
If objFSO Is Nothing Then
Set objFSO = CreateObject("Scripting.FileSystemObject") ' New Scripting.FileSystemObject
End If
If objFSO Is Nothing Then
Shell "Regsvr32.exe /s scrrun.dll", vbHide
Application.Wait (Now() + 5 / 3600 / 24)
Set objFSO = CreateObject("Scripting.FileSystemObject")
End If
If objFSO Is Nothing Then
Exit Function
End If
TempFile = objFSO.GetSpecialFolder(2).Path & "\" & Filename(SourceFile)
If ForceRecopy Then
If Len(VBA.FileSystem.Dir(TempFile)) > 0 Then
VBA.FileSystem.Kill TempFile
End If
End If
If Not (Left(SourceFile, 3) = "C:\" Or Left(SourceFile, 3) = "D:\") Then
If Len(VBA.FileSystem.Dir(TempFile)) > 0 Then
On Error Resume Next
If VBA.FileSystem.FileDateTime(TempFile) < VBA.FileSystem.FileDateTime(SourceFile) Then
VBA.FileSystem.Kill TempFile
ElseIf objFSO.GetFile(TempFile).dateLastAccessed < (Now - LocalCopyLifetime) Then
VBA.FileSystem.Kill TempFile
End If
End If
If Len(VBA.FileSystem.Dir(TempFile)) = 0 Then
If Asynchronous Then
Shell "cmd /c COPY " & Chr(34) & SourceFile & _
Chr(34) & " " & Chr(34) & TempFile & Chr(34), vbHide
ReDim arrTemp(1 To 1, 1 To 1)
arrTemp(1, 1) = "#WAITING FOR FILE TRANSFER. Please try again in a minute."
GetDataFromClosedWorkbook = arrTemp
Erase arrTemp
Exit Function
Else
VBA.FileSystem.FileCopy SourceFile, TempFile
End If
Else
SourceFile = TempFile
End If
End If
' **** Decide whether we need to read a header row separately from the main body of the data: ' **** ****
If InStr(1, SourceRange, "SELECT", vbTextCompare) > 0 And _
InStr(7, SourceRange, "FROM", vbTextCompare) > 1 _
Then
strHeaders = "HDR=Yes"
'SkipHeaders = True
ElseIf SkipHeaders = True Then
strHeaders = "HDR=Yes"
Else
strHeaders = "HDR=No"
End If
' **** Connect to the file: ' **** **** **** **** **** **** **** **** **** **** **** ****' **** ****
Application.StatusBar = "Connecting to " & SourceFile & "..."
If Right(SourceFile, 4) = ".xls" Then '
'strConnect = "DRIVER={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & _
"ReadOnly=1;DBQ=" & Chr(34) & SourceFile & Chr(34) & ";" & _
";Extended Properties=" & _
Chr(34) & "HDR=No;IMEX=1;MaxScanRows=0" & Chr(34) & ";"
strConnect = "Provider=Microsoft.Jet.OLEDB.4.0;_
Data Source=" & Chr(34) & SourceFile & Chr(34) & ";_
Extended Properties=" & Chr(34) & "Excel 8.0;" & _
strHeaders & ";IMEX=1;MaxScanRows=0" & Chr(34) & ";"
' strConnect = "Provider=Microsoft.ACE.OLEDB.12.0;_
Data Source=" & Chr(34) & SourceFile & Chr(34) & ";_
Extended Properties=" & Chr(34) & "Excel 8.0;" & _
strHeaders & ";IMEX=1;MaxScanRows=0" & Chr(34) & ";"
ElseIf Right(SourceFile, 5) = ".xlsx" Then
strConnect = "Provider=Microsoft.ACE.OLEDB.12.0;_
Data Source=" & Chr(34) & SourceFile & Chr(34) & ";_
Extended Properties=" & Chr(34) & "Excel 12.0 Xml;" & _
strHeaders & ";IMEX=1;MaxScanRows=0" & Chr(34) & ";"
ElseIf Right(SourceFile, 5) = ".xlsm" Then
'strConnect = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};"_
& "ReadOnly=1;_
DBQ=" & SourceFile & ";" & Chr(34) & SourceFile & Chr(34) & ";" & ";_
Extended Properties=" & Chr(34) & "Excel 12.0;" & _
strHeaders & ";IMEX=1;MaxScanRows=0" & Chr(34) & ";"
strConnect = "Provider=Microsoft.ACE.OLEDB.12.0; _
Data Source=" & Chr(34) & SourceFile & Chr(34) & ";_
Extended Properties=" & Chr(34) & "Excel 12.0 Macro;" & _
strHeaders & ";IMEX=1;MaxScanRows=0" & Chr(34) & ";"
ElseIf Right(SourceFile, 5) = ".xlsb" Then
'strConnect = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & _
'"ReadOnly=1;DBQ=" & SourceFile & ";" & Chr(34) & SourceFile & Chr(34) & ";" & _
' ";Extended Properties=" & Chr(34) & "Excel 12.0;" & strHeaders & "; _
' IMEX=1;MaxScanRows=0" & Chr(34) & ";"
' This ACE driver is unstable on xlsb files...
' But it's more likely to return a result, if you don't mind crashes:
strConnect = "Provider=Microsoft.ACE.OLEDB.12.0; _
Data Source=" & Chr(34) & SourceFile & Chr(34) & _
";Extended Properties=" & Chr(34) & "Excel 12.0;" & strHeaders _ & "; _
IMEX=1;MaxScanRows=0" & Chr(34) & ";"
ElseIf Right(SourceFile, 4) = ".csv" Or Right(SourceFile, 4) = ".txt" Then
' JET OLEDB text driver connection string:
' Provider=Microsoft.Jet.OLEDB.4.0;Data Source=c:\txtFilesFolder\;
' Extended Properties="text;HDR=Yes;FMT=Delimited;MaxScanRows=;IMEX=1;";
' ODBC text driver connection string:
' Driver={Microsoft Text Driver
' (*.txt; *.csv)};Dbq=c:\txtFilesFolder\;Extensions=asc,csv,tab,txt;
strConnect = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & _
Chr(34) & Folder(SourceFile) & Chr(34) & ";"
strConnect = strConnect & "Extended Properties=" & Chr(34) & _
"text;HDR=Yes;IMEX=1;MaxScanRows=0" & Chr(34) & ";"
SourceRange = Filename(SourceFile)
ElseIf Right(SourceFile, 4) = ".tab" Or Right(SourceFile, 4) = ".dat" Then
' JET OLEDB text driver connection string:
' Provider=Microsoft.Jet.OLEDB.4.0;Data Source=c:\txtFilesFolder\;Extended
' Properties="text;HDR=Yes;FMT=Delimited;MaxScanRows=;IMEX=1;";
' ODBC text driver connection string:
' Driver={Microsoft Text Driver
' (*.txt; *.csv)};Dbq=c:\txtFilesFolder\;Extensions=asc,csv,tab,txt;
strConnect = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & _
Chr(34) & Folder(SourceFile) & Chr(34) & ";"
strConnect = strConnect & "Extended Properties=" & Chr(34) & _
"text;HDR=Yes;IMEX=1;MaxScanRows=0;DELIMITER=TAB" & Chr(34) & ";"
SourceRange = Filename(SourceFile)
Else
ReDim arrTemp(1 To 1, 1 To 1)
arrTemp(1, 1) = "#ERROR - file format not known"
GetDataFromClosedWorkbook = arrTemp
Erase arrTemp
End If
On Error GoTo ErrSub
Set objConnect = CreateObject("ADODB.Connection") ' New ADODB.Connection
With objConnect
.ConnectionTimeout = 60
.CommandTimeout = 90
.Mode = 1 ' adModeRead = 1
.ConnectionString = strConnect
.Open
End With
' **** Retrieve the data: ' **** **** **** **** **** **** **** **** **** **** **** **** ****
Set rst = CreateObject("ADODB.Recordset") ' New ADODB.Recordset
With rst
.CursorLocation = 3
If Right(ThisWorkbook.Name, 4) = ".xls" Then
.MaxRecords = 65535
Else
.MaxRecords = 1048575
End If
If InStr(1, SourceRange, "SELECT", vbTextCompare) > 0 _
And InStr(7, SourceRange, "FROM", vbTextCompare) > 1 Then
SQL = SourceRange
Else
SQL = "SELECT * FROM [" & SourceRange & "] "
End If
Application.StatusBar = "Querying " & SourceFile & "..."
'.Open SQL, objConnect, adOpenStatic, adLockReadOnly, adCmdText + adAsyncFetch
.Open SQL, objConnect, 3, 1, 1 + 32
i = 0
Do While .State > 1
i = (i + 1) Mod 3
Application.StatusBar = "Retrieving data from " & SourceFile & String(i, ".")
Application.Wait Now + (0.25 / 24 / 3600)
Loop
End With
' **** Handle the returned data ' **** **** **** **** **** **** **** **** **** **** **** ****
On Error Resume Next
' resume next is required, as the errors we anticipate cannot be trapped:
' they can only be detected after the fact
For i = 0 To rst.Fields.Count - 1
FieldNames = FieldNames & rst.Fields(i).Name & ","
Next i
FieldNames = Left(FieldNames, Len(FieldNames) - 1)
If rst.EOF And rst.BOF Then
'return a single empty rpw, so that the caller doesn't error out
ReDim arrTemp(1 To rst.Fields.Count, 1 To 1) 'remember, its a transposed array
arrTemp(1, 1) = "#NO MATCHING DATA IN '" & SourceFile & "' USING '" & SQL & "'"
GetDataFromClosedWorkbook = arrTemp
Else
Err.Clear
rst.MoveFirst
GetDataFromClosedWorkbook = rst.GetRows
' note that this often fails on the first try.
If IsEmpty(GetDataFromClosedWorkbook) Then
rst.MoveFirst
GetDataFromClosedWorkbook = rst.GetRows
End If
If IsEmpty(GetDataFromClosedWorkbook) Then
' ...And on the second try. GetRows is fast when it works, but cannot be relied on
rst.MoveFirst
ReDim arrTemp(0 To rst.Fields.Count - 1, 0 To rst.RecordCount)
i = 0
j = 0
Do Until rst.EOF
Err.Clear
If i > UBound(arrTemp, 2) Then
ReDim Preserve arrTemp(0 To rst.Fields.Count - 1, 0 To i)
End If
For j = 0 To rst.Fields.Count - 1
arrTemp(j, i) = rst.Fields(j).Value
If Err.Number = &HBCD Then
Exit For
End If
Next j
i = i + 1
If Err.Number <> &HBCD Then
rst.MoveNext
End If
If Err.Number <> &H80004005 And Err.Number <> 0 Then
Exit Do
End If
Loop
GetDataFromClosedWorkbook = arrTemp
Erase arrTemp
End If ' IsEmpty(GetDataFromClosedWorkbook)
End If ' rst.EOF And rst.BOF Then
ExitSub:
On Error Resume Next
rst.Close
objConnect.Close ' close the database connection
Set rst = Nothing
Set objConnect = Nothing
Exit Function
ErrSub:
ReDim arrTemp(1 To 1, 1 To 1)
If InStr(Err.Description, "not a valid name") Then
arrTemp(1, 1) = "#ERROR: cannot retrieve data from '" & SourceRange & "'t"
MsgBox "Cannot open the file: " & vbCrLf & vbCrLf & strPathFull & vbCrLf & vbCrLf & _
"This error message probably means that the source file is locked because another _
user has this file open. Please wait a few minutes, and try again." & vbCrLf & _
vbCrLf & "If this error persists, please contact the tech team.", vbCritical, _
APP_NAME & ": file access error:"
ElseIf InStr(Err.Description, "cannot open the file") Then
arrTemp(1, 1) = "#ERROR: Cannot open the file '" & SourceRange & "'t"
MsgBox "Cannot open the file: " & vbCrLf & vbCrLf & strPathFull & vbCrLf _
& vbCrLf & "This error message probably means that the source file is _
locked because another user has this file open. Please wait a few minutes, _
and try again." & vbCrLf & vbCrLf & "If this error persists, please contact _
the tech team.", vbCritical, APP_NAME & ": file access error:"
ElseIf InStr(Err.Description, "not find the object") Then
arrTemp(1, 1) = "#ERROR: Invalid object name in '" & SourceRange & "'" _
MsgBox Err.Description & vbCrLf & vbCrLf & "This error message probably _
means that the worksheet or range has been renamed, or does not exist in _
the file. Please check your file: if you can't see an obvious error, ask _
for help from the tech team.", vbCritical, APP_NAME & ": file data error:"
ElseIf InStr(Err.Description, "Permission Denied") Then
arrTemp(1, 1) = "#ERROR Access to file"
MsgBox "Cannot open the file: " & vbCrLf & vbCrLf & strPathFull & vbCrLf & vbCrLf & _
"Another user probably has this file open. Please wait a few minutes, and try again." _
& vbCrLf & vbCrLf & "If this error persists, please contact tech team.", _
vbCritical, APP_NAME & ": file access error:"
Else
arrTemp(1, 1) = "#ERROR " & Err.Number & ": " & Err.Description
End If
GetDataFromClosedWorkbook = arrTemp
Erase arrTemp
Resume ExitSub
Resume
End Function
</PRE>Nigel Heffernanhttp://www.blogger.com/profile/08954578765691578714noreply@blogger.com0tag:blogger.com,1999:blog-1800518423097919889.post-63023472112892901742013-06-23T17:12:00.000+01:002014-10-27T17:13:09.607+00:00Code for a version-independent date pickerBy now, you're either working entirely in 64-bit windows and the 64-bit versions of VBA in Office 2010 and 2013, or sort-of-stuck with running office in 32-bit mode because all the 32-bit OCX and COM objects are broken.
A good (or bad) example of this is the Date-Picker control, and I ended up coding a native VBA version that runs on either OS.
This code won't do it all for you: you've got to build the form and create the controls - I don't do downloads on this server - but it's a good overview of the coding you've got to do to make a date-picker work.
<CODE Lang="VB"><PRE>
Option Explicit
' Version-independent date-picker form, entirely
' built in MSForms controls and native VBA.
' Note that the date-selector functions for month
' and year respect end-of-month: jumping back one
' month from March 31st goes to February 28th and
' jumping forward one month from Feb 28th goes to
' March 31st - not March 28th, the result you get
' using the native Excel and VBA date arithmetic.
' ********************************************
' Author: Nigel Heffernan
' June 2013 http://excellerando.blogspot.com
' **** THIS CODE IS IN THE PUBLIC DOMAIN ****
'
' You are advised to segregate this code from
' any proprietary or commercially-confidential
' source code, and to label it clearly. If you
' fail do do so, there is a risk that you will
' impair your right to assert ownership of any
' intellectual property embedded in your work;
' or impair your employers or clients' ability
' to do so if the intellectual property rights
' in your work have been assigned to them.
'
' You are free to use this code as-is, but all
' use is entirely at your own risk: the author
' accepts no liability arising from the use of
' this source code or any work derived from it
' and no warranty is offered or implied.
'
' * YOU ARE EXPECTED TO DO YOUR OWN TESTING *
'
' You are asked, as a matter of professional
' courtesy, to acknowledge the author of any
' source code that you incorporate into your
' work, with a link to author's website or a
' link to the relevant open-source community
' site if that was where you found the code.
'
' You are strongly advised to include both the
' copyright and liability disclaimers, and to
' consult your company's legal advisors with a
' view to providing equivalent and appropriate
' notices and disclaimers.
' ********************************************
'SAMPLE USAGE: FUNCTION TO OPEN THE FORM AND RETURN THE SELECTED DATE
'Option Explicit
'Option Private Module ' Don't expose this for use in formulas
'Public Function DatePicker(Optional StartDate As Date = 0, _
' Optional LinkedCell As Excel.Range, _
' Optional Caption As String = "Select date") As Date
'
'' Open a date picker form and return the date selected by the user.
'
'' This function respects end-of-month: jumping forward a month from
'' February 28th lands on March 31st, not March 28th.
'
'' Clicking Cancel, or the form's window close button, will discard
'' the user's selection and return the initial date.
'If StartDate = 0 Then
' StartDate = VBA.Date
'End If
'
'With frmDatePicker
'
' .Caption = Caption
'
' If LinkedCell Is Nothing Then
' ' no action
' ElseIf Not IsDate(LinkedCell.Cells(1, 1).Value) Then
' ' no action
' Else
' .txtSelectedDate.ControlSource = Chr(39) & LinkedCell.Worksheet.Name & Chr(39) & "!" & LinkedCell.Cells(1, 1).Address
' If IsDate(LinkedCell.Value) Or IsNumeric(LinkedCell.Value2) Then
' StartDate = CVDate(LinkedCell.Value)
' Else
' StartDate = VBA.Date
' End If
' End If
'
' .InitialDate = StartDate
'
' .StartUpPosition = 0 'manual
' .Left = Application.Left + (0.5 * Application.Width) - (0.5 * .Width)
' .Top = Application.Top + (0.5 * Application.Height) - (0.5 * .Height)
'
' .Show
'
'End With
'
'' This 'With' block exit and re-entry avoids OLE disconnection errors if the form window is closed
'
'With frmDatePicker
'
' If .Cancel Then
'
' DatePicker = StartDate
' If Not LinkedCell Is Nothing Then
' LinkedCell.Value2 = StartDate
' End If
'
' Else
'
' DatePicker = .SelectedDate
' If Not LinkedCell Is Nothing Then
' LinkedCell.Value2 = .SelectedDate
' End If
'
' End If
'
'End With
'
'
'Unload frmDatePicker
'
'End Function
' *************************************************************************************
#If VBA7 And Win64 Then ' 64 bit Excel
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongLong)
#Else ' 32 bit Excel
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
Private Const BTN_MEDIUM As Long = &HE0E0E0
Private Const BTN_DARK_1 As Long = &HD0D0D0
Private Const BTN_LIGHT As Long = &HF0F0F0
Private Const FONT_DARK As Long = &H800000
Private Const FONT_LIGHT As Long = &HFFFFA0
Private Const FONT_GREY As Long = &H808080
Private Const BTN_DELAY As Long = 150
Private Const YEAR_START As Long = -3
Private m_dtSelected As Date ' The selected date, as displayed
Private m_dtInitial As Date ' an initial date set externally by a VBA caller
Private m_BaseDate As Date ' A nominal date corresponding to day button zero
Private m_Month As Long ' The current month (as 1-12)
Private m_Year As Long ' The current year
Public Cancel As Boolean ' Cancel remains true until the user performs some
' action that selects a date, or clicks 'OK'
Public Property Get InitialDate() As Date
InitialDate = m_dtInitial
End Property
Public Property Let InitialDate(DateInitial As Date)
' InitialDate is the date returned to callers when Cancel=True
' Cancel is set TRUE on initialisation, or on setting this property
' All user actions that select a date set Cancel=False
' The user action 'Cancel' sets Cancel=True
m_dtInitial = DateInitial
SelectedDate = m_dtInitial
Cancel = True
End Property
Public Property Get SelectedDate() As Date
' Return the date currently selected
SelectedDate = m_dtSelected
End Property
Public Property Let SelectedDate(DateSelected As Date)
Dim lngLabel As Long
Dim strLabel As String
On Error Resume Next
Application.EnableEvents = False
m_dtSelected = DateSelected
If m_Month <> Month(DateSelected) Or m_Year <> Year(DateSelected) Then
m_Month = Month(DateSelected)
m_Year = Year(DateSelected)
'ResetFormats
DisplayMonth m_Year, m_Month
End If
'lng Label is the ordinal (1 to 42) of the 'day' button for the selected date
lngLabel = DateSelected - m_BaseDate
strLabel = "day" & Right("00" & lngLabel, 2)
DayButton_Click Me.Controls(strLabel)
Me.txtSelectedDate = Format(DateSelected, "dd-mmm-yyyy")
Me.cboMonth.Text = Format(DateSelected, "mmmm")
Me.cboYear.Text = Format(DateSelected, "yyyy")
Me.Cancel = False
Application.EnableEvents = True
End Property
Private Sub DisplayMonth(iYear As Long, lngMonth As Long)
Dim lngStartDate As Long ' First day of this month
Dim lngEndDate As Long ' First day of this month
Dim strCtrlName As String
Dim lngLabel As Long
Dim lngWeekDay As Long
Dim lngDate As Long ' local variable, incremented in a loop
lngStartDate = DateSerial(iYear, lngMonth, 1)
lngEndDate = DateSerial(iYear, lngMonth + 1, 1) - 1 ' DateSerial(2014, 13, 1) ' actually works in VBA
lngWeekDay = Weekday(lngStartDate)
m_BaseDate = lngStartDate - lngWeekDay
For lngLabel = 1 To 42
lngDate = m_BaseDate + lngLabel
strCtrlName = "day" & Right("00" & lngLabel, 2)
With Me.Controls(strCtrlName)
.Caption = Day(lngDate)
If lngDate = m_dtSelected Then
FormatSelected Me.Controls(strCtrlName)
Else
FormatDeselected Me.Controls(strCtrlName), lngMonth
End If
End With
Next lngLabel
End Sub
Private Sub FormatSelected(ctrl As MSForms.Control)
' format the day selector control for a selection 'click'
Dim lngLabel As Integer
With ctrl
.SpecialEffect = fmSpecialEffectSunken
lngLabel = CInt(Right(.Name, 2))
If lngLabel Mod 7 > 1 Then
.BackColor = BTN_LIGHT - &H606060
Else
.BackColor = BTN_MEDIUM - &H606060
End If
.ForeColor = &HFFFFB0 ' FONT_LIGHT
.Font.Bold = True
End With
End Sub
Private Sub FormatDeselected(ctrl As MSForms.Control, Optional lngMonth As Long = 0)
' format the day selector control for a selection 'click'
Dim lngLabel As Integer
Dim lngDate As Long
If lngMonth = 0 Then
lngMonth = Month(m_dtSelected)
End If
With ctrl
.SpecialEffect = fmSpecialEffectEtched
lngLabel = CInt(Right(.Name, 2))
lngDate = m_BaseDate + lngLabel
If lngLabel Mod 7 > 1 Then
.BackColor = BTN_LIGHT
Else
.BackColor = BTN_MEDIUM
End If
.Font.Bold = False
If lngLabel Mod 7 > 1 Then
.BackColor = BTN_LIGHT
Else
.BackColor = BTN_MEDIUM
End If
If Month(lngDate) = lngMonth Then
'.Enabled = True
.ForeColor = FONT_DARK
Else
'.Enabled = False
.ForeColor = FONT_GREY
.BackColor = BTN_MEDIUM
End If
End With
End Sub
Private Sub DayButton_Click(ctrlClicked As MSForms.Control, Optional SetDate As Boolean = True)
Dim lngLabel As Integer
Dim ctrl As MSForms.Control
For Each ctrl In Me.Controls
' Enforce 'toggle' behaviour: deselect any other date button that's selected
If Left(ctrl.Name, 3) = "day" And ctrl.Name <> ctrlClicked.Name Then
If ctrl.SpecialEffect = fmSpecialEffectSunken Then
FormatDeselected ctrl
End If
End If
Next
With ctrlClicked
lngLabel = CInt(Right(.Name, 2))
If .SpecialEffect = fmSpecialEffectEtched Then
FormatSelected ctrlClicked
If SetDate Then
SelectedDate = m_BaseDate + lngLabel
End If
End If
End With
End Sub
Private Sub cboMonth_Change()
Dim lngDate As Date
Dim lngMonth As Long
Dim lngShift As Long
If Application.EnableEvents = False Then Exit Sub
lngDate = SelectedDate
lngMonth = cboMonth.ListIndex + 1
lngShift = lngMonth - Month(lngDate)
ShiftMonth lngShift
End Sub
Public Sub ShiftMonth(lngShift As Long)
Dim lngDate As Date
lngDate = SelectedDate
' Respect end-of-month logic: adding 1 month to Feb 28th does NOT equal March 28
If DateSerial(Year(lngDate), Month(lngDate) + 1, 1) - 1 = lngDate Then ' start from EOM
SelectedDate = DateSerial(Year(lngDate), Month(lngDate) + lngShift + 1, 1) - 1
ElseIf DateSerial(Year(lngDate), Month(lngDate), 1) = lngDate Then ' start from BOM
SelectedDate = DateSerial(Year(lngDate), Month(lngDate) + lngShift, 1)
Else
SelectedDate = DateAdd("m", lngShift, lngDate)
End If
End Sub
Private Sub cboYear_Change()
If Application.EnableEvents = False Then Exit Sub
Dim lngDate As Date
Dim lngYear As Long
Dim lngShift As Long
If Len(cboYear.Text) < 2 Then Exit Sub
lngDate = SelectedDate
lngYear = cboYear.Text
If lngYear > -1 And lngYear < 100 Then
lngYear = Year(SelectedDate) - (Year(SelectedDate) Mod 100) + lngYear
End If
lngShift = lngYear - Year(lngDate)
ShiftYear lngShift
End Sub
Public Sub ShiftYear(lngShift As Long)
Dim lngDate As Date
lngDate = SelectedDate
' Respect end-of-month logic: adding 1 month to Feb 28th does NOT equal March 28
If DateSerial(Year(lngDate), Month(lngDate) + 1, 1) - 1 = lngDate Then ' start from EOM
SelectedDate = DateSerial(Year(lngDate) + lngShift, Month(lngDate) + 1, 1) - 1
ElseIf DateSerial(Year(lngDate), Month(lngDate), 1) = lngDate Then ' start from BOM
SelectedDate = DateSerial(Year(lngDate) + lngShift, Month(lngDate), 1)
Else
SelectedDate = DateAdd("yyyy", lngShift, lngDate)
End If
End Sub
' *** Note the use of label controls instead of MSForms butttons
' The MS Forms 'button' controls don't support the fine detail we
' need in this kind of densely-packed and densely-functional form
Private Sub cmdDateDec_Click()
' Microbutton decrementing a textbox: dynamic formatting required
With cmdDateDec
.Top = .Top - 0.75
.SpecialEffect = fmSpecialEffectSunken
Me.Repaint
Sleep BTN_DELAY
Me.SelectedDate = Me.SelectedDate - 1
.Top = .Top + 0.75
.SpecialEffect = fmSpecialEffectFlat
End With
End Sub
Private Sub cmdDateInc_Click()
' Microbutton incrementing a textbox: dynamic formatting required
With cmdDateInc
.Top = .Top - 0.75
.SpecialEffect = fmSpecialEffectSunken
Me.Repaint
Sleep BTN_DELAY
Me.SelectedDate = Me.SelectedDate + 1
.SpecialEffect = fmSpecialEffectFlat
.Top = .Top + 0.75
End With
End Sub
Private Sub cmdMonthDec_Click()
' Microbutton decrementing a textbox: dynamic formatting required
With cmdMonthDec
.Top = .Top - 0.75
.SpecialEffect = fmSpecialEffectSunken
Me.Repaint
Sleep BTN_DELAY
ShiftMonth -1
.Top = .Top + 0.75
.SpecialEffect = fmSpecialEffectFlat
End With
End Sub
Private Sub cmdMonthInc_Click()
' Microbutton incrementing a textbox: dynamic formatting required
With cmdMonthInc
.Top = .Top - 0.75
.SpecialEffect = fmSpecialEffectSunken
Me.Repaint
Sleep BTN_DELAY
ShiftMonth 1
.SpecialEffect = fmSpecialEffectFlat
.Top = .Top + 0.75
End With
End Sub
Private Sub cmdYearDec_Click()
' Microbutton decrementing a textbox: dynamic formatting required
With cmdYearDec
.Top = .Top - 0.75
.SpecialEffect = fmSpecialEffectSunken
Me.Repaint
Sleep BTN_DELAY
ShiftYear -1
.Top = .Top + 0.75
.SpecialEffect = fmSpecialEffectFlat
End With
End Sub
Private Sub cmdYearInc_Click()
' Microbutton incrementing a textbox: dynamic formatting required
With cmdYearInc
.Top = .Top - 0.75
.SpecialEffect = fmSpecialEffectSunken
Me.Repaint
Sleep BTN_DELAY
ShiftYear 1
.SpecialEffect = fmSpecialEffectFlat
.Top = .Top + 0.75
End With
End Sub
Private Sub cmdCancel_Click()
cmdCancel.SpecialEffect = fmSpecialEffectSunken
Me.Repaint
Sleep BTN_DELAY
Me.SelectedDate = m_dtInitial
Me.Cancel = True
cmdCancel.SpecialEffect = fmSpecialEffectEtched
Me.Hide
End Sub
Private Sub cmdOK_Click()
cmdOK.SpecialEffect = fmSpecialEffectSunken
Me.Repaint
Sleep BTN_DELAY
cmdOK.SpecialEffect = fmSpecialEffectEtched
Me.Hide
End Sub
Private Sub txtSelectedDate_Change()
Dim lngYear As Long
Dim strDate As String
Dim arrDate As Variant
Dim lngDate As Variant
Dim varTemp As Variant
If Application.EnableEvents = False Then Exit Sub
txtSelectedDate.Text = Replace(txtSelectedDate.Text, "/", "-")
txtSelectedDate.Text = Replace(txtSelectedDate.Text, " ", "-")
txtSelectedDate.Text = Replace(txtSelectedDate.Text, ",", "-")
txtSelectedDate.Text = Replace(txtSelectedDate.Text, ".", "-")
txtSelectedDate.Text = Replace(txtSelectedDate.Text, "--", "-")
arrDate = Split(txtSelectedDate.Text, "-")
If UBound(arrDate) < 2 Then Exit Sub
If UBound(arrDate) > 2 Then ReDim Preserve arrDate(0 To 2)
If Len(CStr(arrDate(0))) > 2 Then
' Swap mmm-dd-yyyy to dd-mmm-yyyy
If IsNumeric(arrDate(1)) And Not IsNumeric(arrDate(0)) Then
varTemp = arrDate(0)
arrDate(0) = arrDate(1)
arrDate(1) = varTemp
' Swap 05-26-2011 to 26-05-2011
If IsNumeric(arrDate(1)) And IsNumeric(arrDate(0)) Then
If arrDate(1) > 12 And arrDate(0) < 12 Then
varTemp = arrDate(0)
arrDate(0) = arrDate(1)
arrDate(1) = varTemp
End If
End If
' Swap yyyy-mmm-dd to dd-mmm-yyyy
ElseIf Len(CStr(arrDate(0))) = 4 And Len(arrDate(2)) < 3 Then
varTemp = arrDate(0)
arrDate(0) = arrDate(2)
arrDate(2) = varTemp
End If
End If
If Not IsNumeric(arrDate(0)) Then Exit Sub
If arrDate(0) < 1 Then Exit Sub
If Not IsNumeric(arrDate(2)) Then
Exit Sub
ElseIf Len(arrDate(2)) < 2 Then
Exit Sub 'do nothing, the user is still typing the year
ElseIf Left(arrDate(2), 2) = CStr((Year(Date) \ 100)) And Len(arrDate(2)) < 4 Then
Exit Sub 'do nothing, the user is still typing the year
End If
strDate = "00" & Right(arrDate(0), 2) & "-" & arrDate(1) & "-" & arrDate(2)
If IsDate(strDate) Then
Me.SelectedDate = CVDate(strDate)
End If
End Sub
Private Sub txtSelectedDate_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
With txtSelectedDate
If IsDate(.Value) Then
Select Case .SelStart
Case 1, 2
Me.SelectedDate = Me.SelectedDate + 1
Case 3, 4, 5, 6
' Respect end-of-month logic: adding 1 month to Feb 28th does NOT equal March 28
If Month(SelectedDate + 1) <> Month(SelectedDate) Then
SelectedDate = DateSerial(Year(SelectedDate), Month(SelectedDate) + 2, 1) - 1
Else
SelectedDate = DateAdd("m", 1, SelectedDate)
End If
Case Is > 7
' However, we do not apply EOM logic for leap years: it surprises the users
SelectedDate = DateAdd("yyyy", 1, SelectedDate)
End Select
End If
End With
End Sub
Private Sub txtSelectedDate_Exit(ByVal Cancel As MSForms.ReturnBoolean)
'Supports direct user edits in the control
If IsDate(txtSelectedDate.Value) Then
If Me.SelectedDate <> CVDate(txtSelectedDate.Value) Then
Me.SelectedDate = CVDate(txtSelectedDate.Value)
End If
End If
End Sub
Private Sub UserForm_Initialize()
Dim lngLabel As Long
Dim strLabel As String
Dim lngDate As Long
Me.Caption = "Select Date"
SelectedDate = Date
' Populate day name labels, lblDay1 to lblDay7
' Doing this in code picks up the locale's day
' abbreviations - test this on a 'French' PC
lngDate = SelectedDate
Do Until Weekday(lngDate) = 7
lngDate = lngDate + 1
Loop
For lngLabel = 1 To 7
strLabel = "lblDay" & lngLabel
Me.Controls(strLabel).Caption = Format(lngDate + lngLabel, "ddd")
Next lngLabel
lngDate = SelectedDate
With cboMonth
.Clear
For lngLabel = 1 To 12
.AddItem Format(DateSerial(Year(lngDate), lngLabel, 1), "mmmm")
Next lngLabel
.ListIndex = Month(lngDate) - 1
End With
lngDate = SelectedDate
With cboYear
.Clear
For lngLabel = YEAR_START To 10
.AddItem Year(lngDate) + lngLabel
Next lngLabel
.ListIndex = -YEAR_START
End With
Me.InitialDate = lngDate ' This also sets Me.Cancel = True
' Cancel remains true until the user selects a date
End Sub
Private Sub day01_Click(): DayButton_Click day01: End Sub
Private Sub day02_Click(): DayButton_Click day02: End Sub
Private Sub day03_Click(): DayButton_Click day03: End Sub
Private Sub day04_Click(): DayButton_Click day04: End Sub
Private Sub day05_Click(): DayButton_Click day05: End Sub
Private Sub day06_Click(): DayButton_Click day06: End Sub
Private Sub day07_Click(): DayButton_Click day07: End Sub
Private Sub day08_Click(): DayButton_Click day08: End Sub
Private Sub day09_Click(): DayButton_Click day09: End Sub
Private Sub day10_Click(): DayButton_Click day10: End Sub
Private Sub day11_Click(): DayButton_Click day11: End Sub
Private Sub day12_Click(): DayButton_Click day12: End Sub
Private Sub day13_Click(): DayButton_Click day13: End Sub
Private Sub day14_Click(): DayButton_Click day14: End Sub
Private Sub day15_Click(): DayButton_Click day15: End Sub
Private Sub day16_Click(): DayButton_Click day16: End Sub
Private Sub day17_Click(): DayButton_Click day17: End Sub
Private Sub day18_Click(): DayButton_Click day18: End Sub
Private Sub day19_Click(): DayButton_Click day19: End Sub
Private Sub day20_Click(): DayButton_Click day20: End Sub
Private Sub day21_Click(): DayButton_Click day21: End Sub
Private Sub day22_Click(): DayButton_Click day22: End Sub
Private Sub day23_Click(): DayButton_Click day23: End Sub
Private Sub day24_Click(): DayButton_Click day24: End Sub
Private Sub day25_Click(): DayButton_Click day25: End Sub
Private Sub day26_Click(): DayButton_Click day26: End Sub
Private Sub day27_Click(): DayButton_Click day27: End Sub
Private Sub day28_Click(): DayButton_Click day28: End Sub
Private Sub day29_Click(): DayButton_Click day29: End Sub
Private Sub day30_Click(): DayButton_Click day30: End Sub
Private Sub day31_Click(): DayButton_Click day31: End Sub
Private Sub day32_Click(): DayButton_Click day32: End Sub
Private Sub day33_Click(): DayButton_Click day33: End Sub
Private Sub day34_Click(): DayButton_Click day34: End Sub
Private Sub day35_Click(): DayButton_Click day35: End Sub
Private Sub day36_Click(): DayButton_Click day36: End Sub
Private Sub day37_Click(): DayButton_Click day37: End Sub
Private Sub day38_Click(): DayButton_Click day38: End Sub
Private Sub day39_Click(): DayButton_Click day39: End Sub
Private Sub day40_Click(): DayButton_Click day40: End Sub
Private Sub day41_Click(): DayButton_Click day41: End Sub
Private Sub day42_Click(): DayButton_Click day42: End Sub
</PRE></CODE>Nigel Heffernanhttp://www.blogger.com/profile/08954578765691578714noreply@blogger.com0tag:blogger.com,1999:blog-1800518423097919889.post-81107957469068875962012-08-19T13:11:00.000+01:002012-08-23T01:21:21.087+01:00Join and Split functions for 2-Dimensional arraysHere's something I fished out of the attic and posted into <a href="http://stackoverflow.com/questions/8934184/build-a-string-in-excel-vba/12054533#12054533">StackOverflow</a>...<br />
<br />
The code's trivial, in the sense that anyone can do a bit of string-concatenation and a Redim() statement and you've probably done some kind of 'Join' and 'Split' already. But there are a couple of points about efficient string-handling in the comments; or rather, overcoming the inefficiencies of a language which has no string-builder class. <br />
<br />
Someday, you are going to find out that concatenating strings slows down *severely* for long strings, and you'll need to know how to work around that.<br />
<br />
So, without further ado:<br />
<br />
<strong>Join2d: A 2-Dimensional Join function in VBA with optimised string-handling</strong><br />
<br />
Coding notes:<br />
<ol><li>This 'Join' function does not suffer from the 255-char limitation that affects most (if not all) of the native Concatenate functions in Excel, and the Range.Value code sample above will pass in the data, in full, from cells containing longer strings.</LI>
<li>This is heavily optimised: we use string-concatenation as little as possible, as the native VBA string-concatenations are slow and get progressively slower as a longer string is concatenated.</LI> </OL>If you want to look more deeply into optimising string-handling in VBA and the VB family of languages, advanced techniques are listed in parts I, II and II of this web article: http://www.aivosto.com/vbtips/stringopt3.html <br />
<br />
The biggest performance gain available in native VBA is to avoid allocation and concatenation ( here's why: http://www.aivosto.com/vbtips/stringopt2.html#huge ) - so I use join, split, and replace instead of myString = MyString & MoreString<br />
<br />
Bigger gains are available if you use the Kernel string functions directly: after that, you're Googling for LightningStrings and taking the big step into pointer arithmentic... Which I consider a step too far: if you need that kind of performance, you need another platform.<br />
<br />
<pre><code Lang='VB'>
Public Function Join2d(ByRef InputArray As Variant, _
Optional RowDelimiter As String = vbCr, _
Optional FieldDelimiter = vbTab,_
Optional SkipBlankRows As Boolean = False _
) As String
' Join up a 2-dimensional array into a string. Works like the standard
' VBA.Strings.Join, for a 2-dimensional array.
' Note that the default delimiters are those inserted into the string
' returned by ADODB.Recordset.GetString
On Error Resume Next
' Coding note: we're not doing any string-handling in VBA.Strings -
' allocating, deallocating and (especially!) concatenating are SLOW.
' We're using the VBA Join & Split functions ONLY. The VBA Join,
' Split, & Replace functions are linked directly to fast (by VBA
' standards) functions in the native Windows code. Feel free to
' optimise further by declaring and using the Kernel string functions
' if you want to.
' ** THIS CODE IS IN THE PUBLIC DOMAIN **
' Nigel Heffernan Excellerando.Blogspot.com
Dim i As Long
Dim j As Long
Dim i_lBound As Long
Dim i_uBound As Long
Dim j_lBound As Long
Dim j_uBound As Long
Dim arrTemp1() As String
Dim arrTemp2() As String
Dim strBlankRow As String
i_lBound = LBound(InputArray, 1)
i_uBound = UBound(InputArray, 1)
j_lBound = LBound(InputArray, 2)
j_uBound = UBound(InputArray, 2)
ReDim arrTemp1(i_lBound To i_uBound)
ReDim arrTemp2(j_lBound To j_uBound)
For i = i_lBound To i_uBound
For j = j_lBound To j_uBound
arrTemp2(j) = InputArray(i, j)
Next j
arrTemp1(i) = Join(arrTemp2, FieldDelimiter)
Next i
If SkipBlankRows Then
If Len(FieldDelimiter) = 1 Then
strBlankRow = String(j_uBound - j_lBound, FieldDelimiter)
Else
For j = j_lBound To j_uBound
strBlankRow = strBlankRow & FieldDelimiter
Next j
End If
Join2d = Replace(Join(arrTemp1, RowDelimiter), strBlankRow, RowDelimiter, "")
i = Len(strBlankRow & RowDelimiter)
If Left(Join2d, i) = strBlankRow & RowDelimiter Then
Mid$(Join2d, 1, i) = ""
End If
Else
Join2d = Join(arrTemp1, RowDelimiter)
End If
Erase arrTemp1
End Function
</CODE></PRE>For completeness, here's the corresponding 2-D Split function:<br />
<br />
<strong>Split2d: A 2-Dimensional Split function in VBA with optimised string-handling</strong><br />
<br />
<pre><code>
Public Function Split2d(ByRef strInput As String, _
Optional RowDelimiter As String = vbCr, _
Optional FieldDelimiter = vbTab, _
Optional CoerceLowerBound As Long = 0 _
) As Variant
' Split up a string into a 2-dimensional array.
' Works like VBA.Strings.Split, for a 2-dimensional array.
' Check your lower bounds on return: never assume that any array in
' VBA is zero-based, even if you've set Option Base 0
' If in doubt, coerce the lower bounds to 0 or 1 by setting
' CoerceLowerBound
' Note that the default delimiters are those inserted into the
' string returned by ADODB.Recordset.GetString
On Error Resume Next
' Coding note: we're not doing any string-handling in VBA.Strings -
' allocating, deallocating and (especially!) concatenating are SLOW.
' We're using the VBA Join & Split functions ONLY. The VBA Join,
' Split, & Replace functions are linked directly to fast (by VBA
' standards) functions in the native Windows code. Feel free to
' optimise further by declaring and using the Kernel string functions
' if you want to.
' ** THIS CODE IS IN THE PUBLIC DOMAIN **
' Nigel Heffernan Excellerando.Blogspot.com
Dim i As Long
Dim j As Long
Dim i_n As Long
Dim j_n As Long
Dim i_lBound As Long
Dim i_uBound As Long
Dim j_lBound As Long
Dim j_uBound As Long
Dim arrTemp1 As Variant
Dim arrTemp2 As Variant
arrTemp1 = Split(strInput, RowDelimiter)
i_lBound = LBound(arrTemp1)
i_uBound = UBound(arrTemp1)
If VBA.LenB(arrTemp1(i_uBound)) <= 0 Then
' clip out empty last row: a common artifact in data
'loaded from files with a terminating row delimiter
i_uBound = i_uBound - 1
End If
i = i_lBound
arrTemp2 = Split(arrTemp1(i), FieldDelimiter)
j_lBound = LBound(arrTemp2)
j_uBound = UBound(arrTemp2)
If VBA.LenB(arrTemp2(j_uBound)) <= 0 Then
' ! potential error: first row with an empty last field...
j_uBound = j_uBound - 1
End If
i_n = CoerceLowerBound - i_lBound
j_n = CoerceLowerBound - j_lBound
ReDim arrData(i_lBound + i_n To i_uBound + i_n, j_lBound + j_n To j_uBound + j_n)
' As we've got the first row already... populate it
' here, and start the main loop from lbound+1
For j = j_lBound To j_uBound
arrData(i_lBound + i_n, j + j_n) = arrTemp2(j)
Next j
For i = i_lBound + 1 To i_uBound Step 1
arrTemp2 = Split(arrTemp1(i), FieldDelimiter)
For j = j_lBound To j_uBound Step 1
arrData(i + i_n, j + j_n) = arrTemp2(j)
Next j
Erase arrTemp2
Next i
Erase arrTemp1
Application.StatusBar = False
Split2d = arrData
End Function
</PRE>Share and enjoy... And watch out for unwanted line breaks in the code, inserted by your browser (or by Blogger's helpful formatting functions)Nigel Heffernanhttp://www.blogger.com/profile/08954578765691578714noreply@blogger.com0tag:blogger.com,1999:blog-1800518423097919889.post-66007970667375750422012-08-01T08:27:00.000+01:002014-11-20T14:30:25.006+00:00Adding a month to the end of the month: another Excel annoyance:Ever see a column of month-end payment days do this in a spreadsheet?<br />
<pre><blockquote> 31/08/2005
30/11/2005
28/02/2006
28/05/2006
28/08/2006
28/11/2006
28/02/2007
28/05/2007
28/08/2007
28/11/2007
<span style="color: red;">
28/02/2008</span></blockquote></pre><br />
Sigh. All VBA developers eventually face the weary task of correcting the VBA.DateTime function library because of this loathsome miscoding by Microsoft: <br />
<br />
<blockquote><br />
<span style="color: green; font-family: FixedSys, System, Terminal;"><br />
' Special handling required for adding months at EOM:<br />
' VBA.DateAdd("m", 1, "28 Feb 2006") = 28/03/2006 (!)<br />
' Business logic is ALWAYS that adding a month to EOM<br />
' gives the end of the following month - 31 Mar 2006.<br />
</span></blockquote><br />
Here's my solution: I guess you've all got one of your own by now. <br />
<br />
The usual health warning applies to ATTRIBUTE statements: they are not recognised by the VBA editor, you have to drag-and-drop the entire module out of the VB IDE, insert the statements manually in notepad, and drag the object back. In case you didn't know, the VB_ProcData attribute places AddDate in the 'Date & Time' category of the Spreadsheet Function Wizard, instead of letting it languish in obscurity under 'User-Defined'. <br />
<br />
<span style="font-family: FixedSys, System, Terminal;"><FONT Face="Courier New">
<br />
Public Function AddDate( _<br />
ByVal DateString As String, _<br />
Optional ByVal ReferenceDate As Date _<br />
Optional Subtract As Boolean = False _<br />
) As Date<br />
<span style="color: silver;">'ATTRIBUTE AddDate.VB_Description="Add a datestring of the form '1m', '10d' or '5y' to the reference date. \r\nBy default the reference date is the current date. \r\nInteger dates only: time expressed as fractional days is discarded. \r\nAll addition and subtraction uses Actual/Actual: no other date convention is implemented.</span><br />
<span style="color: silver;">'ATTRIBUTE AddDate.VB_ProcData.VB_Invoke_Func = " \n2"</span> <br />
<span style="color: green;"><br />
'Nigel Heffernan 2001<br />
<br />
'THIS CODE IS IN THE PUBLIC DOMAIN<br />
<br />
'Add a datestring of the form '1m', '10d' or '5y' to the reference date.<br />
'By default the reference date is the current date.<br />
'Integer dates only: time expressed as fractional days is discarded.<br />
'All addition and subtraction uses Actual/Actual: no other date convention is implemented.<br />
</span><br />
Const VB_HELPFILE As String = "C:\PROGRA~1\COMMON~1\MICROS~1\VBA\VBA6\1033\VbLR6.chm"<br />
<span style="color: green;">' I'm too lazy to do the proper registry lookup for this help file.<br />
</span><br />
On Error GoTo ErrSub<br />
<br />
Dim sNum As String<br />
Dim iLen As Integer<br />
Dim i As Long<br />
Dim strLabel As String<br />
<br />
If ReferenceDate = 0 Then<br />
ReferenceDate = Date<br />
End If<br />
<br />
DateString = Trim(UCase(DateString))<br />
DateString = Left(DateString, 16)<br />
<br />
If DateString = "SPOT" Then<br />
<br />
DateString = "2" 'Spot price - <span style="color: green;">'zero-day' plus settlement lag</span><br />
strLabel = "d"<br />
<br />
ElseIf DateString = "OVERNIGHT" Then<br />
<br />
DateString = "1"<br />
strLabel = "d"<br />
<br />
ElseIf DateString = "O/N" Then<br />
<br />
DateString = "1"<br />
strLabel = "d"<br />
<br />
ElseIf DateString = "DAILY" Then<br />
<br />
DateString = "1"<br />
strLabel = "d"<br />
<br />
ElseIf DateString = "WEEKLY" Then<br />
<br />
DateString = "7"<br />
strLabel = "d"<br />
<br />
ElseIf DateString = "ANNUAL" Then<br />
<br />
DateString = "1"<br />
strLabel = "yyyy" ' Year<br />
<br />
ElseIf DateString = "YEARLY" Then<br />
<br />
DateString = "1"<br />
strLabel = "yyyy" ' Year<br />
<br />
ElseIf DateString = "MONTHLY" Then<br />
<br />
DateString = "1"<br />
strLabel = "m"<br />
<br />
ElseIf DateString = "QUARTERLY" Then<br />
<br />
DateString = "3"<br />
strLabel = "m"<br />
<br />
ElseIf DateString = "SEMI-ANNUAL" Then<br />
<br />
DateString = "6"<br />
strLabel = "m"<br />
<br />
ElseIf DateString = "SEMIANNUAL" Then<br />
<br />
DateString = "6"<br />
strLabel = "m"<br />
<br />
ElseIf InStr(DateString, "MONTH") Then<br />
<br />
iLen = InStr(DateString, "M")<br />
strLabel = "m" <span style="color: green;">' Month"</span><br />
<br />
ElseIf InStr(DateString, "YEAR") Then<br />
<br />
iLen = InStr(DateString, "Y")<br />
strLabel = "yyyy" <span style="color: green;">' Year"</span><br />
<br />
ElseIf InStr(DateString, "DAY") Then<br />
<br />
iLen = InStr(DateString, "D")<br />
strLabel = "d" <span style="color: green;">' Day"</span><br />
<br />
ElseIf InStr(DateString, "M") Then<br />
<br />
iLen = InStr(DateString, "M")<br />
strLabel = "m" <span style="color: green;">' Month"</span><br />
<br />
ElseIf InStr(DateString, "Y") Then<br />
<br />
iLen = InStr(DateString, "Y")<br />
strLabel = "yyyy" <span style="color: green;">' Year"</span><br />
<br />
ElseIf InStr(DateString, "D") Then<br />
<br />
iLen = InStr(DateString, "D")<br />
strLabel = "d" <span style="color: green;">' Day"</span><br />
<br />
ElseIf InStr(DateString, "Q") Then<br />
<br />
iLen = InStr(DateString, "Q")<br />
strLabel = "q" <span style="color: green;">' Quarter"</span><br />
<br />
ElseIf InStr(DateString, "W") Then<br />
<br />
iLen = InStr(DateString, "W")<br />
strLabel = "ww" <span style="color: green;">' Week"</span><br />
<br />
ElseIf IsNumeric(DateString) Then<br />
<br />
iLen = Len(DateString)<br />
strLabel = "d" <span style="color: green;">' Day"</span><br />
<br />
Else<br />
<br />
GoTo ErrSub<br />
<br />
End If<br />
<br />
sNum = Trim(Left(DateString, iLen - 1))<br />
<br />
If Not IsNumeric(sNum) Then<br />
<br />
<span style="color: green;">'Trim down until we reach a number</span><br />
<br />
Do Until IsNumeric(sNum) Or Len(sNum) < 1<br />
<br />
sNum = Left(sNum, Len(sNum) - 1)<br />
sNum = Trim(sNum)<br />
<br />
<span style="color: green;">'Do not read "5-Year" as "Minus five years"</span><br />
<br />
If Right(sNum, 1) = "-" Then<br />
<br />
sNum = Left(sNum, Len(sNum) - 1)<br />
sNum = Trim(sNum)<br />
<br />
End If<br />
<br />
Loop<br />
<br />
End If<br />
<br />
If Len(sNum) < 1 Then<br />
GoTo ErrSub<br />
<br />
End If<br />
<br />
If Not IsNumeric(sNum) Then<br />
<br />
GoTo ErrSub<br />
<br />
End If<br />
<br />
i = CLng(sNum)<br />
<br />
If Subtract Then<br />
<br />
i = -1 * i<br />
<br />
End If<br />
<br />
<span style="color: green;"><br />
<br />
' Special handling required for adding months at EOM:<br />
' VBA.DateAdd("m", 1, "28 Feb 2006") = 28/03/2006 (!)<br />
' Business logic is ALWAYS that adding a month to EOM<br />
' gives the end of the following month - 31 Mar 2006.<br />
</span><br />
If strLabel = "m" Then<br />
<br />
If Month(ReferenceDate) <> Month(ReferenceDate) + 1 Then <span style="color: green;">'EOM detected</span><br />
<br />
ReferenceDate = ReferenceDate + 1<br />
AddDate = DateAdd(strLabel, i, ReferenceDate)<br />
AddDate = AddDate - 1<br />
<br />
Else<br />
<br />
AddDate = DateAdd(strLabel, i, ReferenceDate)<br />
<br />
End If<br />
<br />
Else<br />
<br />
AddDate = DateAdd(strLabel, i, ReferenceDate)<br />
<br />
End If<br />
<br />
ExitSub:<br />
<br />
Exit Function<br />
<br />
ErrSub:<br />
<br />
If Len(Dir(VB_HELPFILE)) > 0 Then<br />
<br />
Err.Raise 13, "AddDate Function", _<br />
"'" & DateString & "'" & " was not recognised as date interval." & vbCrLf _<br />
& vbCrLf _<br />
& "Try typing '10d', '3m' or '5y', or the date " & vbCrLf _<br />
& "interval as a number of calendar days.", _<br />
VB_HELPFILE, 1000013<br />
<br />
Else<br />
<br />
Err.Raise 13, "AddDate Function", _<br />
"'" & DateString & "'" & " was not recognised as date interval." & vbCrLf _<br />
& _<br />
vbCrLf _<br />
& "Try typing '10d', '3m' or '5y', or the date " & _<br />
vbCrLf _<br />
& "interval as a number of calendar days."<br />
<br />
End If<br />
<br />
<br />
<br />
End Function<br />
</span></FONT>
<BR />Nigel Heffernanhttp://www.blogger.com/profile/08954578765691578714noreply@blogger.com0tag:blogger.com,1999:blog-1800518423097919889.post-23561014894627169582012-07-21T10:28:00.000+01:002015-05-05T15:32:27.310+01:00A generic VBA Array To Range functionHere's a common task: <b>writing an array to a range</b>.
<br />
<br />
Here, we're writing an array to the sheet in a single 'hit' to the sheet. This is much faster than writing the data into the sheet one cell at a time in lops for the rows and columns.
<br />
<br />
However, there's some housekeeping to do, as you must specify the size of the target range correctly.
<br />
<br />
This 'housekeeping' looks like a lot of work and it's probably rather slow: but this is 'last mile' code to write to the sheet, and everything is faster than writing to the worksheet. Or at least, so much faster that it's effectively instantaneous, compared with a read or write to the worksheet, even in VBA, and you should do everything you possibly can in code before you hit the sheet.
<br />
<br />
A major component of this is error-trapping that I used to see turning up everywhere. I hate repetitive coding: I've coded it all here, and - hopefully - you'll never have to write it again.
<br />
<br />
As always, watch out for 'helpful' reformatting by your browser (or by Blogger) that inserts line breaks.
<br />
<br />
<pre><code lang="VB">
Option Explicit
Public Sub ArrayToRange(rngTarget As Excel.Range, InputArray As Variant)
' Write an array to an Excel range in a single 'hit' to the sheet
' InputArray expects a 2-Dimensional structure of the form Variant(Rows, Columns)
' Vector arrays will be written as an array of 1 to n rows in a single column
' The target range is resized automatically to the dimensions of the array, with
' the top left cell used as the start point.
' This subroutine saves repetitive coding for a common VBA and Excel task.
' If you think you won't need the code that works around common errors (long
' strings and objects in the array, etc) then feel free to comment it out.
On Error Resume Next
'
' Author: Nigel Heffernan Http://Excellerando.blogspot.com
'
'
' This code is in the public domain: take care to mark it clearly, and segregate
' it from proprietary code if you intend to assert intellectual property rights
' or impose commercial confidentiality restrictions on your proprietary code
Dim rngOutput As Excel.Range
Dim iRowCount As Long
Dim iColCount As Long
Dim iRow As Long
Dim iCol As Long
Dim arrTemp As Variant
Dim iDimensions As Integer
Dim iRowOffset As Long
Dim iColOffset As Long
Dim iStart As Long
Application.EnableEvents = False
If rngTarget.Cells.Count > 1 Then
rngTarget.ClearContents
End If
Application.EnableEvents = True
If IsEmpty(InputArray) Then
Exit Sub
End If
If TypeName(InputArray) = "Range" Then
InputArray = InputArray.Value
End If
' Is it actually an array? IsArray is sadly broken so...
If InStr(TypeName(InputArray), "(") < 1 Then
rngTarget.Cells(1, 1).Value2 = InputArray
Exit Sub
End If
iDimensions = ArrayDimensions(InputArray)
If iDimensions < 1 Then
rngTarget.Value = CStr(InputArray)
ElseIf iDimensions = 1 Then
ReDim arrTemp(LBound(InputArray) To UBound(InputArray), 1 To 1)
For iRow = LBound(InputArray) To UBound(InputArray)
arrTemp(iRow, 1) = InputArray(iRow)
Next iRow
ArrayToRange rngTarget, arrTemp
Erase arrTemp
ElseIf iDimensions >= 2 Then
iRowCount = UBound(InputArray, 1) - LBound(InputArray, 1)
iColCount = UBound(InputArray, 2) - LBound(InputArray, 2)
iStart = LBound(InputArray, 1)
If iRowCount > (65534 - rngTarget.Row) Then
iRowCount = 65534 - rngTarget.Row
InputArray = ArrayTranspose(InputArray)
ReDim Preserve InputArray(LBound(InputArray, 1) To UBound(InputArray, 1), iStart To iRowCount)
InputArray = ArrayTranspose(InputArray)
End If
iStart = LBound(InputArray, 2)
If iColCount > (rngTarget.Worksheet.Columns.Count - rngTarget.Column) Then
iColCount = rngTarget.Worksheet.Columns.Count - rngTarget.Column - 1
ReDim Preserve InputArray(LBound(InputArray, 1) To UBound(InputArray, 1), iStart To iColCount)
End If
With rngTarget.Worksheet
Set rngOutput = .Range(rngTarget.Cells(1, 1), rngTarget.Cells(iRowCount + 1, iColCount + 1))
Err.Clear
Application.EnableEvents = False
rngOutput.Value2 = InputArray
Application.EnableEvents = True
If Err.Number <> 0 Then
For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)
For iCol = LBound(InputArray, 2) To UBound(InputArray, 2)
If IsNumeric(InputArray(iRow, iCol)) Then
' no action
Else
InputArray(iRow, iCol) = "" & InputArray(iRow, iCol)
InputArray(iRow, iCol) = Trim(InputArray(iRow, iCol))
End If
Next iCol
Next iRow
Err.Clear
rngOutput.Formula = InputArray
End If 'err<>0
If Err <> 0 Then
For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)
For iCol = LBound(InputArray, 2) To UBound(InputArray, 2)
If IsNumeric(InputArray(iRow, iCol)) Then
' no action
Else
' Have we picked up values that can be read as a formula?
If Left(InputArray(iRow, iCol), 1) = "=" Then
InputArray(iRow, iCol) = "'" & InputArray(iRow, iCol)
End If
If Left(InputArray(iRow, iCol), 1) = "+" Then
InputArray(iRow, iCol) = "'" & InputArray(iRow, iCol)
End If
If Left(InputArray(iRow, iCol), 1) = "*" Then
InputArray(iRow, iCol) = "'" & InputArray(iRow, iCol)
End If
End If
Next iCol
Next iRow
Err.Clear
rngOutput.Value2 = InputArray
End If 'err<>0
If Err <> 0 Then
For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)
For iCol = LBound(InputArray, 2) To UBound(InputArray, 2)
If IsError(InputArray(iRow, iCol)) Then
InputArray(iRow, iCol) = "#ERROR"
ElseIf IsObject(InputArray(iRow, iCol)) Then
InputArray(iRow, iCol) = "[OBJECT] " & TypeName(InputArray(iRow, iCol))
ElseIf IsArray(InputArray(iRow, iCol)) Then
InputArray(iRow, iCol) = Split(InputArray(iRow, iCol), ",")
ElseIf IsNumeric(InputArray(iRow, iCol)) Then
' no action
Else
InputArray(iRow, iCol) = "" & InputArray(iRow, iCol)
If Len(InputArray(iRow, iCol)) > 255 Then
' Block-write operations fail on strings exceeding 255 chars. You
' have to go back and check, and write it out one cell at a time.
InputArray(iRow, iCol) = Left(Trim(InputArray(iRow, iCol)), 255)
End If
End If
Next iCol
Next iRow
Err.Clear
rngOutput.Text = InputArray
End If 'err<>0
If Err <> 0 Then
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
iRowOffset = LBound(InputArray, 1) - 1
iColOffset = LBound(InputArray, 2) - 1
For iRow = 1 To iRowCount
If iRow Mod 100 = 0 Then
Application.StatusBar = "Filling range... " & CInt(100# * iRow / iRowCount) & "%"
End If
For iCol = 1 To iColCount
rngOutput.Cells(iRow, iCol) = InputArray(iRow + iRowOffset, iCol + iColOffset)
Next iCol
Next iRow
Application.StatusBar = False
Application.ScreenUpdating = True
End If 'err<>0
Set rngTarget = rngOutput ' resizes the range This is useful, *most* of the time
End With ' rngTarget.Worksheet
End If ' iDimensions
End Sub
Private Function ArrayTranspose(InputArray As Variant) As Variant
Dim arrOutput As Variant
Dim i As Long
Dim j As Long
Dim iMin As Long
Dim iMax As Long
Dim jMin As Long
Dim jMax As Long
iMin = LBound(InputArray, 1)
iMax = UBound(InputArray, 1)
jMin = LBound(InputArray, 2)
jMax = UBound(InputArray, 2)
ReDim arrOutput(jMin To jMax, iMin To iMax)
For i = iMin To iMax
For j = jMin To jMax
arrOutput(j, i) = InputArray(i, j)
Next j
Next i
ArrayTranspose = arrOutput
End Function
Public Function ArrayDimensions(arr As Variant) As Integer
' Return values:
' -1 if arr is not an array
' 0 for an array variant that has not been dimensioned
' 1 to 255 for the array's dimensions.
' Special case: arr isn't a variant, it's a Range object
' Return the dimensions of the range's .Value() property
' VBA will pass the reference to a Range *object* (not the
' object's default property (the .Value variant) into your
' function, even though the parameter was declared as type
' variant. The 'least astonishment' approach to handling
' that is to defer to the infallibility of Microsoft's API
' decisions and return the dimensions of the range's value
' We ignore the possibility of a range with multiple areas
Dim i As Integer
Dim j As Long
If TypeName(arr) = "Range" Then
If arr Is Nothing Then
ArrayDimensions = 0
ElseIf arr.Areas(1).Cells.Count = 1 Then
ArrayDimensions = 1
Else
ArrayDimensions = 2
End If
ElseIf InStr(TypeName(arr), "(") < 1 Then
ArrayDimensions = -1
ElseIf IsEmpty(arr) Then
ArrayDimensions = 0
Else
On Error Resume Next
Err.Clear
For i = 1 To 255
j = 0
j = UBound(arr, i)
If Err.Number <> 0 Then
ArrayDimensions = i - 1
Exit For
End If
Next i
If i > 255 Then ' not a VBA-compatible array
ArrayDimensions = -1
End If
End If
End Function
</code>
</pre>
<br />
<br />
Please keep the acknowledgements in your source code: as you progress in your career as a developer, you will come to appreciate your own contributions being acknowledged.
<br />
<br />
Nigel Heffernanhttp://www.blogger.com/profile/08954578765691578714noreply@blogger.com0tag:blogger.com,1999:blog-1800518423097919889.post-39909268750398003032012-02-17T07:31:00.000+00:002012-02-17T07:38:47.002+00:00Using the sadly broken Excel Worksheet 'CustomProperties' collectionI think the comment explains it all.<br /><br /><pre><br />Public Function GetCustomProperty(ws As Worksheet, PropertyName As String) As Variant<br /><font color="Green"><br />' Return the value of a user-specified worksheet property created as:<br />'<br />p' Ws.CustomProperties.Add Name:="Report Type", Value:"Balance Sheet"<br />'<br />' Return value is NULL if the named property does not exist<br />'<br /><br />' Nigel Heffernan 07 April 2008<br /><br />' Return the value of an Excel Worksheet Custom Property<br />' This is necessary because Microsoft have not implemented<br />' CustomProperties as a VBA collection: names are not indexed<br />' and the numeric position is NOT the ordinal: it's the<br />' position of the named property in an alphabetic sort by name.<br />'<br />' Maybe future releases will clear this up.<br />'<br /></FONT><br />Dim i As Integer<br /><br />GetCustomProperty = Null<br /><br /><br /> For i = 1 To ws.CustomProperties.Count<br /> If ws.CustomProperties(i).name = PropertyName Then<br /> GetCustomProperty = ws.CustomProperties(i).Value<br /> Exit Function<br /> End If<br /> Next i<br /> <br />End Function<br /><br /></PRE><br /><br />Maybe this was fixed in 2010: it's still broken in Excel 2010. Some days, I think that Aspirin should be listed under 'Programming Tools'Nigel Heffernanhttp://www.blogger.com/profile/08954578765691578714noreply@blogger.com1tag:blogger.com,1999:blog-1800518423097919889.post-1031511286978006712011-11-04T11:17:00.000+00:002014-11-04T11:40:38.068+00:00The Flasher: Show A Cell, Cells, Or Merged Cells With A Warning ColourThis is a common theme: your sheet contains a cell for a file location, some macro runs with the value, and fails because the file address is invalid.
<BR /><BR />
Fine, we've all written error-handlers for that, and we can write informative error messages telling the user what's gone wrong, and what to do next.
<BR /><BR />
And we all *do* do this... Right?
<BR /><BR />
As useful bit of user interface work is to flash up the range with the bad data, changing the background colour to red, and back again, two or three times. It's an easy bit of code to write, until you run into ranges containing merged cells - which are a nuisance, but an occasional necessity - because the <CODE LANG="VB">range.interior.color</CODE> property fails silently on merged cells.
<BR /><BR />
We also have a second consideration: interior.color sometimes returns zero for cells with no interior colour. This is embarrassing when you've read the original colour as zero and 'restore' the range to that after flashing and ringing bells.
<BR /><BR />
This is the code to flash a cell in red, three times (the default settings for 'WarningFlash'):
<PRE>WarningFlash rngFileControl.Cells(iRow, iCol)</PRE>
And this is what the code looks like to flash the cell (or merged cells) behind a command button, twice, in a tasteful yellow colour:
<PRE>WarningFlash rngFileControl.Rows.Worksheet.OLEObjects("cmdSelectFiles").TopLeftCell, &HFFFF, 2</PRE>
Note that we select the top-left cell of the range: <b>my code for merged ranges only works if you specify the whole of the merge, or the first cell in the merge</B>. And yes, I often put COM control buttons in merged cells: a well-formatted button with a 16*16 icon is twice the height of a standard Excel row, and I prefer to have the control in a merged single cell because 'move and size with cells' works badly if the control spans more than one cell.
<BR /><BR />
Coding Note: best-practice would be to save your favourite colours as constants, or to use the built-in VBA colour constant for yellow: VBA.ColorConstants.vbYellow
<BR /><BR />
So, without further ado, the source for the WarningFlash subroutine:
<PRE>
Public Sub WarningFlash(FlashRange As Excel.Range, _ <BR /> Optional WarningColor As Long = &HFF, _ <BR /> Optional FlashCount As Integer = 3)
Dim lngPriorColor As Long
Dim i As Integer
Dim rng As Excel.Range
' This unwieldly syntax works on ranges of merged cells, if you specify the top left cell
Set rng = FlashRange.Areas(1).Worksheet.Range(FlashRange.Areas(1).Address)
lngPriorColor = rng.Interior.Color
If lngPriorColor = 0 Then Exit Sub
For i = 1 To FlashCount
rng.Interior.Color = WarningColor
Sleep 500
rng.Interior.Color = lngPriorColor
Sleep 500
Next i
End Sub
</PRE>
And now for the difficult bit: I'm using 'sleep', because Application.Wait only works in whole seconds. That API declaration needs to work in all Windows versions, and in all versions of VBA:
<PRE>
#If VBA7 And Win64 Then ' 64 bit Excel under 64-bit windows
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongLong)
#ElseIf VBA7 Then ' 64 bit Excel in all environments
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else ' 32 bit Excel
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
</PRE>
Let me know how you get on: or, better still, post your own solutions.
<BR /><BR /><BR /><BR />
Nigel Heffernanhttp://www.blogger.com/profile/08954578765691578714noreply@blogger.com0tag:blogger.com,1999:blog-1800518423097919889.post-90378261320668954122011-08-30T19:46:00.008+01:002011-08-30T21:08:23.526+01:00Demising VBA: the caret and stick approach<P Align="justify">I haven't been posting much in the last year, because the work I'm doing is under contract and I don't own the source code... So I can't publish it here. I can't complain: everyone's tightened up the IP and disclosure rules in their contracts and workng quietly beats hell out of not working.
<br />
<br />So, in the absence of any actual content from me, here's a little gem from <A Href="http://www.tushar-mehta.com/publish_train/xl_vba_cases/1016%20Office%202010%20VBA.shtml" alt="Link to the full article Tushar Mehta's site">Tushar Mehta, on VBA in Office 2010</A>:</P>
<br /><cite src="http://www.tushar-mehta.com/publish_train/xl_vba_cases/1016%20Office%202010%20VBA.shtml"><P Align="justify">To support this new data type, Microsoft also introduced the CLngLng function, the VarType constant vbLongLong, and the DefType statement DefLngLng. The type declaration character is ^. This can cause problems while typing VBA statements that use the exponentiation operator, which is also ^.</P></cite><P Align="justify">
<br />Feel free to read the details... And remember to insert a space before indicating an exponent in your calculations.
<br />
<br />I wonder what else is out there, waiting to be discovered. I wonder, also, whether any other financial institution has made the transition to Office 2010, outside of a few 'early adopters' who amuse and entertain their IT staff with their ingenuity. We've only got about 50,000 regular users, worldwide - regular as in 'I use it every day in a critical part of my job', and probably twice that number of occasionals, so we're talking about a fair chunk of revenue for Microsoft here, and you'd think they'd make it easy for us to migrate.
<br />
<br />Actually, you know Microsoft: you know damn' well they've made it difficult.
<br />
<br />Everything we've done in terms of macros and reports, all the way up to add-ins and fully-developed applications, will need some testing - that's standard for all Office upgrades, even service patches - and we test the complex ones quite thoroughly. You'd think there might be tools, and scripts, and maybe even checklists and case studies. But no: Microsoft is unlike any other software vendor. And we start this job *knowing* that everything we've build that uses the application menubar is broken, by design, by Microsoft's insistence on imposing the new 'Ribbon Bar' with no concession whatsoever to supporting backward compatibility... I predict thet we'll be using Office 2003 well into 2012; and that there are major companies as big as us, or bigger, who'll be using it in 2014.
<br />
<br />Ultimately, Microsoft will kill off VBA and this is just another nail in the coffin; they are, if you will, putting the caret before the hearse.</P>
<br />Nigel Heffernanhttp://www.blogger.com/profile/08954578765691578714noreply@blogger.com0tag:blogger.com,1999:blog-1800518423097919889.post-14133514108570485142011-02-17T08:12:00.003+00:002012-02-17T08:27:23.767+00:00Adding a month to the end of the month: another Excel annoyanceEver see a column of month-end payment days do this in a spreadsheet?<br><br /><br><blockquote><br /> 31/08/2005<br><br /> 30/11/2005<br><br /> 28/02/2006<br><br /> 28/05/2006<br><br /> 28/08/2006<br><br /> 28/11/2006<br><br /> 28/02/2007<br><br /> 28/05/2007<br><br /> 28/08/2007<br><br /> 28/11/2007<br><font color="red"><br /> 28/02/2008<br></font></blockquote><br /><br><br />Sigh. All VBA developers eventually face the weary task of correcting the VBA.DateTime function library because of this loathsome miscoding by Microsoft:<br /><br><blockquote><br /><font color="Green" face="FixedSys, System, Terminal"><br><br />' Special handling required for adding months at EOM:<br><br />' VBA.DateAdd("m", 1, "28 Feb 2006") = 28/03/2006 (!)<br><br />' Business logic is ALWAYS that adding a month to EOM<br><br />' gives the end of the following month - 31 Mar 2006.<br><br /></font><br></blockquote><br /><br /><br><br />Here's my solution: I guess you've all got one of your own by now. <br><br /><br><br />The usual health warning applies to ATTRIBUTE statements: they are not recognised by the VBA editor, you have to drag-and-drop the entire module out of the VB IDE, insert the statements manually in notepad, and drag the object back. In case you didn't know, the VB_ProcData attribute places AddDate in the 'Date & Time' category of the Spreadsheet Function Wizard, instead of letting it languish in obscurity under 'User-Defined'.<br /><br><br /><br><br /><font face="FixedSys, System, Terminal"><br><pre><br />Public Function AddDate( _<br> ByVal DateString As String, _<br> Optional ByVal ReferenceDate As Date _<br> Optional Subtract As Boolean = False _<br> ) As Date<br><br /><font color="#C0C0C0" size="1">'ATTRIBUTE AddDate.VB_Description="Add a datestring of the form '1m', '10d' or '5y' to the reference date. \r\nBy default the reference date is the current date. \r\nInteger dates only: time expressed as fractional days is discarded. \r\nAll addition and subtraction uses Actual/Actual: no other date convention is implemented.</font><br><br /><font color="#C0C0C0" size="1">'ATTRIBUTE AddDate.VB_ProcData.VB_Invoke_Func = " \n2"</font><br /><font color="Green"><br><br /><br><br />'Nigel Heffernan 2001 <br><br /><br><br /><br><br />'THIS CODE IS IN THE PUBLIC DOMAIN<br><br /><br><br /><br><br />'Add a datestring of the form '1m', '10d' or '5y' to the reference date.<br><br />'By default the reference date is the current date.<br><br />'Integer dates only: time expressed as fractional days is discarded.<br><br />'All addition and subtraction uses Actual/Actual: no other date convention is implemented.<br><br /></font><br><br />Const VB_HELPFILE As String = "C:\PROGRA~1\COMMON~1\MICROS~1\VBA\VBA6\1033\VbLR6.chm"<br><br /><font color="Green">' I'm too lazy to do the proper registry lookup for this help file.<br><br /></font><br><br />On Error GoTo ErrSub<br><br /><br><br />Dim sNum As String<br><br />Dim iLen As Integer<br><br />Dim i As Long<br><br />Dim strLabel As String<br><br /><br><br />If ReferenceDate = 0 Then<br><br /> ReferenceDate = Date<br><br />End If<br><br /><br><br /><br><br />DateString = Trim(UCase(DateString))<br><br />DateString = Left(DateString, 16)<br><br /><br><br />If DateString = "SPOT" Then<br><br /><br><br /> DateString = "2" 'Spot price - <font color="Green">'zero-day' plus settlement lag</font><br><br /> strLabel = "d"<br><br /> <br><br />ElseIf DateString = "OVERNIGHT" Then<br><br /><br><br /> DateString = "1"<br><br /> strLabel = "d"<br><br /> <br><br />ElseIf DateString = "O/N" Then<br><br /><br><br /> DateString = "1"<br><br /> strLabel = "d"<br><br /><br><br />ElseIf DateString = "DAILY" Then<br><br /><br><br /> DateString = "1"<br><br /> strLabel = "d"<br><br /><br><br />ElseIf DateString = "WEEKLY" Then<br><br /><br><br /> DateString = "7"<br><br /> strLabel = "d"<br><br /> <br><br />ElseIf DateString = "ANNUAL" Then<br><br /><br><br /> DateString = "1"<br><br /> strLabel = "yyyy" ' Year<br><br /><br><br />ElseIf DateString = "YEARLY" Then<br><br /><br><br /> DateString = "1"<br><br /> strLabel = "yyyy" ' Year<br><br /><br><br />ElseIf DateString = "MONTHLY" Then<br><br /><br><br /> DateString = "1"<br><br /> strLabel = "m"<br><br /><br><br />ElseIf DateString = "QUARTERLY" Then<br><br /><br><br /> DateString = "3"<br><br /> strLabel = "m"<br><br /><br><br />ElseIf DateString = "SEMI-ANNUAL" Then<br><br /><br><br /> DateString = "6"<br><br /> strLabel = "m"<br><br /><br><br />ElseIf DateString = "SEMIANNUAL" Then<br><br /><br><br /> DateString = "6"<br><br /> strLabel = "m"<br><br /><br><br />ElseIf InStr(DateString, "MONTH") Then<br><br /><br><br /> iLen = InStr(DateString, "M")<br><br /> strLabel = "m" <font color="Green">' Month"</font><br><br /><br><br />ElseIf InStr(DateString, "YEAR") Then<br><br /><br><br /> iLen = InStr(DateString, "Y")<br><br /> strLabel = "yyyy" <font color="Green">' Year"</font><br><br /><br><br />ElseIf InStr(DateString, "DAY") Then<br><br /><br><br /> iLen = InStr(DateString, "D")<br><br /> strLabel = "d" <font color="Green">' Day"</font><br><br /><br><br />ElseIf InStr(DateString, "M") Then<br><br /><br><br /> iLen = InStr(DateString, "M")<br><br /> strLabel = "m" <font color="Green">' Month"</font><br><br /><br><br />ElseIf InStr(DateString, "Y") Then<br><br /><br><br /> iLen = InStr(DateString, "Y")<br><br /> strLabel = "yyyy" <font color="Green">' Year"</font><br><br /><br><br />ElseIf InStr(DateString, "D") Then<br><br /><br><br /> iLen = InStr(DateString, "D")<br><br /> strLabel = "d" <font color="Green">' Day"</font><br><br /><br><br />ElseIf InStr(DateString, "Q") Then<br><br /><br><br /> iLen = InStr(DateString, "Q")<br><br /> strLabel = "q" <font color="Green">' Quarter"</font><br><br /><br><br />ElseIf InStr(DateString, "W") Then<br><br /><br><br /> iLen = InStr(DateString, "W")<br><br /> strLabel = "ww" <font color="Green">' Week"</font><br><br /><br><br />ElseIf IsNumeric(DateString) Then<br><br /><br><br /> iLen = Len(DateString)<br><br /> strLabel = "d" <font color="Green">' Day"</font><br><br /> <br><br /> <br><br />Else<br><br /><br><br /> GoTo ErrSub<br><br /> <br><br />End If<br><br /><br><br /><br><br />sNum = Trim(Left(DateString, iLen - 1))<br><br /> <br><br /><br><br />If Not IsNumeric(sNum) Then<br><br /><br><br /> <font color="Green">'Trim down until we reach a number</font><br><br /> <br><br /> Do Until IsNumeric(sNum) Or Len(sNum) < 1<br><br /> <br><br /> sNum = Left(sNum, Len(sNum) - 1)<br><br /> sNum = Trim(sNum)<br><br /> <br><br /> <font color="Green">'Do not read "5-Year" as "Minus five years"</font><br><br /> If Right(sNum, 1) = "-" Then<br><br /> sNum = Left(sNum, Len(sNum) - 1)<br><br /> sNum = Trim(sNum)<br><br /> End If<br><br /> <br><br /> Loop<br><br /> <br><br />End If<br><br /><br><br />If Len(sNum) < 1 Then<br><br /> GoTo ErrSub<br><br />End If<br><br /><br><br />If Not IsNumeric(sNum) Then<br><br /> GoTo ErrSub<br><br />End If<br><br /><br><br />i = CLng(sNum)<br><br /><br><br />If Subtract Then<br><br /> i = -1 * i<br><br />End If<br><br /><font color="Green"><br><br />' Special handling required for adding months at EOM:<br><br />' VBA.DateAdd("m", 1, "28 Feb 2006") = 28/03/2006 (!)<br><br />' Business logic is ALWAYS that adding a month to EOM<br><br />' gives the end of the following month - 31 Mar 2006.<br><br /></font><br><br />If strLabel = "m" Then<br><br /><br><br /> If Month(ReferenceDate) <> Month(ReferenceDate) + 1 Then <font color="Green">'EOM detected</font><br><br /> ReferenceDate = ReferenceDate + 1<br><br /> AddDate = DateAdd(strLabel, i, ReferenceDate)<br><br /> AddDate = AddDate - 1<br><br /> Else<br><br /> AddDate = DateAdd(strLabel, i, ReferenceDate)<br><br /> End If<br><br /> <br><br />Else<br><br /><br><br /> AddDate = DateAdd(strLabel, i, ReferenceDate)<br><br /> <br><br />End If<br><br /><br><br />ExitSub:<br><br /> Exit Function<br><br /> <br><br />ErrSub:<br><br /><br><br /> If Len(Dir(VB_HELPFILE)) > 0 Then<br><br /> Err.Raise 13, "AddDate Function", _<br> "'" & DateString & "'" & " was not recognised as date interval." & vbCrLf _<br> & vbCrLf _<br> & "Try typing '10d', '3m' or '5y', or the date " & vbCrLf _<br> & "interval as a number of calendar days.", _<br> VB_HELPFILE, 1000013<br><br /> Else<br><br /> Err.Raise 13, "AddDate Function", _<br> "'" & DateString & "'" & " was not recognised as date interval." & vbCrLf _<br> & _<br> vbCrLf _<br> & "Try typing '10d', '3m' or '5y', or the date " & _<br> vbCrLf _<br> & "interval as a number of calendar days."<br><br /> End If<br><br /> <br><br />End Function<br><br /><br></font></pre>Nigel Heffernanhttp://www.blogger.com/profile/08954578765691578714noreply@blogger.com0tag:blogger.com,1999:blog-1800518423097919889.post-60434587577947130752010-09-23T21:17:00.000+01:002014-10-02T17:36:08.384+01:00Hashing algorithms: Adler32 implemented in VBA
I could've sworn I posted this here, years ago, but here's an implementation of Adler-32 in 32-bit VBA.
<BR /><BR />
There's a horrible hack in it: Adler-32 returns a 32-bit integer, and the VBA Long is a signed integer with a range ± (2^31) -1, so I've implemented a 'wrap around' of the overflow at +2^31, restarting at -2^31 +1. And done something I really, really shouldn't have done with a floating-point variable. Eventually everyone, everywhere, will have 64-bit Office and this'll be kind of quaint and unnecessary... Right?
<BR /><BR />
Of course, the real question is: why bother?
<BR /><BR />
It boils down to the common question of checking for changes: if you don't want to use the 'on change' event, or you're dealing with data directly in VBA before it hits the sheet, large data sets need something better than an item-by-item brute force approach. At least, if you're doing it more than once: the cost of rolling each item into your hash is always more than the cost of the one-by-one comparison...
<BR /><BR />
...And that's still true if you're importing a fast hashing algorithm from MySQL or one of the web API libraries (try MDA5, if you can get at an exposed function), unless you can find something that reads VBA variant arrays directly and relieve your VBA thread of the task of enumerating the list values into the imported function.
<BR /><BR />
Meanwhile, here's a hash algorithm that's within reach of VBA: Adler32. The details are in Wikipedia’s article on Adler32: http://en.wikipedia.org/wiki/Adler-32 and an hour's testing will teach you some lessons about hashing:
<OL><LI>'Hash collisions' (differing data sets returning the same hash code) are more common than you expected, especially with data containing repeated patterns (like dates);></LI><LI>Choice of hashing algorithm is important;</LI><LI>...And that choice is more of an art than a science;</LI><LI>Admitting that you really shouldn't have bothered and resorting to brute force is often the better part of valour.</LI></OL>
<BR /><BR />
Adler-32 is actually more useful as a tool to teach those lessons, than as a workaday checksum. It's great for detecting changes in lists of more than 100 distinct items; it's tolerable, on a list of 24 randomly-generated 8-letter words (hash collisions at 1 in 1800 attempts) and it starts giving you single-digit percentage occurrences of the hash collision error in a list of 50 not-so-distinct option maturities, where the differences are mostly in the last 10 chars and *those* ten chars are recurring 3-month maturity dates.
<BR /><BR />
By the time you're comparing pairs of 6-letter strings, more than 10% of your changes will be missed by the checksum in a non-random data set. And then you realise that might as well be using string comparison for that kind of trivial computation anyway.
<BR /><BR />
So the answer is always: test it.
<BR /><BR />
Meanwhile, here's the algorithm, horrible hacks and all:<BR /><BR />
<PRE>
Option Explicit
Public Function CheckSum(ByRef ColArray As Variant) As Long
Application.Volatile False
' Returns an Adler32 checksum of all the numeric and text values in a column
' Capture data from cells as myRange.Value2 and use a 32-bit checksum to see
' if any value in the range subsequently changes. You can run this on multi-
' column ranges, but it's MUCH faster to run this separately for each column
'
' Note that the VBA Long Integer data type is *not* a 32-bit integer, it's a
' signed integer with a range of ± (2^31) -1. So our return value is signed
' and return values exceeding +2^31 -1 'wraparound' and restart at -2^31 +1.
' Coding Notes:
' This is intended for use in VBA, and not for use on the worksheet. Use the
' setting 'Option Private Module' to hide CheckSum from the function wizard
' Author: Nigel Heffernan, May 2006 http://excellerando.blogspot.com
' Acknowledgements and thanks to Paul Crowley, who recommended Adler-32
' Please note that this code is in the public domain. Mark it clearly, with
' the author's name, and segregate it from any proprietary code if you need
' to assert ownership & commercial confidentiality on your proprietary code
Const LONG_LIMIT As Long = (2 ^ 31) - 1
Const MOD_ADLER As Long = 65521
Dim a As Long
Dim b As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim arrByte() As Byte
Dim dblOverflow As Double
If TypeName(ColArray) = "Range" Then
ColArray = ColArray.Value2
End If
If IsEmpty(ColArray) Then
CheckSum = 0
Exit Function
End If
If (VarType(ColArray) And vbArray) = 0 Then
' single-cell range, or a scalar data type
ReDim arrData(0 To 0, 0 To 0)
arrData(0, 0) = CStr(ColArray)
Else
arrData = ColArray
End If
a = 1
b = 0
For j = LBound(arrData, 2) To UBound(arrData, 2)
For i = LBound(arrData, 1) To UBound(arrData, 1)
' VBA Strings are byte arrays: arrByte(n) is faster than Mid$(s, n)
arrByte = CStr(arrData(i, j)) ' Is this type conversion efficient?
For k = LBound(arrByte) To UBound(arrByte)
a = (a + arrByte(k)) Mod MOD_ADLER
b = (b + a) Mod MOD_ADLER
Next k
' Terminating each item with a 'vTab' char constructs a better hash
' than vbNullString which, being equal to zero, adds no information
' to the hash and therefore permits the clash ABCD+EFGH = ABC+DEFGH
' However, we wish to avoid inefficient string concatenation, so we
' roll the terminating character's bytecode directly into the hash:
a = (a + 11) Mod MOD_ADLER ' vbVerticalTab = Chr(11)
b = (b + a) Mod MOD_ADLER
Next i
' Roll the column into the hash with a terminating horizontal tab char:
a = (a + 9) Mod MOD_ADLER ' Horizontal Tab = Chr(9)
b = (b + a) Mod MOD_ADLER
Next j
' Using a float in an integer calculation? We can get away with it, because
' the float error for a VBA double is < ±0.5 with numbers smaller than 2^32
dblOverflow = (1# * b * MOD_ADLER) + a
If dblOverflow > LONG_LIMIT Then ' wraparound 2^31 to 1-(2^31)
Do Until dblOverflow < LONG_LIMIT
dblOverflow = dblOverflow - LONG_LIMIT
Loop
CheckSum = 1 + dblOverflow - LONG_LIMIT
Else
CheckSum = b * MOD_ADLER + a
End If
End Function
</PRE>Nigel Heffernanhttp://www.blogger.com/profile/08954578765691578714noreply@blogger.com0tag:blogger.com,1999:blog-1800518423097919889.post-73359167282471026162010-03-01T21:14:00.010+00:002014-05-13T14:37:53.486+01:00VLookup() with fuzzy-matching to get a 'closest match' result<div align="justify">
<br />Ever had to look up a name or an address in a list that doesn't quite match, so the standard Excel 'VLookup()' and 'Match()' functions don't help you?</div>
Here's the solution:<br />
<br />
<a href="https://blogger.googleusercontent.com/img/b/R29vZ2xl/AVvXsEjY8Y5bq_OGEYWeSzc7ru4bTfENkPfu3rnyUQV0W0ZygguTNfffzavH-Hv5LFW1lSGhIzVHsR2Etrz5wNQC9onT2AoJKd9OSIeWpg8y8R4qgMaGA3-SSt78dH58MQN7drjbbNq7zEkYbpU/s1600-h/FuncArgs2.jpg" onblur="try {parent.deselectBloggerImageGracefully();} catch(e) {}"><img alt="" border="0" src="https://blogger.googleusercontent.com/img/b/R29vZ2xl/AVvXsEjY8Y5bq_OGEYWeSzc7ru4bTfENkPfu3rnyUQV0W0ZygguTNfffzavH-Hv5LFW1lSGhIzVHsR2Etrz5wNQC9onT2AoJKd9OSIeWpg8y8R4qgMaGA3-SSt78dH58MQN7drjbbNq7zEkYbpU/s400/FuncArgs2.jpg" id="BLOGGER_PHOTO_ID_5443792723774202754" style="cursor: pointer; display: block; height: 285px; margin: 0px auto 10px; text-align: center; width: 400px;" /></a><br />
<div align="justify">
The answer is 'Fuzzy Matching', a process of applying rules and picking out a 'best fit'. In the case of text - words, addresses, alphanumeric codes like ISIN identifiers for shares, bonds and other financial instruments - the best approach is the Levenshtein Edit Distance algorithm, a measure of how many characters were changed or moved to get from one text to another; but I've gone for a simplified approach that adds up how much of text A is made up of recognisable fragments of text B. </div>
<div align="justify">
It works surprisingly well, but there are some limitations. There's a more detailed discussion of this in the preceding post: feel free to offer some suggestions and comments there: what you're reading <i>here</i> is the application of these abstract principles to spreadsheets. Click on the image: it'll <i>show</i> you how the function is used.</div>
<div align="justify">
What's missing is a version of <b>Match()</b> (you can code that up for yourselves), and a dedicated 'FuzzyVLookupAddress()' function, tweaked to deal with the peculiar things that we do to postal addresses to make them extraordinarily difficult for computers (and spreadsheets!) to read. Instead, I've provided a crude <b>'NormaliseAddress'</b> function, which standardises all those troublesome Aves, Avenues, Streets, Saints and St.'s. Apply it to the addresses in your list (and to the search term you're trying to look up) and let me know how you get on.</div>
<div align="justify">
Enough witter: the code's below. It's been tested for cut-and-paste out of Blogger, but there's always a health warning: Blogger will munge the line breaks, and so will whatever you're using to view this post, especially if it's an RSS feed.</div>
<br />
<br />
<span style="font-family: FixedSys, System, Terminal, Courier New;"><br /><br />Option Explicit<br /><br /><br />Public Function FuzzyVLookup(Lookup_Value As String, _<br /> Table_Array As Variant, _ <br /> Optional Col_Index_Num As Integer = 1, _<br /> Optional Compare As VbCompareMethod = vbTextCompare _ <br /> ) As Variant<br /><!--<br />Attribute FuzzyVLookup.VB_Description = "Find the best match for a given string in column 1 of an array of data\r\nThis is functionally similar to VLookup, but it returns the best match, not the first exact match\r\nThis function is not case-sensitive, unless you specify 'Compare' as 0 or vbBinaryCompare\r\n\r\n' If your data quality is poor, you are advised to display the retrieved index value from column 1 and use the FuzzyMatchScore() function on this index value to reveal the fuzzy-matching 'score' and discard all results below a threshold value."<br />--><span style="color: green;"><br />' Find the best match for a given string in column 1 of an array of data obtained from an Excel range<br />' This is functionally similar to VLookup, but it returns the best match, not the first exact match<br />' This function is not case-sensitive, unless you specify 'Compare' as 0 or vbBinaryCompare<br /><br />' If your data quality is poor, you are advised to display the retrieved index value from column 1<br />' and use the FuzzyMatchScore() function on this index value to reveal the fuzzy-matching 'score' and<br />' discard all results below a threshold value. Feel free to code up a 'threshold' parameter!<br /><br />' If you are looking up names and addresses, use the NormaliseAddress() function on your search term and<br />' searched population to standardise abbreviations and word-order conventions used in British addresses.<br /><br />' THIS CODE IS IN THE PUBLIC DOMAIN</span><br /><br />Application.Volatile False<br /><br />Dim dblBestMatch As Double<br /><br />Dim iRowBest As Integer<br />Dim dblMatch As Double<br />Dim iRow As Integer<br />Dim strTest As String<br />Dim strInput As String<br /><br />Dim iStartCol As Integer<br />Dim iEndCol As Integer<br />Dim iOffset As Integer<br /><br />If InStr(TypeName(Table_Array), "(") + InStr(1, TypeName(Table_Array), "Range", vbTextCompare) < 1 Then<br /> <span style="color: green;"> 'Table_Array is not an array </span><br /> FuzzyVLookup = "#VALUE"<br /> Exit Function<br />End If<br /><br />If InStr(1, TypeName(Table_Array), "Range", vbTextCompare) > 0 Then<br /> Table_Array = Table_Array.Value<br />End If<br /><span style="color: green;"><br />' If you get a subscript-out-of-bounds error here, you're using a vector instead<br />' of the 2-dimensional array that is the default 'Value' property of an Excel range.</span><br /><br />iStartCol = LBound(Table_Array, 2)<br />iEndCol = UBound(Table_Array, 2)<br />iOffset = 1 - iStartCol<br /><br /><br />Col_Index_Num = Col_Index_Num - iOffset<br /><br />If Col_Index_Num > iEndCol Or Col_Index_Num < iStartCol Then<br /> <span style="color: green;"> 'Out-of-bounds</span><br /> FuzzyVLookup = "#VALUE"<br /> Exit Function<br />End If<br /><br /><br /><br /> strInput = UCase(Lookup_Value)<br /><br /> iRowBest = -1<br /> dblBestMatch = 0<br /><br /> For iRow = LBound(Table_Array, 1) To UBound(Table_Array, 1)<br /><br /> strTest = ""<br /> strTest = Table_Array(iRow, iStartCol)<br /><br /> dblMatch = 0<br /> dblMatch = FuzzyMatchScore(strInput, strTest, Compare)<br /><br /> If dblMatch = 1 Then ' Bail out on finding an exact match<br /> iRowBest = iRow<br /> Exit For<br /> End If<br /><br /> If dblMatch > dblBestMatch Then<br /> dblBestMatch = dblMatch<br /> iRowBest = iRow<br /> End If<br /><br /> Next iRow<br /><br /><br /> If iRowBest = -1 Then<br /> FuzzyVLookup = "#NO MATCH"<br /> Exit Function<br /> End If<br /><br /> FuzzyVLookup = Table_Array(iRowBest, Col_Index_Num)<br /><br />End Function<br /> <br />Public Function FuzzyHLookup(Lookup_Value As String, _ <br /> Table_Array As Variant, _ <br /> Optional Row_Index_Num As Integer = 1, _ <br /> Optional Compare As VbCompareMethod = vbTextCompare)<br /><span style="color: green;"><br />' Find the best match for a given string in Row 1 of an array of data obtained from an Excel range<br />' This is functionally similar to HLookup, but it returns the best match, not the first exact match<br />' This function is not case-sensitive, unless you specify 'Compare' as vbTextBinary.<br /><br />' If your data quality is poor, you are advised to display the retrieved index value from row 1<br />' and use the FuzzyMatchScore() function on this index value to reveal the fuzzy-matching 'score' and<br />' discard all results below a threshold value. Feel free to code up a 'threshold' parameter!<br /><br />' If you are looking up names and addresses, use the NormaliseAddress() function on your search term and<br />' searched population to standardise abbreviations and word-order conventions used in British addresses.<br /><br />' THIS CODE IS IN THE PUBLIC DOMAIN</span><br /><br />Application.Volatile False<br /><br />Dim dblBestMatch As Double<br /><br />Dim iColBest As Integer<br />Dim dblMatch As Double<br />Dim iCol As Integer<br />Dim strTest As String<br />Dim strInput As String<br /><br />Dim iStartRow As Integer<br />Dim iEndRow As Integer<br />Dim iOffset As Integer<br /><br />If InStr(TypeName(Table_Array), "(") + InStr(1, TypeName(Table_Array), "Range", vbTextCompare) < 1 Then<br /> <span style="color: green;"> 'Table_Array is not an array </span><br /> FuzzyHLookup = "#VALUE"<br /> Exit Function<br />End If<br /><br />If InStr(1, TypeName(Table_Array), "Range", vbTextCompare) > 0 Then<br /> Table_Array = Table_Array.Value<br />End If<br /><span style="color: green;"><br />' If you get a subscript-out-of-bounds error here, you're using a vector instead<br />' of the 2-dimensional array that is the default 'Value' property of an Excel range.</span><br /><br />iStartRow = LBound(Table_Array, 1)<br />iEndRow = UBound(Table_Array, 1)<br />iOffset = 1 - iStartRow<br /><br /><br />Row_Index_Num = Row_Index_Num - iOffset<br /><br />If Row_Index_Num > iEndRow Or Row_Index_Num < iStartRow Then<br /> <span style="color: green;"> 'Out-of-bounds </span><br /> FuzzyHLookup = "#VALUE"<br /> Exit Function<br />End If<br /><br /><br /> strInput = UCase(Lookup_Value)<br /><br /> iColBest = -1<br /> dblBestMatch = 0<br /><br /> For iCol = LBound(Table_Array, 2) To UBound(Table_Array, 2)<br /><br /> strTest = ""<br /> strTest = Table_Array(iStartRow, iCol)<br /><br /> dblMatch = 0<br /> dblMatch = FuzzyMatchScore(strInput, strTest, Compare)<br /><br /> If dblMatch = 1 Then ' Bail out on finding an exact match<br /> iColBest = iCol<br /> Exit For<br /> End If<br /><br /> If dblMatch > dblBestMatch Then<br /> dblBestMatch = dblMatch<br /> iColBest = iCol<br /> End If<br /><br /> Next iCol<br /><br /><br /> If iColBest = -1 Then<br /> FuzzyHLookup = "#NO MATCH"<br /> Exit Function<br /> End If<br /><br /> FuzzyHLookup = Table_Array(Row_Index_Num, iColBest)<br /><br />End Function<br /><br /><br />Public Function FuzzyMatchScore(ByVal str1 As String, _ <br /> ByVal str2 As String, _ <br /> Optional Compare As VbCompareMethod = vbTextCompare _<br /> ) As Double<br /><span style="color: green;"><br />' Returns an estimate of how closely word 1 matches word 2: this is best displayed as a percentage<br />' This is calculated as the fraction of the longer string that is made up of recognisable fragments of the shorter string<br />' There is no support for wildcards and regular expressions. Case-sensitivity is determined by the 'compare' parameter<br /><br />' THIS CODE IS IN THE PUBLIC DOMAIN</span><br /><br />Application.Volatile False<br /><br />Dim maxLen As Integer<br />Dim minLen As Integer<br /><br /> If str1 = str2 Then<br /> FuzzyMatchScore = 1#<br /> Exit Function<br /> End If<br /><br /> If Len(str1) > Len(str2) Then<br /> maxLen = Len(str1)<br /> minLen = Len(str2)<br /> Else<br /> maxLen = Len(str2)<br /> minLen = Len(str1)<br /> End If<br /><br /> If Len(str1) = 0 Or Len(str2) = 0 Then<br /> FuzzyMatchScore = 0#<br /> Else<br /><br /> FuzzyMatchScore = 0#<br /> FuzzyMatchScore = SumOfCommonStrings(str1, str2, Compare) / maxLen<br /><br /> End If<br /> <br />End Function<br /><br />Public Function SumOfCommonStrings( _<br /> ByVal s1 As String, _<br /> ByVal s2 As String, _<br /> Optional Compare As VBA.VbCompareMethod = vbTextCompare, _<br /> Optional iScore As Integer = 0 _<br /> ) As Integer<br /><br />Application.Volatile False<br /><span style="color: green;"><br />' N.Heffernan 06 June 2006 (somewhere over Newfoundland)<br />' THIS CODE IS IN THE PUBLIC DOMAIN<br /><br /><br />' Function to measure how much of String 1 is made up of substrings found in String 2<br /><br />' This function uses a modified Longest Common String algorithm.<br />' Simple LCS algorithms are unduly sensitive to single-letter<br />' deletions/changes near the midpoint of the test words, eg:<br />' Wednesday is obviously closer to WedXesday on an edit-distance<br />' basis than it is to WednesXXX. So it would be better to score<br />' the 'Wed' as well as the 'esday' and add up the total matched<br /><br />' Watch out for strings of differing lengths:<br />'<br />' SumOfCommonStrings("Wednesday", "WednesXXXday")<br />'<br />' This scores the same as:<br />'<br />' SumOfCommonStrings("Wednesday", "Wednesday")<br />'<br />' So make sure the calling function uses the length of the longest<br />' string when calculating the degree of similarity from this score.<br /><br /><br />' This is coded for clarity, not for performance.</span><br /><br />Dim arr() As Integer ' Scoring matrix<br />Dim n As Integer ' length of s1<br />Dim m As Integer ' length of s2<br />Dim i As Integer ' start position in s1<br />Dim j As Integer ' start position in s2<br />Dim subs1 As String ' a substring of s1<br />Dim len1 As Integer ' length of subs1<br /><br />Dim sBefore1 ' documented in the code<br />Dim sBefore2<br />Dim sAfter1<br />Dim sAfter2<br /><br />Dim s3 As String<br /><br /><br />SumOfCommonStrings = iScore<br /><br />n = Len(s1)<br />m = Len(s2)<br /><br />If s1 = s2 Then<br /> SumOfCommonStrings = n<br /> Exit Function<br />End If<br /><br />If n = 0 Or m = 0 Then<br /> Exit Function<br />End If<br /><br /><span style="color: green;">'s1 should always be the shorter of the two strings:</span><br />If n > m Then<br /> s3 = s2<br /> s2 = s1<br /> s1 = s3<br /> n = Len(s1)<br /> m = Len(s2)<br />End If<br /><br />n = Len(s1)<br />m = Len(s2)<br /><br /><span style="color: green;">' Special case: s1 is n exact substring of s2</span><br />If InStr(1, s2, s1, Compare) Then<br /> SumOfCommonStrings = n<br /> Exit Function<br />End If<br /><br />For len1 = n To 1 Step -1<br /><br /> For i = 1 To n - len1 + 1<br /><br /> subs1 = Mid(s1, i, len1)<br /> j = 0<br /> j = InStr(1, s2, subs1, Compare)<br /> <br /> If j > 0 Then<br /> <br /> <span style="color: green;">' We've found a matching substring...</span><br /> iScore = iScore + len1 <br /><br /> <span style="color: green;">' Now clip out this substring from s1 and s2...</span><br /> <span style="color: green;">' And search the fragments before and after this excision:</span><br /><br /> <br /> If i > 1 And j > 1 Then<br /> sBefore1 = left(s1, i - 1)<br /> sBefore2 = left(s2, j - 1)<br /> iScore = SumOfCommonStrings(sBefore1, _<br /> sBefore2, _<br /> Compare, _<br /> iScore)<br /> End If<br /> <br /> <br /> If i + len1 < n And j + len1 < m Then<br /> sAfter1 = right(s1, n + 1 - i - len1)<br /> sAfter2 = right(s2, m + 1 - j - len1)<br /> iScore = SumOfCommonStrings(sAfter1, _<br /> sAfter2, _<br /> Compare, _<br /> iScore)<br /> End If<br /> <br /> <br /> SumOfCommonStrings = iScore<br /> Exit Function<br /><br /> End If<br /><br /> Next<br /><br /><br />Next<br /><br /><br />End Function<br /><br /><br />Private Function Minimum(ByVal a As Integer, _<br /> ByVal b As Integer, _<br /> ByVal c As Integer) As Integer<br />Dim min As Integer<br /><br /> min = a<br /><br /> If b < min Then<br /> min = b<br /> End If<br /><br /> If c < min Then<br /> min = c<br /> End If<br /><br /> Minimum = min<br /><br />End Function<br /><br /><br /><br />Public Function NormaliseAddress(ByVal strAddress As String) As String<br />Application.Volatile False <span style="color: green;"><br />' This function is intended to remove or standardise common phrases<br />' and abbreviations used in British postal addresses, allowing the use<br />' of string-comparison algorithms in lists of names and addresses.<br /><br />' Developers in other countries should review the word list used here,<br />' as conventions probably differ in your local language or dialect.</span><br /><br />strAddress = " " & UCase(strAddress) & " "<br /><br />strAddress = Substitute(strAddress, ",", " ")<br />strAddress = Substitute(strAddress, ".", " ")<br />strAddress = Substitute(strAddress, "-", " ")<br />strAddress = Substitute(strAddress, vbCrLf, " ")<br />strAddress = Substitute(strAddress, " BLVD ", " BOULEVARD ")<br />strAddress = Substitute(strAddress, " BVD ", " BOULEVARD ")<br />strAddress = Substitute(strAddress, " AV ", " AVENUE ")<br />strAddress = Substitute(strAddress, " AVE ", " AVENUE ")<br />strAddress = Substitute(strAddress, " RD ", " ROAD ")<br />strAddress = Substitute(strAddress, " WY ", " WAY ")<br />strAddress = Substitute(strAddress, " EST ", " ESTATE ")<br />strAddress = Substitute(strAddress, " PL ", " PLACE ")<br />strAddress = Substitute(strAddress, " PK ", " PARK ")<br />strAddress = Substitute(strAddress, " HSE ", " HOUSE ")<br />strAddress = Substitute(strAddress, " H0 ", " HOUSE ")<br />strAddress = Substitute(strAddress, " GDNS ", " GARDENS ")<br /><br />strAddress = Substitute(strAddress, "&", "AND")<br />strAddress = Substitute(strAddress, " LIMITED ", " LTD ")<br />strAddress = Substitute(strAddress, " COMPANY ", " CO ")<br />strAddress = Substitute(strAddress, " CORPORATION ", " CORP ")<br />strAddress = Substitute(strAddress, " T/A ", " TA ")<br />strAddress = Substitute(strAddress, " TRADING AS ", " TA ")<br /><span style="color: green;"><br />' Common personal titles: these are often applied inconsistently or<br />' omitted, and must therefore be removed. Specific applications may<br />' require additional titles and their abbreviations - military rank,<br />' academic titles and degrees, courtesy titles of the aristocracy,<br />' knighthoods and honours (particularly for lists of civil servants)</span><br /><br />strAddress = Substitute(strAddress, " ESQ ", " ")<br />strAddress = Substitute(strAddress, " MR ", " ")<br />strAddress = Substitute(strAddress, " MRS ", " ")<br />strAddress = Substitute(strAddress, " MISS ", " ")<br />strAddress = Substitute(strAddress, " MS ", " ")<br />strAddress = Substitute(strAddress, " MESSRS ", " ")<br />strAddress = Substitute(strAddress, " SIR ", " ")<br />strAddress = Substitute(strAddress, " OF ", " ")<br />strAddress = Substitute(strAddress, " DR ", " ")<br />strAddress = Substitute(strAddress, " OR ", " ")<br />strAddress = Substitute(strAddress, " IN ", " ")<br />strAddress = Substitute(strAddress, " THE ", " ")<br />strAddress = Substitute(strAddress, " REVEREND ", " REV ")<br />strAddress = Substitute(strAddress, " REVERENT ", " REV ")<br />strAddress = Substitute(strAddress, " HONOURABLE ", " HON ")<br />strAddress = Substitute(strAddress, " BROS ", " BROTHERS ")<br />strAddress = Substitute(strAddress, " ASSOC ", " ASSOCIATION ")<br />strAddress = Substitute(strAddress, " ASSN ", " ASSOCIATION ")<br /><span style="color: green;"><br />' Standardising 'St.', 'St', and 'Street'. Note that there are over 40 English<br />' towns and place names that contain or consist entirely of the word 'Street'.<br />' In addition, 'St' is a common abbreviation for 'Saint' in addresses.<br /><br />' I have never seen a list of addresses where 'Street' and 'St' were used in a<br />' consistent way, and the only workable solution is to delete them all:</span><br /><br />strAddress = Substitute(strAddress, " STREET ", " ")<br />strAddress = Substitute(strAddress, " ST ", " ")<br />strAddress = Substitute(strAddress, " STR ", " ")<br /><br />Do While InStr(strAddress, " ") > 0<br /> strAddress = Substitute(strAddress, " ", " ")<br />Loop<br /><br />strAddress = Trim(strAddress)<br /><br />NormaliseAddress = strAddress<br /><br />End Function<br /><br /><br />Public Function StripChars(myString As String, ParamArray Exceptions()) As String<br /><span style="color: green;"><br />' Strip out all non-alphanumeric characters from a string in a single pass<br />' Exceptions parameters allow you to retain specific characters (eg: spaces)<br /><br />' THIS CODE IS IN THE PUBLIC DOMAIN</span><br /><br />Application.Volatile False<br /><br />Dim i As Integer<br />Dim iLen As Integer<br />Dim chrA As String * 1<br />Dim intA As Integer<br />Dim j As Integer<br />Dim iStart As Integer<br />Dim iEnd As Integer<br /><br />If Not IsEmpty(Exceptions()) Then<br /> iStart = LBound(Exceptions)<br /> iEnd = UBound(Exceptions)<br />End If<br /><br />iLen = Len(myString)<br /><br />For i = 1 To iLen<br /> chrA = Mid(myString, i, 1)<br /> intA = Asc(chrA)<br /> Select Case intA<br /> Case 48 To 57, 65 To 90, 97 To 122<br /> StripChars = StripChars & chrA<br /> Case Else<br /> If Not IsEmpty(Exceptions()) Then<br /> For j = iStart To iEnd<br /> If chrA = Exceptions(j) Then<br /> StripChars = StripChars & chrA<br /> Exit For ' j<br /> End If<br /> Next j<br /> End If<br /> End Select<br />Next i<br /><br /><br /><br />End Function<br /><br /><br />Private Function Substitute(ByVal Text As String, _<br /> ByVal Old_Text As String, _<br /> ByVal New_Text As String, _<br /> Optional Instance As Long = 0, _<br /> Optional Compare As VbCompareMethod = vbTextCompare _<br /> ) As String<br /><br /><span style="color: green;"><br />' Replace all instances (or the nth instance ) of 'Old' text with 'New'<br />' Unlike VB.Mid$ this method is not sensitive to length and can replace ALL instances<br />' This is not exposed as a Public function because there is an Excel Worksheet function<br />' called Substitute(). However, Workheet Functions have length constraints.<br /><br />' THIS CODE IS IN THE PUBLIC DOMAIN</span><br /><br />Dim iStart As Long<br />Dim iEnd As Long<br />Dim iLen As Long<br />Dim iInstance As Long<br />Dim strOut As String<br /><br />iLen = Len(Old_Text)<br /><br />If iLen = 0 Then<br /> Substitute = Text<br /> Exit Function<br />End If<br /><br />iEnd = 0<br />iStart = 1<br /><br />iEnd = InStr(iStart, Text, Old_Text, Compare)<br /><br />If iEnd = 0 Then<br /> Substitute = Text<br /> Exit Function<br />End If<br /><br /><br />strOut = ""<br /><br />Do Until iEnd = 0<br /><br /> strOut = strOut & Mid$(Text, iStart, iEnd - iStart)<br /> iInstance = iInstance + 1<br /><br /> If Instance = 0 Or Instance = iInstance Then<br /> strOut = strOut & New_Text<br /> Else<br /> strOut = strOut & Mid$(Text, iEnd, Len(Old_Text))<br /> End If<br /><br /> iStart = iEnd + iLen<br /> iEnd = InStr(iStart, Text, Old_Text, Compare)<br /><br />Loop<br /><br />iLen = Len(Text)<br />strOut = strOut & Mid$(Text, iStart, iLen - iEnd)<br /><br />Substitute = strOut<br /><br />End Function<br /></span><br />
<br />
<div align="justify">
<br />This is something I coded up on an obscure personal blog a couple of years ago: I get one or two enquiries about it every year (mostly appreciative) so I've tidied it up, tested it more thoroughly, and released it into the wild on Excellerando.</div>
Nigel Heffernanhttp://www.blogger.com/profile/08954578765691578714noreply@blogger.com4tag:blogger.com,1999:blog-1800518423097919889.post-70814680017493437112010-02-27T11:07:00.003+00:002010-03-01T21:13:49.586+00:00String-Comparison in VBA: a modified Longest-Common-String approach<B>Summary:</B><p align="justify">I discuss the use of a sum-of-longest-common-strings algorithm to measure the degree of difference between strings. This is efficient in VBA, and can be used as a the basis as a closest-match alternative to VLookup and Match.<br /></P><br /><B>The Details...</B><p align="justify">A couple of years ago, I looked at writing a fuzzy-matching version of VLookup, to return the closest match to a search string rather than the #NA() that comes back from the standard Excel function. I posted it in an obscure personal blog, and forgot about it. But I'll be posting it here, shortly, and <i>this</i> post is the introduction to it, with an explanation of the principles and the core VBA function that drives the whole thing.<br /></P><p align="justify">Originally,I looked at using a Levenshtein 'Edit Distance' algorithm to compare and measure the degree of difference between strings. (Thanks are due to the inestimable Mr. Crowley for pointing me towards some basic C++ and theory-of-algorithms links). But field-testing showed that a simpler and faster approach was required - I needed something that gives consistent results on longer strings, like addresses and sentences, without the need for a separate scoring process that examines the word order.<br /></P><p align="justify">The simplest approach of all to comparing and scoring for similarity is searching for the longest common string. This has the obvious advantages of speed and simplicity, but it alse has a weak point: simple LCS algorithms are unduly sensitive to single-letter substitutions and deletions near the midpoint of the test word. For example, 'Wed<b>n</b>esday' is obviously closer to 'Wed<b>X</b>esday' on an edit-distance basis than it is to 'WednesXXX', but the latter has the longest common string despite having more substitutions; this suggests that it would be better to score the 'Wed' as well as the 'eday', adding up <i>all</i> the matching substrings, instead of just measuring the longest one. <br /></P><p align="justify">It turns out that the recursive algorithm I'm using to do this has an embedded sequence-sensitivity; in theory, this is a complication and a pretty heavy hint that there's some error in my logic that I ought to investigate and remove. In practice, a degree of sequence-sensitivity works well when we compare two sentences or phrases: this 'error' is a pretty good proxy for compiling a secondary score based on similarities in their word order.<br /></P><p align="justify">Which goes to show that serendipidity comes from simplicity and, if you strip out the comments, this function is a commendably compact piece of code:<br /></p><br /><font face="FixedSys, System, Terminal, Courier New"><br />Public Function SumOfCommonStrings( _<br /> ByVal s1 As String, _<br /> ByVal s2 As String, _<br /> Optional Compare As VBA.VbCompareMethod = vbTextCompare, _<br /> Optional iScore As Integer = 0 _<br /> ) As Integer<br /><br />Application.Volatile False<br /><font color="Green"> <br />' N.Heffernan 06 June 2006 (somewhere over Newfoundland)<br />' THIS CODE IS IN THE PUBLIC DOMAIN<br /><br /><br />' Function to measure how much of String 1 is made up of substrings found in String 2<br /><br />' This function uses a modified Longest Common String algorithm.<br />' Simple LCS algorithms are unduly sensitive to single-letter<br />' deletions/changes near the midpoint of the test words, eg:<br />' Wednesday is obviously closer to WedXesday on an edit-distance<br />' basis than it is to WednesXXX. So would it be better to score<br />' the 'Wed' as well as the 'eday' ?<br /><br />' Watch out for strings of differing lengths:<br />'<br />' SumOfCommonStrings("Wednesday", "WednesXXXday")<br />'<br />' This scores the same as:<br />'<br />' SumOfCommonStrings("Wednesday", "Wednesday")<br />'<br />' So make sure the calling function uses the length of the longest<br />' string when calculating the degree of similarity from this score.<br /><br /><br />' This is coded for clarity, not for performance. </FONT><br /><br />Dim arr() As Integer <font color="Green"> ' Scoring matrix </FONT><br />Dim n As Integer <font color="Green"> ' length of s1 </FONT><br />Dim m As Integer <font color="Green"> ' length of s2 </FONT><br />Dim i As Integer <font color="Green"> ' start position in s1 </FONT><br />Dim j As Integer <font color="Green"> ' start position in s2 </FONT><br />Dim subs1 As String <font color="Green"> ' a substring of s1 </FONT><br />Dim len1 As Integer <font color="Green"> ' length of subs1 </FONT><br /><br />Dim sBefore1 <font color="Green"> ' documented in the code </FONT><br />Dim sBefore2<br />Dim sAfter1<br />Dim sAfter2<br /><br />Dim s3 As String<br /><br /><br />SumOfCommonStrings = iScore<br /><br />n = Len(s1)<br />m = Len(s2)<br /><br />If s1 = s2 Then<br /> SumOfCommonStrings = n<br /> Exit Function<br />End If<br /><br />If n = 0 Or m = 0 Then<br /> Exit Function<br />End If<br /><font color="Green"><br />'s1 should always be the shorter of the two strings: </FONT><br />If n > m Then<br /> s3 = s2<br /> s2 = s1<br /> s1 = s3<br /> n = Len(s1)<br /> m = Len(s2)<br />End If<br /><br />n = Len(s1)<br />m = Len(s2)<br /><br /><font color="Green">' Special case: s1 is n exact substring of s2 </FONT><br />If InStr(1, s2, s1, Compare) Then<br /> SumOfCommonStrings = n<br /> Exit Function<br />End If<br /><br />For len1 = n To 1 Step -1<br /><br /> For i = 1 To n - len1 + 1<br /><br /> subs1 = Mid(s1, i, len1)<br /> j = 0<br /> j = InStr(1, s2, subs1, Compare)<br /> <br /> If j > 0 Then<br /> <br /> <font color="Green"> ' We've found a matching substring...</FONT><br /> iScore = iScore + len1<br /> <font color="Green"> <br /> ' Reinstate this Debug.Print statement to monitor the function:<br /> ' Debug.Print s1 & " substring (len=" & len1 & ") " & subs1 & " in " & s2 & " Scores " & len1<br /> <br /> ' Now clip out this substring from s1 and s2...<br /> <br /> ' However, we can't just concatenate the fragments before and<br /> ' after this deletion and restart: substrings that span this<br /> ' artificial join might give spurious matches. So we run the<br /> ' function on the separate 'before' and 'after' pieces. Note<br /> ' that running before1 vs before2 and after1 vs after2, without<br /> ' running before1 vs after2 and before2 vs after1, introduces<br /> ' a sequence bias. This may be undesirable, as the effect will<br /> ' be to discard match scores for transposed words in a sentence</FONT><br /> <br /> If i > 1 And j > 1 Then<br /> sBefore1 = left(s1, i - 1)<br /> sBefore2 = left(s2, j - 1)<br /> iScore = SumOfCommonStrings(sBefore1, _<br /> sBefore2, _<br /> Compare, _<br /> iScore)<br /> End If<br /> <br /> <br /> If i + len1 < n And j + len1 < m Then<br /> sAfter1 = right(s1, n + 1 - i - len1)<br /> sAfter2 = right(s2, m + 1 - j - len1)<br /> iScore = SumOfCommonStrings(sAfter1, _<br /> sAfter2, _<br /> Compare, _<br /> iScore)<br /> End If<br /> <br /> <br /> SumOfCommonStrings = iScore<br /> <font color="Green">' No further recursion: don't double-count substrings of a matched substring!</FONT><br /> Exit Function<br /> <font color="Green"><br /> 'Reinstate this 'Else' block to monitor the function:<br /> 'Else<br /> ' No action required.<br /> ' Debug.Print s1 & " substring (len=" & len1 & ") " & subs1 & " in " & s2 </FONT><br /> <br /> End If<br /><br /> Next<br /><br /><br />Next<br /><br /><br />End Function<br /></font><br /><br /> <br /> <br /><br /><br /><p align="justify"><br />There is room for improvement, and I suspect that the embedded sequence sensitivity is a drawback in some applications. Consider these two addresses:<br /><br /> The House of Cards,<br /> 11 High Street,<br /><br />and<br /><br /> House of Cards, The<br /> 11 High Street<br /><br />They are clearly the same address, and this isn't even a typing error: moving 'The' to the end of the line (or titles like 'Mr' and 'Mrs') is accepted secretarial practice in lists that are sorted alphabetically. But my algorithm treats the transposed word 'The' as an insertion, applying a penalty without making any attempt to identify it as a transposition. In fact, it double-counts the transposition as two points of difference - deletion plus insertion - just like the unmodified Levenshtein edit-distance algorithm. So feel free to rewrite my code where it splits the test words into 'before' and 'after' fragments and resumes the search for matching substrings - but be warned, this is not as simple as you might think, and I don't see any obvious analogy with Damerau's extension of the Levenshtein algorithm. In practice the brutal excision of articles and titles from addresses is the most reliable approach.</P><br /><b>A parting shot:</B><br /><p align="justify">I have a vague suspicion that this sum-of-longest-common-strings algorithm is functionally equivalent to the Levenshtein edit distance, but I lack the logical tools to attempt a formal proof. Would anyone care to offer some pointers? I think its time I moved beyond simple hacks and started putting this stuff on a firmer foundation.<br /></p>Nigel Heffernanhttp://www.blogger.com/profile/08954578765691578714noreply@blogger.com4tag:blogger.com,1999:blog-1800518423097919889.post-60883964406888717482010-02-26T15:37:00.009+00:002010-02-26T16:58:11.728+00:00Unprotecting a project using VBA<p></p><p>Ever tried to open another workbook call a macro in it from your VBA code?<br /></p><p>Easy, if the sub or function is declared 'public' at workbook level and is visible as a method of the workbook object. If it isn't (and, sometimes, even if it is) and the VB Project is locked, you'll need to go into the VBE editor and unlock it yourself.<br /></p><p>In short: manual intervention is required.<br /></p><p>For obvious reasons, there's no Project.Unprotect(sPassword) function: obvious, but not good,and definitely not convenient when you've been asked to re-run all the reports in a month of separate daily workbooks.<br /></p><p>We'll gloss over that your office should probably be handling the data and the daily reporting process in a more efficient way: sometimes you get this kind of job and the rest s up to you.<br /></p><p>We'll assume that you know the password and have the right to open and run these files... now what?<br /></p><p>There's code out there to unlock a project using a truly horrible combination of SendKeys() strings. THIS code is marginally better, but not miraculously so: it works on identifying the windows and the handles of the controls, and sending Windows messages using the API functions.<br /></p><p>Most of the time the messages work... More often, anyway, than Sendkeys does. And, as we're in a slightly better environment than a keystroke-passer, we can read the results and retry the messages when they fail.<br /></p><p>Here's the function:<br /><br /><b>fUnlockProject(wbk As Excel.Workbook, strPwd As String) As Boolean</b><br /><br />I'm assuming that you know how to open a workbook in VBA: if you can't, then this code sample probably isn't for you. Not only is at an advanced topic - API calls and window messages - but we're doing something that VBA really isn't designed to do.<br /></p><p>On top of that, Blogger's HTML editor (whatever RSS feed you're viewing the blog post in!) will have munged at least one of the line breaks and, while I've succeeded in getting thhe code below to copy-and-paste into a new VBA module, I suspect that some of you will get at least one syntax error when you try.<br /></p><p>Finally: read the comments below the function header. There's stuff in there that you need to know about the return value, and a hint about passing the workbook object.<br /></p><br /><br /><font face=Courier New><SPAN style="color:#00007F">Option</SPAN> <SPAN style="color:#00007F">Explicit</SPAN><br><SPAN style="color:#00007F">Option</SPAN> <SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Module</SPAN><br><br><br><SPAN style="color:#007F00">' Requires a reference to the library :</SPAN><br><SPAN style="color:#007F00">'   Microsoft Visual Basic for Applications Extensibility (v5.3)</SPAN><br><br><br>    <SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Declare</SPAN> <SPAN style="color:#00007F">Function</SPAN> SendMessage <SPAN style="color:#00007F">Lib</SPAN> "user32.dll" Alias "SendMessageA" ( _<br>          <SPAN style="color:#00007F">ByVal</SPAN> hWnd <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, <SPAN style="color:#00007F">ByVal</SPAN> wMsg <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, <SPAN style="color:#00007F">ByVal</SPAN> wParam <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, <SPAN style="color:#00007F">ByVal</SPAN> lParam <SPAN style="color:#00007F">As</SPAN> Long _<br>       ) <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>       <br>    <SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Declare</SPAN> <SPAN style="color:#00007F">Function</SPAN> SendMessageStr <SPAN style="color:#00007F">Lib</SPAN> "user32.dll" Alias "SendMessageA" ( _<br>          <SPAN style="color:#00007F">ByVal</SPAN> hWnd <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, <SPAN style="color:#00007F">ByVal</SPAN> wMsg <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, <SPAN style="color:#00007F">ByVal</SPAN> wParam <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, <SPAN style="color:#00007F">ByVal</SPAN> lParam <SPAN style="color:#00007F">As</SPAN> String _<br>       ) <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>       <br>    <SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Declare</SPAN> <SPAN style="color:#00007F">Function</SPAN> PostMessage <SPAN style="color:#00007F">Lib</SPAN> "user32.dll" Alias "PostMessageA" ( _<br>            <SPAN style="color:#00007F">ByVal</SPAN> hWnd <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, <SPAN style="color:#00007F">ByVal</SPAN> wMsg <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, <SPAN style="color:#00007F">ByVal</SPAN> wParam <SPAN style="color:#00007F">As</SPAN> Long, <SPAN style="color:#00007F">ByVal</SPAN> lParam <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN> _<br>        ) <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br><br><br><br>    <SPAN style="color:#007F00">' SetText params for SendMessage and PostMessage:</SPAN><br><br>    <SPAN style="color:#007F00">' ms-help://MS.VSCC.v80/MS.MSDN.v80/MS.WIN32COM.v10.en/winui/winui/windowsuserinterface/windowing/windows/windowreference/windowmessages/wm_settext.htm</SPAN><br>    <SPAN style="color:#007F00">'   wParam:         This parameter is not used.</SPAN><br>    <SPAN style="color:#007F00">'   lParam:         Pointer to a null-terminated string that is the window text.</SPAN><br>    <SPAN style="color:#007F00">'   Return Value:   The return value is TRUE if the text is set.</SPAN><br>    <br>    <br>    <SPAN style="color:#007F00">' API Window Message Constants are documented here:</SPAN><br>    <br>    <SPAN style="color:#007F00">' ms-help://MS.VSCC.v80/MS.MSDN.v80/MS.WIN32COM.v10.en/winui/winui/windowsuserinterface/windowing/windows/windowreference/windowmessages/wm_close.htm</SPAN><br>    <SPAN style="color:#007F00">' ms-help://MS.VSCC.v80/MS.MSDN.v80/MS.WIN32COM.v10.en/shellcc/platform/commctls/buttons/buttonreference/buttonmessages/bm_click.htm</SPAN><br><br>    <SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Declare</SPAN> <SPAN style="color:#00007F">Function</SPAN> GetWindowTextApi <SPAN style="color:#00007F">Lib</SPAN> "user32.dll" Alias "GetWindowTextA" (<SPAN style="color:#00007F">ByVal</SPAN> hWnd <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, <SPAN style="color:#00007F">ByVal</SPAN> lpString <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN>, <SPAN style="color:#00007F">ByVal</SPAN> cch <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>) <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>    <SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Declare</SPAN> <SPAN style="color:#00007F">Function</SPAN> GetClassNameApi <SPAN style="color:#00007F">Lib</SPAN> "user32.dll" Alias "GetClassNameA" (<SPAN style="color:#00007F">ByVal</SPAN> hWnd <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, <SPAN style="color:#00007F">ByVal</SPAN> lpClassName <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN>, <SPAN style="color:#00007F">ByVal</SPAN> nMaxCount <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>) <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>    <br>    <SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Const</SPAN> WM_SETTEXT <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN> = &HC<br>    <SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Const</SPAN> WM_CLOSE <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN> = &H10<br>    <SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Const</SPAN> BM_CLICK = &HF5<br>    <br>    <SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Const</SPAN> SW_HIDE = 0<br>    <SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Const</SPAN> BM_SETCHECK <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN> = &HF1&<br>    <SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Const</SPAN> BST_UNCHECKED = &H0&<br>    <SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Const</SPAN> BST_CHECKED <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN> = &H1&<br>    <SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Const</SPAN> BST_INDETERMINATE = &H2&<br>    <SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Const</SPAN> EM_REPLACESEL <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN> = &HC2&<br>    <SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Const</SPAN> HWND_TOPMOST <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN> = -1<br>    <SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Const</SPAN> SWP_NOACTIVATE <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN> = &H10&<br>    <SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Const</SPAN> SWP_NOMOVE <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN> = &H2&<br>    <SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Const</SPAN> SWP_NOSIZE <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN> = &H1&<br>    <SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Const</SPAN> SWP_SHOWWINDOW <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN> = &H40&<br><br>    <SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Const</SPAN> TCM_SETCURFOCUS <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN> = &H1330&<br><br>    <SPAN style="color:#007F00">' Default Dialog control IDs</SPAN><br>    <SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Const</SPAN> IDOK <SPAN style="color:#00007F">As</SPAN> Long = 1<br>    <SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Const</SPAN> IDCANCEL <SPAN style="color:#00007F">As</SPAN> Long = 2<br><br>    <br><SPAN style="color:#007F00">'    Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As <SPAN style="color:#00007F">Long</SPAN>, <SPAN style="color:#00007F">ByVal</SPAN> nCmdShow As <SPAN style="color:#00007F">Long</SPAN>) As <SPAN style="color:#00007F">Long</SPAN></SPAN><br>        <br>    <SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Declare</SPAN> <SPAN style="color:#00007F">Function</SPAN> SetFocus <SPAN style="color:#00007F">Lib</SPAN> "user32" (<SPAN style="color:#00007F">ByVal</SPAN> hWnd <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>) <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br><br>    <SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Declare</SPAN> <SPAN style="color:#00007F">Function</SPAN> FindWindow <SPAN style="color:#00007F">Lib</SPAN> "user32.dll" Alias "FindWindowA" ( _<br>            <SPAN style="color:#00007F">ByVal</SPAN> lpClassName <SPAN style="color:#00007F">As</SPAN> String, <SPAN style="color:#00007F">ByVal</SPAN> lpWindowName <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN> _<br>        ) <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br> <br>    <SPAN style="color:#007F00">' ms-help:'MS.VSCC.v80/MS.MSDN.v80/MS.WIN32COM.v10.en/winui/winui/windowsuserinterface/windowing/dialogboxes/dialogboxreference/dialogboxfunctions/getdlgitem.htm</SPAN><br>    <SPAN style="color:#007F00">' Retrieves the handle to a control in the specified dialog box.</SPAN><br>    <SPAN style="color:#007F00">' hDlg      : [in] Handle to the dialog box that contains the control.</SPAN><br>    <SPAN style="color:#007F00">' nIDDlgItem: [in] Specifies the identifier of the control to be retrieved.</SPAN><br>    <SPAN style="color:#007F00">' returns   : The window handle of the specified control indicates success. NULL indicates failure due to an invalid dialog box handle or a nonexistent control.</SPAN><br>    <SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Declare</SPAN> <SPAN style="color:#00007F">Function</SPAN> GetDlgItem <SPAN style="color:#00007F">Lib</SPAN> "user32.dll" (<SPAN style="color:#00007F">ByVal</SPAN> hDlg <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, <SPAN style="color:#00007F">ByVal</SPAN> nIDDlgItem <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>) <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>    <br>    <SPAN style="color:#007F00">' ms-help://MS.VSCC.v80/MS.MSDN.v80/MS.WIN32COM.v10.en/winui/winui/windowsuserinterface/windowing/windows/windowreference/windowfunctions/setforegroundwindow.htm</SPAN><br>    <SPAN style="color:#007F00">' If the window was brought to the foreground, the return value is nonzero.</SPAN><br>    <SPAN style="color:#007F00">' If the window was not brought to the foreground, the return value is zero.</SPAN><br>    <SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Declare</SPAN> <SPAN style="color:#00007F">Function</SPAN> SetForegroundWindow <SPAN style="color:#00007F">Lib</SPAN> "user32.dll" (<SPAN style="color:#00007F">ByVal</SPAN> hWnd <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>) <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br><br>        <br>    <SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Declare</SPAN> <SPAN style="color:#00007F">Function</SPAN> GetTickCount <SPAN style="color:#00007F">Lib</SPAN> "kernel32.dll" () <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>    <SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Declare</SPAN> <SPAN style="color:#00007F">Sub</SPAN> Sleep <SPAN style="color:#00007F">Lib</SPAN> "kernel32.dll" (<SPAN style="color:#00007F">ByVal</SPAN> dwMilliseconds <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>)<br><br><br>    <SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Declare</SPAN> <SPAN style="color:#00007F">Function</SPAN> CharLower <SPAN style="color:#00007F">Lib</SPAN> "user32.dll" Alias "CharLowerA" (<SPAN style="color:#00007F">ByVal</SPAN> lpsz <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN>) <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN><br>    <SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Declare</SPAN> <SPAN style="color:#00007F">Function</SPAN> CharUpper <SPAN style="color:#00007F">Lib</SPAN> "user32.dll" Alias "CharUpperA" (ByVal lpsz <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN>) <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN><br>        <br><br><SPAN style="color:#007F00">' Password windows caption suffix</SPAN><br><SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Const</SPAN> DLG_PWD_CAP_SUFFIX <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN> = " Password"<br><br><SPAN style="color:#007F00">' Project properties dialog caption suffix</SPAN><br><SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Const</SPAN> DLG_PRJPROP_CAP_SUFFIX <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN> = " - Project properties"<br><br><SPAN style="color:#007F00">' Project properties dialog hWnd</SPAN><br><SPAN style="color:#00007F">Private</SPAN> hWndProjectProperties <SPAN style="color:#00007F">As</SPAN> Long<br><br><br><SPAN style="color:#007F00">' Caption of the dialog when a bad password is inserted</SPAN><br><SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Const</SPAN> DLG_BADPWD_CAP <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN> = "Project Locked"<br><br><SPAN style="color:#007F00">' Caption of the generic VBA error</SPAN><br><SPAN style="color:#00007F">Public</SPAN> <SPAN style="color:#00007F">Const</SPAN> DLG_VBERROR_CAP <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN> = "Microsoft Visual Basic"<br><br><SPAN style="color:#007F00">' Dialog class</SPAN><br><SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Const</SPAN> DIALOG_CLS <SPAN style="color:#00007F">As</SPAN> String = "#32770"<br><br><SPAN style="color:#007F00">' Password dialog textfield control ID</SPAN><br><SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Const</SPAN> PWD_DLG_EDIT_ID <SPAN style="color:#00007F">As</SPAN> Long = &H155E&<br><br><SPAN style="color:#007F00">' Wait time for the windows search</SPAN><br><SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Const</SPAN> WAIT_TIME <SPAN style="color:#00007F">As</SPAN> Long = 500<br><SPAN style="color:#007F00">'</SPAN></FONT><br /><font face=Courier New><SPAN style="color:#00007F">Public</SPAN> <SPAN style="color:#00007F">Function</SPAN> fUnlockProject(wbk <SPAN style="color:#00007F">As</SPAN> Excel.Workbook, strPwd <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN>) <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Boolean</SPAN><br><SPAN style="color:#00007F">On</SPAN> <SPAN style="color:#00007F">Error</SPAN> <SPAN style="color:#00007F">Resume</SPAN> <SPAN style="color:#00007F">Next</SPAN><br><br><SPAN style="color:#007F00">' Unlock a VB project using a known password.</SPAN><br><br><SPAN style="color:#007F00">' You are advised to pass a wbk parameter that's opened in another Excel Application session.</SPAN><br><SPAN style="color:#007F00">' This one will probably crash if you try it locally.</SPAN><br><br><SPAN style="color:#007F00">' Returns True if all the dialog boxes were closed (indicating that the app can be safely closed).</SPAN><br><SPAN style="color:#007F00">' To know if the document project was unlocked successfully, use the .VBProject.Protection property.</SPAN><br><br><SPAN style="color:#007F00">' This code works by manipulating the windows of the VBE password dialogue in VBA.</SPAN><br><SPAN style="color:#007F00">' It's a step above the widely-published 'SendKeys' code. But that's faint praise:</SPAN><br><SPAN style="color:#007F00">' it's messy, and you'll soon find out why I use all those 'GoTo ...iRetry' blocks.</SPAN><br><br>    <SPAN style="color:#00007F">Dim</SPAN> appExcel <SPAN style="color:#00007F">As</SPAN> Excel.Application<br>    <SPAN style="color:#00007F">Dim</SPAN> vbpProject <SPAN style="color:#00007F">As</SPAN> VBIDE.VBProject<br>    <SPAN style="color:#00007F">Dim</SPAN> vbEditor <SPAN style="color:#00007F">As</SPAN> VBIDE.VBE<br>   <br>    <SPAN style="color:#00007F">Dim</SPAN> i <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>    <SPAN style="color:#00007F">Dim</SPAN> lStart <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br><br>    <br>    <SPAN style="color:#00007F">Dim</SPAN> sPPDlgCaption <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN>     <SPAN style="color:#007F00">' Project Properties dialog caption</SPAN><br>    <SPAN style="color:#00007F">Dim</SPAN> hDlgProjectProps <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>    <SPAN style="color:#007F00">' Project Properties dialog handle</SPAN><br>    <br>    <SPAN style="color:#00007F">Dim</SPAN> sPwdDlgCaption <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN>    <SPAN style="color:#007F00">' password dialog caption</SPAN><br>    <SPAN style="color:#00007F">Dim</SPAN> hDlgPassword <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>        <SPAN style="color:#007F00">' password dialog handle</SPAN><br>    <br>    <SPAN style="color:#00007F">Dim</SPAN> hPwdField <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>           <SPAN style="color:#007F00">' password dialog textbox handle</SPAN><br>    <SPAN style="color:#00007F">Dim</SPAN> hDlgBadPassword <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>     <SPAN style="color:#007F00">' a 'Bad Password' dialog handle</SPAN><br>    <br>    <SPAN style="color:#00007F">Dim</SPAN> iRetry <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>    <br>    <br>    <SPAN style="color:#007F00">' Menu bar</SPAN><br>    <SPAN style="color:#007F00">'  \ Tools (msoControlPopup, ID:30007)</SPAN><br>    <SPAN style="color:#007F00">'     \ Properties of <project_name>... (msoControlButton, ID:2578)</SPAN><br>    <br>    <SPAN style="color:#00007F">Dim</SPAN> cbMenuBar <SPAN style="color:#00007F">As</SPAN> CommandBar<br>    <SPAN style="color:#00007F">Dim</SPAN> cbpTools <SPAN style="color:#00007F">As</SPAN> CommandBarPopup<br>    <SPAN style="color:#00007F">Dim</SPAN> cbbProperties <SPAN style="color:#00007F">As</SPAN> CommandBarButton<br>    <SPAN style="color:#00007F">Dim</SPAN> bDialogsCleared <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Boolean</SPAN><br>        <br>    bDialogsCleared = <SPAN style="color:#00007F">True</SPAN><br>    <br>    <SPAN style="color:#007F00">'Application.EnableCancelKey = xlDisabled</SPAN><br><br>    <br>    <SPAN style="color:#00007F">Set</SPAN> appExcel = wbk.Application<br>    <SPAN style="color:#00007F">Set</SPAN> vbEditor = appExcel.VBE<br>    <SPAN style="color:#00007F">Set</SPAN> vbpProject = wbk.VBProject<br>    <br>    <SPAN style="color:#007F00">' show Visual Basic Editor?</SPAN><br><SPAN style="color:#007F00">'    If appExcel.VBE.MainWindow.visible = True Then</SPAN><br><SPAN style="color:#007F00">'        appExcel.VBE.MainWindow.visible = False</SPAN><br><SPAN style="color:#007F00">'    End If</SPAN><br>    <br>    <SPAN style="color:#007F00">' set the VBE active project</SPAN><br>    <SPAN style="color:#00007F">Set</SPAN> vbEditor.ActiveVBProject = vbpProject<br>        <br>    <SPAN style="color:#007F00">' construct the password dialog caption</SPAN><br>    sPwdDlgCaption = vbpProject.Name & DLG_PWD_CAP_SUFFIX<br>    <br>    <SPAN style="color:#007F00">' construct the 'project properties' dialog caption</SPAN><br>    sPPDlgCaption = vbpProject.Name & DLG_PRJPROP_CAP_SUFFIX<br>    <br>     <br><br>    <SPAN style="color:#007F00">' Note that this could be structured as nested IF... THEN blocks, avoiding the use of 'GOTO'</SPAN><br>    <SPAN style="color:#007F00">' But 'drop-through or exit' is easier to follow when we use a 'go-back-and-retry' structure</SPAN><br><br><br><SPAN style="color:#007F00">' Try to acquire the menu bar</SPAN><br>iRetry = 0<br>RetryGetMenuBar:<br>iRetry = iRetry + 1<br><br>    <SPAN style="color:#00007F">If</SPAN> <SPAN style="color:#00007F">Not</SPAN> fGetMenuBar(vbEditor, cbMenuBar) <SPAN style="color:#00007F">Then</SPAN><br>    <br>        <SPAN style="color:#007F00">' Failed, retry 3 times</SPAN><br>        <SPAN style="color:#00007F">Call</SPAN> Sleep(32 * iRetry)<br>        <br>        <SPAN style="color:#00007F">If</SPAN> iRetry < 4 <SPAN style="color:#00007F">Then</SPAN><br>            <SPAN style="color:#00007F">GoTo</SPAN> RetryGetMenuBar<br>        <SPAN style="color:#00007F">Else</SPAN><br>            Debug.Print vbpProject.Name & vbTab & "fUnlockProject() - Menubar not found : " & Err.Description<br>            <SPAN style="color:#00007F">GoTo</SPAN> ExitFunction<br>        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>        <br>    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN>  <SPAN style="color:#007F00">' menu bar successfully acquired</SPAN><br>    <br>    <br>                <br><SPAN style="color:#007F00">' try to find the 'Tools' menu</SPAN><br>iRetry = 0<br>RetryGetToolsMenu:<br>iRetry = iRetry + 1<br>        <br>    <SPAN style="color:#00007F">Set</SPAN> cbpTools = cbMenuBar.FindControl(ID:="30007")<br>    <br>    <SPAN style="color:#00007F">If</SPAN> (cbpTools <SPAN style="color:#00007F">Is</SPAN> <SPAN style="color:#00007F">Nothing</SPAN>) <SPAN style="color:#00007F">Then</SPAN><br>    <br>        <SPAN style="color:#007F00">' Failed, retry 3 times</SPAN><br>        <SPAN style="color:#00007F">Call</SPAN> Sleep(32 * iRetry)<br>        <br>        <SPAN style="color:#00007F">If</SPAN> iRetry < 4 <SPAN style="color:#00007F">Then</SPAN><br>            <SPAN style="color:#00007F">GoTo</SPAN> RetryGetToolsMenu<br>        <SPAN style="color:#00007F">Else</SPAN><br>            Debug.Print vbpProject.Name & vbTab & "fUnlockProject() - Tools menu not found : " & Err.Description<br>            <SPAN style="color:#00007F">GoTo</SPAN> ExitFunction<br>        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>        <br>     <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>         <br>         <br>         <br><SPAN style="color:#007F00">' try to get the 'project properties' menu item</SPAN><br>iRetry = 0<br>RetryGetProjProps:<br>iRetry = iRetry + 1<br>            <br>            <br>    <SPAN style="color:#00007F">Call</SPAN> fGetPopupItem(cbpTools, "2578", cbbProperties)<br>    CloseNamedDialog DLG_VBERROR_CAP<br>    <br>    <SPAN style="color:#00007F">If</SPAN> (cbbProperties <SPAN style="color:#00007F">Is</SPAN> <SPAN style="color:#00007F">Nothing</SPAN>) <SPAN style="color:#00007F">Then</SPAN><br>    <br>        <SPAN style="color:#007F00">'Failed, Retry 3 times</SPAN><br>        <SPAN style="color:#00007F">Call</SPAN> Sleep(32 * iRetry)<br>        <br>        <SPAN style="color:#00007F">If</SPAN> iRetry < 4 <SPAN style="color:#00007F">Then</SPAN><br>            <SPAN style="color:#00007F">GoTo</SPAN> RetryGetProjProps<br>        <SPAN style="color:#00007F">Else</SPAN><br>            Debug.Print vbpProject.Name & vbTab & "fUnlockProject() : Properties menu item not found."<br>            <SPAN style="color:#00007F">GoTo</SPAN> ExitFunction<br>        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>        <br>    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>        <br><br>    <SPAN style="color:#007F00">' Execute the 'project properties' menu item action</SPAN><br>    <SPAN style="color:#00007F">Call</SPAN> cbbProperties.Execute<br><br>    <SPAN style="color:#007F00">' Test an unlikely outcome: the project properties window</SPAN><br>    <SPAN style="color:#007F00">' opened up straightaway, indicating there was no password:</SPAN><br>    hDlgProjectProps = 0<br>    hDlgProjectProps = FindWindow(DIALOG_CLS, sPPDlgCaption)<br>    <br>    <SPAN style="color:#00007F">If</SPAN> hDlgProjectProps <> 0 <SPAN style="color:#00007F">Then</SPAN><br>        <SPAN style="color:#00007F">GoTo</SPAN> ExitFunction<br>    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>    <br>    <br>       <br><SPAN style="color:#007F00">' Get the password dialog's window handle:</SPAN><br><br>        hDlgPassword = 0<br>        hDlgPassword = FindWindow(DIALOG_CLS, sPwdDlgCaption)<br><br>           <br><SPAN style="color:#007F00">' Test the  password dialog exists, retry if it does not:</SPAN><br>        <br>iRetry = 0<br>RetryGetPwdDialog:<br>iRetry = iRetry + 1<br><br>        <SPAN style="color:#00007F">If</SPAN> hDlgPassword = 0 And iRetry < 3 <SPAN style="color:#00007F">Then</SPAN><br>        <br>            <SPAN style="color:#007F00">' Close any 'bad password' or VB Error windows</SPAN><br>            CloseNamedDialog DLG_VBERROR_CAP<br>            CloseNamedDialog DLG_BADPWD_CAP<br>            <br>            <SPAN style="color:#007F00">' Try getting the hWnd of the password dialog again:</SPAN><br>            hDlgPassword = FindWindow(DIALOG_CLS, sPwdDlgCaption)<br>            <br>            <SPAN style="color:#00007F">If</SPAN> hDlgPassword = 0 <SPAN style="color:#00007F">Then</SPAN><br>                <SPAN style="color:#00007F">Call</SPAN> Sleep(32 * iRetry)<br>            <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>            <br>            <SPAN style="color:#00007F">If</SPAN> hDlgPassword = 0 <SPAN style="color:#00007F">Then</SPAN><br>                <SPAN style="color:#00007F">GoTo</SPAN> RetryGetPwdDialog<br>            <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>            <br>        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>        <br>        <SPAN style="color:#00007F">If</SPAN> hDlgPassword = 0 And iRetry < 4 <SPAN style="color:#00007F">Then</SPAN><br>        <br>            CloseNamedDialog DLG_VBERROR_CAP<br>            CloseNamedDialog DLG_BADPWD_CAP<br>            <br>            <SPAN style="color:#007F00">' Try reopening the dialog from the menu, then get the hwnd:</SPAN><br>            <SPAN style="color:#00007F">Call</SPAN> cbbProperties.Execute<br>            <br>            <SPAN style="color:#00007F">Call</SPAN> Sleep(32 * iRetry)<br>            hDlgPassword = (FindWindow(DIALOG_CLS, sPwdDlgCaption))<br>            <br>            <SPAN style="color:#00007F">If</SPAN> hDlgPassword = 0 <SPAN style="color:#00007F">Then</SPAN><br>                <SPAN style="color:#00007F">Call</SPAN> Sleep(32 * iRetry)<br>            <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>            <br>            <SPAN style="color:#00007F">If</SPAN> hDlgPassword = 0 <SPAN style="color:#00007F">Then</SPAN><br>                <SPAN style="color:#00007F">GoTo</SPAN> RetryGetPwdDialog<br>            <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>            <br>        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br><br>        <SPAN style="color:#00007F">If</SPAN> hDlgPassword = 0 <SPAN style="color:#00007F">Then</SPAN><br>            Debug.Print vbpProject.Name & vbTab & "fUnlockProject(): cannot open the password dialog."<br>            <SPAN style="color:#00007F">GoTo</SPAN> ExitFunction<br>        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>        </FONT><br /><font face=Courier New>        <br><SPAN style="color:#007F00">' Get the password textbox</SPAN><br><br>        hPwdField = 0<br>        hPwdField = GetDlgItem(hDlgPassword, PWD_DLG_EDIT_ID)<br>        <br>        <br><SPAN style="color:#007F00">' Test the password textbox exists, retry if it does not:</SPAN><br>           <br>iRetry = 0<br>RetryGetPwdTextbox:<br>iRetry = iRetry + 1<br>        <br>        <SPAN style="color:#00007F">If</SPAN> hPwdField = 0 And iRetry < 4 <SPAN style="color:#00007F">Then</SPAN><br>        <br>            CloseNamedDialog DLG_VBERROR_CAP<br>            CloseNamedDialog DLG_BADPWD_CAP<br>            <br>            hPwdField = GetDlgItem(hDlgPassword, PWD_DLG_EDIT_ID)<br>            <br>            <SPAN style="color:#00007F">If</SPAN> hPwdField = 0 <SPAN style="color:#00007F">Then</SPAN><br>                <SPAN style="color:#00007F">Call</SPAN> Sleep(32 * iRetry)<br>            <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>            <br>            <SPAN style="color:#00007F">If</SPAN> hPwdField = 0 <SPAN style="color:#00007F">Then</SPAN><br>                <SPAN style="color:#00007F">GoTo</SPAN> RetryGetPwdTextbox<br>            <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>         <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>            <br>        <SPAN style="color:#00007F">If</SPAN> hPwdField = 0 <SPAN style="color:#00007F">Then</SPAN><br>            Debug.Print vbpProject.Name & vbTab & "fUnlockProject(): cannot find the password textbox."<br>            bDialogsCleared = CloseWindow(hDlgPassword)<br>            <SPAN style="color:#00007F">GoTo</SPAN> ExitFunction<br>        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>        <br>                <br><SPAN style="color:#007F00">'Fill in the password text:</SPAN><br>iRetry = 0<br>RetrySetText:<br>iRetry = iRetry + 1<br><br>        <SPAN style="color:#00007F">If</SPAN> SendMessageStr(hPwdField, WM_SETTEXT, 0&, strPwd) = 0 <SPAN style="color:#00007F">Then</SPAN><br>        <br>            <SPAN style="color:#007F00">' zero return indicates a failed set-text operation</SPAN><br>            <SPAN style="color:#00007F">Call</SPAN> Sleep(32 * iRetry)<br>            <br>            <SPAN style="color:#00007F">Select</SPAN> <SPAN style="color:#00007F">Case</SPAN> iRetry<br>            <SPAN style="color:#00007F">Case</SPAN> <SPAN style="color:#00007F">Is</SPAN> < 4<br>                <SPAN style="color:#00007F">GoTo</SPAN> RetrySetText<br>            <SPAN style="color:#00007F">Case</SPAN> <SPAN style="color:#00007F">Is</SPAN> < 5<br>                CloseNamedDialog DLG_VBERROR_CAP<br>                CloseNamedDialog DLG_BADPWD_CAP<br>                hDlgPassword = (FindWindow(DIALOG_CLS, sPwdDlgCaption))<br>                hPwdField = GetDlgItem(hDlgPassword, PWD_DLG_EDIT_ID)<br>                <SPAN style="color:#00007F">GoTo</SPAN> RetrySetText<br>            <SPAN style="color:#00007F">Case</SPAN> <SPAN style="color:#00007F">Is</SPAN> < 6<br>                CloseNamedDialog DLG_VBERROR_CAP<br>                CloseNamedDialog DLG_BADPWD_CAP<br>                CloseWindow hDlgPassword<br>                <SPAN style="color:#00007F">GoTo</SPAN> RetryGetPwdDialog<br>            <SPAN style="color:#00007F">Case</SPAN> <SPAN style="color:#00007F">Else</SPAN><br>                Debug.Print vbpProject.Name & vbTab & "fUnlockProject() : Unable to enter password '" & strPwd & "' into the textbox."<br>                bDialogsCleared = CloseWindow(hDlgPassword)<br>                <SPAN style="color:#00007F">GoTo</SPAN> ExitFunction<br>            <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Select</SPAN><br>        <br>        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>        <br>        <br><SPAN style="color:#007F00">' Click the 'Ok' button</SPAN><br>iRetry = 0<br>RetryClickOK:<br>iRetry = iRetry + 1<br>       <br>       <br>        <SPAN style="color:#007F00">' PostMessage returns the results of the 'click': nonzero indicates success</SPAN><br>        <SPAN style="color:#00007F">If</SPAN> PostMessage(GetDlgItem(hDlgPassword, IDOK), BM_CLICK, 0&, 0&) = 0 <SPAN style="color:#00007F">Then</SPAN><br>                    <br>            <SPAN style="color:#00007F">Select</SPAN> <SPAN style="color:#00007F">Case</SPAN> iRetry<br>            <SPAN style="color:#00007F">Case</SPAN> <SPAN style="color:#00007F">Is</SPAN> < 4<br>                <SPAN style="color:#00007F">Call</SPAN> Sleep(32 * iRetry)<br>                <SPAN style="color:#00007F">GoTo</SPAN> RetryClickOK<br>            <SPAN style="color:#00007F">Case</SPAN> 4<br>                CloseNamedDialog DLG_BADPWD_CAP<br>                CloseNamedDialog DLG_VBERROR_CAP<br>                <SPAN style="color:#00007F">Call</SPAN> SetForegroundWindow(hDlgPassword)<br>                <SPAN style="color:#00007F">GoTo</SPAN> RetryClickOK<br>            <SPAN style="color:#00007F">Case</SPAN> <SPAN style="color:#00007F">Else</SPAN><br>                Debug.Print vbpProject.Name & vbTab & "fUnlockProject() : Unable to click 'OK' for this password."<br>                bDialogsCleared = CloseWindow(hDlgPassword)<br>                <SPAN style="color:#00007F">GoTo</SPAN> ExitFunction<br>            <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Select</SPAN><br>        <br>        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN> <SPAN style="color:#007F00">' fClickButton failed</SPAN><br>        <br>                <br>        <SPAN style="color:#007F00">' fClickButton returned true, telling us that control</SPAN><br>        <SPAN style="color:#007F00">' has returned to the OK button's parent dialog.</SPAN><br>        <br>        <SPAN style="color:#007F00">' However, that could also mean that the button wasn't clicked at all:</SPAN><br>       <br>        hDlgPassword = 0<br>        hDlgPassword = FindWindow(DIALOG_CLS, sPwdDlgCaption)<br>         <br>        <SPAN style="color:#00007F">If</SPAN> hDlgPassword <> 0 <SPAN style="color:#00007F">Then</SPAN><br>                            <br>            <SPAN style="color:#00007F">Select</SPAN> <SPAN style="color:#00007F">Case</SPAN> iRetry<br>            <SPAN style="color:#00007F">Case</SPAN> <SPAN style="color:#00007F">Is</SPAN> < 4<br>                <SPAN style="color:#00007F">Call</SPAN> Sleep(32 * iRetry)<br>                <SPAN style="color:#00007F">GoTo</SPAN> RetryClickOK<br>            <SPAN style="color:#00007F">Case</SPAN> 4<br>                CloseNamedDialog DLG_BADPWD_CAP<br>                CloseNamedDialog DLG_VBERROR_CAP<br>                <SPAN style="color:#00007F">Call</SPAN> SetForegroundWindow(hDlgPassword)<br>                <SPAN style="color:#00007F">GoTo</SPAN> RetryClickOK<br>            <SPAN style="color:#00007F">Case</SPAN> <SPAN style="color:#00007F">Else</SPAN><br>                Debug.Print vbpProject.Name & vbTab & "fUnlockProject() : Unable to click 'OK' for this password."<br>                bDialogsCleared = CloseWindow(hDlgPassword)<br>                <SPAN style="color:#00007F">GoTo</SPAN> ExitFunction<br>            <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Select</SPAN><br>        <br>        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>        <br>        bDialogsCleared = <SPAN style="color:#00007F">False</SPAN><br>        <br><br>            <br><br><SPAN style="color:#007F00">' Inspect the results of the click</SPAN><br><br><SPAN style="color:#007F00">' No retry block here: retrying Window-open operations, clicks and SetTexts is fine</SPAN><br><SPAN style="color:#007F00">' - or rather, a messy necessity - but the password itself either worked or failed.</SPAN><br><br> <SPAN style="color:#007F00">' Two possible outcomes:   1 Password success opened a 'project properties' dialog</SPAN><br> <SPAN style="color:#007F00">'                          2 Password failure opened a 'bad password' dialog</SPAN><br><br><br>        <br>        <br>        <SPAN style="color:#00007F">If</SPAN> CloseNamedDialog(DLG_BADPWD_CAP) = 0 <SPAN style="color:#00007F">Then</SPAN>  <SPAN style="color:#007F00">' no 'bad password' dialog to close</SPAN><br>        <br>            hDlgProjectProps = 0<br>            hDlgProjectProps = FindWindow(DIALOG_CLS, sPPDlgCaption)<br>            <br>            <SPAN style="color:#00007F">If</SPAN> hDlgProjectProps = 0 <SPAN style="color:#00007F">Then</SPAN><br>                <SPAN style="color:#00007F">Call</SPAN> Sleep(250)<br>            <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>            <br>            <SPAN style="color:#00007F">If</SPAN> hDlgProjectProps <> 0 <SPAN style="color:#00007F">Then</SPAN><br>            <br>                <SPAN style="color:#007F00">' Opened the 'Properties' screen, which means: PASSWORD SUCCESSFUL!</SPAN><br>                Debug.Print "PASSWORD: " & strPwd & vbTab & wbk.FullName<br>                <br>                <SPAN style="color:#007F00">'Close the project properties dialog: try the OK button first</SPAN><br>                bDialogsCleared = fClickButton(hDlgProjectProps, IDOK)<br>                <br>            <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN> <SPAN style="color:#007F00">'successful password</SPAN><br>        <br>        <SPAN style="color:#00007F">Else</SPAN><br>            <SPAN style="color:#007F00">' Bad password dialog detected & closed... Our password Failed</SPAN><br>            <br>        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>    <br><br>ExitFunction:<br><br>    CloseNamedDialog DLG_BADPWD_CAP<br>    CloseNamedDialog DLG_VBERROR_CAP<br>    hDlgProjectProps = FindWindow(DIALOG_CLS, sPPDlgCaption)<br>    bDialogsCleared = bDialogsCleared And CloseWindow(hDlgPassword) And CloseWindow(hDlgProjectProps)<br>   <br>    <br>    <SPAN style="color:#00007F">If</SPAN> (bDialogsCleared) <SPAN style="color:#00007F">Then</SPAN><br>        <SPAN style="color:#007F00">' all the dialog boxes were closed</SPAN><br>        fUnlockProject = <SPAN style="color:#00007F">True</SPAN><br>    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>    <br>    <SPAN style="color:#00007F">Set</SPAN> cbbProperties = <SPAN style="color:#00007F">Nothing</SPAN><br>    <SPAN style="color:#00007F">Set</SPAN> cbpTools = <SPAN style="color:#00007F">Nothing</SPAN><br>    <SPAN style="color:#00007F">Set</SPAN> cbMenuBar = <SPAN style="color:#00007F">Nothing</SPAN><br>    <br>    vbEditor.MainWindow.Close<br>    <br>    <SPAN style="color:#00007F">Set</SPAN> vbEditor = <SPAN style="color:#00007F">Nothing</SPAN><br>    <SPAN style="color:#00007F">Set</SPAN> appExcel = <SPAN style="color:#00007F">Nothing</SPAN><br>    <br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Function</SPAN></FONT><br /><font face=Courier New><br><SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Function</SPAN> fGetDialogHnd(sCaption, hDlg <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>) <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Boolean</SPAN><br><br><SPAN style="color:#007F00">' Get the handle of the dialog whose the caption is specified.</SPAN><br><SPAN style="color:#007F00">' Return True if the dialog was found.</SPAN><br><br>    hDlg = (FindWindow(DIALOG_CLS, sCaption))<br>    fGetDialogHnd = (hDlg <> 0)<br>    <br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Function</SPAN><br><br><br><br><SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Function</SPAN> fClickButton(hDlg <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, lButtonID <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>) <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Boolean</SPAN><br><br><SPAN style="color:#007F00">' Programmatically click on a button in a command bar or menu,  specified by ID</SPAN><br><SPAN style="color:#007F00">' Return False if the button owner was not activated or the 'click' failed</SPAN><br><br>    <SPAN style="color:#00007F">Dim</SPAN> hButton <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>    <br>    <SPAN style="color:#007F00">' get the button handle</SPAN><br>    hButton = GetDlgItem(hDlg, lButtonID)<br>    <br>    <SPAN style="color:#007F00">' active the dialog box (hDlg) and click on the button</SPAN><br>    <SPAN style="color:#00007F">If</SPAN> PostMessage(hButton, BM_CLICK, 0&, 0&) <> 0 <SPAN style="color:#00007F">Then</SPAN><br>        fClickButton = <SPAN style="color:#00007F">True</SPAN><br>    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>    <br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Function</SPAN><br><br><br><br><SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Function</SPAN> fGetMenuBar(oContainer <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Object</SPAN>, cb <SPAN style="color:#00007F">As</SPAN> CommandBar) <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Boolean</SPAN><br><br><SPAN style="color:#007F00">' Get the menu bar of the specified container:</SPAN><br><SPAN style="color:#007F00">' oContainer can be any object which has a CommandBars collection.</SPAN><br><SPAN style="color:#007F00">' Return True if the menu bar was found.</SPAN><br><br>    <SPAN style="color:#00007F">Dim</SPAN> i <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>    <br>    <SPAN style="color:#00007F">On</SPAN> <SPAN style="color:#00007F">Error</SPAN> <SPAN style="color:#00007F">Resume</SPAN> <SPAN style="color:#00007F">Next</SPAN><br>    <SPAN style="color:#00007F">For</SPAN> i = 1 <SPAN style="color:#00007F">To</SPAN> oContainer.CommandBars.Count<br>        <SPAN style="color:#00007F">Set</SPAN> cb = oContainer.CommandBars(i)<br>        <br>        <SPAN style="color:#00007F">If</SPAN> (cb.Type = msoBarTypeMenuBar) <SPAN style="color:#00007F">Then</SPAN><br>            fGetMenuBar = <SPAN style="color:#00007F">True</SPAN><br>            <SPAN style="color:#00007F">Exit</SPAN> <SPAN style="color:#00007F">For</SPAN><br>        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>    <SPAN style="color:#00007F">Next</SPAN> i<br>    <SPAN style="color:#00007F">On</SPAN> <SPAN style="color:#00007F">Error</SPAN> <SPAN style="color:#00007F">GoTo</SPAN> 0<br>    <br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Function</SPAN><br><br><br><br><SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Function</SPAN> fGetPopupItem(cbp <SPAN style="color:#00007F">As</SPAN> CommandBarPopup, sControlID <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN>, cbc <SPAN style="color:#00007F">As</SPAN> CommandBarControl) <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Boolean</SPAN><br><SPAN style="color:#007F00">' Get a control from a commandbar or menu, by specifying the control's ID</SPAN><br><br>    <SPAN style="color:#00007F">Dim</SPAN> i <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>    <br>    <SPAN style="color:#00007F">For</SPAN> i = 1 <SPAN style="color:#00007F">To</SPAN> cbp.Controls.Count<br>    <br>        <SPAN style="color:#00007F">Set</SPAN> cbc = cbp.Controls(i)<br>        <br>        <SPAN style="color:#00007F">If</SPAN> (cbc.ID = sControlID) <SPAN style="color:#00007F">Then</SPAN><br>            fGetPopupItem = <SPAN style="color:#00007F">True</SPAN><br>            <SPAN style="color:#00007F">Exit</SPAN> <SPAN style="color:#00007F">For</SPAN><br>        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>        <br>    <SPAN style="color:#00007F">Next</SPAN> i<br>    <br>    <br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Function</SPAN><br><br><br><SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Function</SPAN> TrimNulls(<SPAN style="color:#00007F">ByVal</SPAN> sString <SPAN style="color:#00007F">As</SPAN> String) <SPAN style="color:#00007F">As</SPAN> String<br><SPAN style="color:#007F00">' Trims trailing nulls</SPAN><br><br><SPAN style="color:#00007F">Dim</SPAN> iPos <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN><br><br>iPos = InStr(sString, Chr$(0))<br>    <br>    <SPAN style="color:#00007F">Select</SPAN> <SPAN style="color:#00007F">Case</SPAN> iPos<br>    <SPAN style="color:#00007F">Case</SPAN> 0<br>    <br>        TrimNulls = sString<br>        <br>    <SPAN style="color:#00007F">Case</SPAN> 1<br><br>        TrimNulls = ""<br>        <br>    <SPAN style="color:#00007F">Case</SPAN> <SPAN style="color:#00007F">Else</SPAN> <SPAN style="color:#007F00">' iPos > 1</SPAN><br>    <br>        TrimNulls = left$(sString, iPos - 1)<br>        <br>    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Select</SPAN><br>    <br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Function</SPAN><br><br><SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Function</SPAN> fUCase(<SPAN style="color:#00007F">ByVal</SPAN> sString <SPAN style="color:#00007F">As</SPAN> String) <SPAN style="color:#00007F">As</SPAN> String<br><br>    <SPAN style="color:#00007F">If</SPAN> (Len(s<SPAN style="color:#00007F">String</SPAN>) >= 2) <SPAN style="color:#00007F">Then</SPAN><br>        fUCase = CharUpper(left$(s<SPAN style="color:#00007F">String</SPAN>, 1)) & _<br>                 CharLower(right$(s<SPAN style="color:#00007F">String</SPAN>, Len(sString) - 1))<br>    <SPAN style="color:#00007F">Else</SPAN><br>        fUCase = s<SPAN style="color:#00007F">String</SPAN><br>    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>    <br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Function</SPAN><br><br><br><br><SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Function</SPAN> IsArrayEmpty(va <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Variant</SPAN>) <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Boolean</SPAN><br><SPAN style="color:#007F00">' Incorporates fix from Torsten Rendelmann (MVPS - Hardcore VB)</SPAN><br>    <SPAN style="color:#00007F">Dim</SPAN> i <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>    <br>    <SPAN style="color:#00007F">On</SPAN> <SPAN style="color:#00007F">Error</SPAN> <SPAN style="color:#00007F">Resume</SPAN> <SPAN style="color:#00007F">Next</SPAN><br>    i = <SPAN style="color:#00007F">LBound</SPAN>(va, 1)<br>    IsArrayEmpty = (Err.Number <> 0)<br>    <SPAN style="color:#00007F">On</SPAN> <SPAN style="color:#00007F">Error</SPAN> <SPAN style="color:#00007F">GoTo</SPAN> 0 <SPAN style="color:#007F00">' Err.Clear</SPAN><br>    <br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Function</SPAN><br><br><br><SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Function</SPAN> CloseWindow(hWnd <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>) <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Boolean</SPAN><br><br><SPAN style="color:#00007F">Dim</SPAN> iRetry <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN><br><br>CloseWindow = <SPAN style="color:#00007F">False</SPAN><br><br>RetryCloseWindow:<br>iRetry = iRetry + 1<br><br>    <SPAN style="color:#00007F">If</SPAN> SendMessage(hWnd, WM_CLOSE, 0&, 0&) = 0& <SPAN style="color:#00007F">Then</SPAN><br>    <br>        CloseWindow = <SPAN style="color:#00007F">True</SPAN><br>        <br>    <SPAN style="color:#00007F">Else</SPAN><br>    <br>        CloseWindow = <SPAN style="color:#00007F">False</SPAN><br>        CloseNamedDialog DLG_VBERROR_CAP<br>        <SPAN style="color:#00007F">Call</SPAN> Sleep(32 * iRetry)<br>        <br>        <SPAN style="color:#00007F">If</SPAN> iRetry < 4 <SPAN style="color:#00007F">Then</SPAN><br>            <SPAN style="color:#00007F">GoTo</SPAN> RetryCloseWindow<br>        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>        <br>    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Function</SPAN><br><br><SPAN style="color:#00007F">Public</SPAN> <SPAN style="color:#00007F">Function</SPAN> CloseNamedDialog(sDialogCaption <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN>) <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br><SPAN style="color:#007F00">'Returns window handle of last-closed window</SPAN><br><SPAN style="color:#00007F">On</SPAN> <SPAN style="color:#00007F">Error</SPAN> <SPAN style="color:#00007F">Resume</SPAN> <SPAN style="color:#00007F">Next</SPAN><br><br><SPAN style="color:#00007F">Dim</SPAN> iCount <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN><br><SPAN style="color:#00007F">Dim</SPAN> hwnDialog <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br><br>Err.Clear<br><br>CloseNamedDialog = 1<br><br>hwnDialog = FindWindow(DIALOG_CLS, sDialogCaption)<br><br><SPAN style="color:#00007F">Do</SPAN> <SPAN style="color:#00007F">Until</SPAN> hwnDialog = 0<br>iCount = iCount + 1<br><br>    SendMessage hwnDialog, WM_CLOSE, 0&, 0&<br>    CloseNamedDialog = hwnDialog<br>    hwnDialog = FindWindow(DIALOG_CLS, sDialogCaption)<br>    <br>    <br>    <SPAN style="color:#00007F">If</SPAN> iCount > 1 <SPAN style="color:#00007F">Then</SPAN><br>        Sleep 10 * iCount<br>        SetFocus hwnDialog<br>    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>    <br>    <SPAN style="color:#00007F">If</SPAN> iCount > 3 <SPAN style="color:#00007F">Then</SPAN><br>        <SPAN style="color:#007F00">' something's stopping us closing the window</SPAN><br>        <SPAN style="color:#00007F">Exit</SPAN> <SPAN style="color:#00007F">Do</SPAN><br>    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>    <br><SPAN style="color:#00007F">Loop</SPAN><br><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Function</SPAN><br><br><SPAN style="color:#00007F">Public</SPAN> <SPAN style="color:#00007F">Sub</SPAN> CloseGenericError()<br><SPAN style="color:#00007F">On</SPAN> Error <SPAN style="color:#00007F">Resume</SPAN> <SPAN style="color:#00007F">Next</SPAN><br><br>    CloseNamedDialog DLG_VBERROR_CAP<br>    Application.OnTime EarliestTime:=Now() + (1# / 24# / 1200#), Procedure:="CloseGeneric<SPAN style="color:#00007F">Error</SPAN>"<br><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br><br><SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Function</SPAN> ClickButton(hWndOwner <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, hWndButton <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>) <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Boolean</SPAN><br><SPAN style="color:#00007F">On</SPAN> Error <SPAN style="color:#00007F">Resume</SPAN> <SPAN style="color:#00007F">Next</SPAN><br><br>    SetForegroundWindow hWndOwner<br>    SetFocus hWndButton<br>    PostMessage hWndButton, BM_CLICK, 0&, 0&<br><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Function</SPAN><br><br><SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Function</SPAN> GetWindowText(<SPAN style="color:#00007F">ByVal</SPAN> hWnd <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>) <SPAN style="color:#00007F">As</SPAN> String<br><br><SPAN style="color:#00007F">Dim</SPAN> sBuffer <SPAN style="color:#00007F">As</SPAN> String<br><SPAN style="color:#00007F">Dim</SPAN> lBufferLen <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>    <br>    sBuffer = String$(512, 0)<br>    lBufferLen = GetWindowTextApi(hWnd, sBuffer, Len(sBuffer))<br>    GetWindowText = left$(sBuffer, lBufferLen)<br>    <br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Function</SPAN><br><br><SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Function</SPAN> GetClassName(<SPAN style="color:#00007F">ByVal</SPAN> hWnd <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>) <SPAN style="color:#00007F">As</SPAN> String<br><br><SPAN style="color:#00007F">Dim</SPAN> sBuffer <SPAN style="color:#00007F">As</SPAN> String<br><SPAN style="color:#00007F">Dim</SPAN> lBufferLen <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br>    <br>    sBuffer = String$(512, 0)<br>    lBufferLen = GetClassNameApi(hWnd, sBuffer, Len(sBuffer))<br>    GetClassName = left$(sBuffer, lBufferLen)<br>    <br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Function</SPAN><br><br></FONT>Nigel Heffernanhttp://www.blogger.com/profile/08954578765691578714noreply@blogger.com0tag:blogger.com,1999:blog-1800518423097919889.post-24627964487284667862009-12-02T23:01:00.003+00:002009-12-03T18:55:47.685+00:00A VBA function to force calculation of a cell's precedents<P Align='justify'>Here's some code I hope you don't need: a targeted 'recalculate' function.</P><P Align='justify'> Most Excel developers don't get huge workbooks that take twenty minutes to recalculate... It's our job to stop this kind of thing, right? But if you do, how do you get just one bit of the monster to calculate - the bit you're trying to debug, or explain the strange results in - when there's a long, long chain of dependencies on market data sources and external math libraries? The one thing you don't want to do is recalculate the whole workbook, but recalculating the cell with the F2 key is useless because it doesn't go right down the 'precedents' (Microsoft's term for the chain of cells and ranges that feed into your cell), no matter what you read in the documentation.</P><a href="https://blogger.googleusercontent.com/img/b/R29vZ2xl/AVvXsEjzV4dL-aaMPr1VKsnUOfLqY-WKkd5eb0o2hwy6c_mINgmJ9CpK-dxzlqD1NFHjtKASu19SpnmMq4lxy-2HjZKVhJ7IGfh1vH3SzrL1nQjXvpOTNkX9ygVgppkmQ63u85gQBRCuAQEDx4c/s1600-h/TraceDependants.JPG"><img style="float:right; margin:0 0 10px 10px;cursor:pointer; cursor:hand;width: 266px; height: 320px;" src="https://blogger.googleusercontent.com/img/b/R29vZ2xl/AVvXsEjzV4dL-aaMPr1VKsnUOfLqY-WKkd5eb0o2hwy6c_mINgmJ9CpK-dxzlqD1NFHjtKASu19SpnmMq4lxy-2HjZKVhJ7IGfh1vH3SzrL1nQjXvpOTNkX9ygVgppkmQ63u85gQBRCuAQEDx4c/s320/TraceDependants.JPG" border="0" alt=""id="BLOGGER_PHOTO_ID_5411079745704242882" /></a><P Align='justify'>So I started writing a tool to record the chain of precedents, and found that really complex spreadsheets could produce so much dependency data that the text output was impossible to assimilate. What I found out <i>next</i> was that presenting this mass of data in a structured way breaks down because there are no tools that can represent cross-linkage without turning into a visual spaghetti, and the only good tool for representing the mess as a branching structure - the treeview control - is unstable in Excel at the best of times and blows up if there's more than 16 layers of recursion or more than 255 subnodes in any given node. </P><P Align='justify'>But the end result of this failed project was a tool that could explore the precedents, list them in a collection and, having discovered all the sources leading into a cell, <b>back it's way out of the dependency chain while only calculating each cell once</b>. That's efficient - not as quick as Excel's internal dependency chain, but it's often quicker than recalculating an over-complicated workbook. And it works a treat when Excel's dependency tree is broken, or blocked by named ranges, indirect references, and third-party libraries which place range pointers in a cell instead of range addresses. <br /></P><P Align='justify'>Feel free to post your code if you get a visualisation tool to work! Also, please let me know if you can think of a way of identifying homogeneous blocks of formulae and enumerating them in one go, instead of repeating the search on cell after cell. It's not that it can't be done, but I can't see a way of doing it reliably and <i>quickly</i> enough to use on thousands of formulae.</P><P Align='justify'>Anyway, here's the code, complete with a snippet for putting it into an add-in and populating the popup 'cell' menu with a button that calls the function. As always, beware of spurious line breaks and syntax errors introduced by the Blogger platform's automatic formatting.</P><br /><br /><br /><font face=Courier New><SPAN style="color:#00007F">Option</SPAN> <SPAN style="color:#00007F">Explicit</SPAN><br><SPAN style="color:#00007F">Option</SPAN> <SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Module</SPAN><br><br /><SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Sub</SPAN> CalculatePrecedents(rngCalc <SPAN style="color:#00007F">As</SPAN> Excel.Range, <SPAN style="color:#00007F">Optional</SPAN> bVerbose <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Boolean</SPAN> = <SPAN style="color:#00007F">False</SPAN>)<br /><br /><SPAN style="color:#007F00">' Recursive function to force calculation of a dependency chain</SPAN><br /><SPAN style="color:#007F00">' with additional coding to prevent searching any range twice</SPAN><br /><br /><SPAN style="color:#00007F">On</SPAN> <SPAN style="color:#00007F">Error</SPAN> <SPAN style="color:#00007F">Resume</SPAN> <SPAN style="color:#00007F">Next</SPAN><br /><br /><br /><SPAN style="color:#00007F">Static</SPAN> iRecurse <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br /><SPAN style="color:#00007F">Static</SPAN> colRanges <SPAN style="color:#00007F">As</SPAN> Scripting.Dictionary<br /><SPAN style="color:#00007F">Static</SPAN> colWorkbooks <SPAN style="color:#00007F">As</SPAN> Scripting.Dictionary<br /><SPAN style="color:#00007F">Static</SPAN> xlPriorCalcSetting <SPAN style="color:#00007F">As</SPAN> XlCalculation<br /><SPAN style="color:#00007F">Static</SPAN> iSearched <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br /><SPAN style="color:#00007F">Static</SPAN> iCalculated <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br /><SPAN style="color:#00007F">Static</SPAN> arrNames() <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN><br /><SPAN style="color:#00007F">Static</SPAN> iCountNames <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br /><SPAN style="color:#00007F">Static</SPAN> sWorkbookName <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN><br /><br /><SPAN style="color:#00007F">Dim</SPAN> iCountPrecedents <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br /><SPAN style="color:#00007F">Dim</SPAN> rPrecedent <SPAN style="color:#00007F">As</SPAN> Excel.Range<br /><SPAN style="color:#00007F">Dim</SPAN> rCell <SPAN style="color:#00007F">As</SPAN> Excel.Range<br /><SPAN style="color:#00007F">Dim</SPAN> myName <SPAN style="color:#00007F">As</SPAN> Excel.Name<br /><SPAN style="color:#00007F">Dim</SPAN> strName <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN><br /><SPAN style="color:#00007F">Dim</SPAN> strAddress <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN><br /><SPAN style="color:#00007F">Dim</SPAN> strFormula <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN><br /><SPAN style="color:#00007F">Dim</SPAN> iLen <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br /><SPAN style="color:#00007F">Dim</SPAN> i <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN><br /><SPAN style="color:#00007F">Dim</SPAN> iMatch <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN><br /><SPAN style="color:#00007F">Dim</SPAN> iNextChar <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN><br /><SPAN style="color:#00007F">Dim</SPAN> iPrevChar <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN><br /><SPAN style="color:#00007F">Dim</SPAN> boolIsName <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Boolean</SPAN><br /><br /><SPAN style="color:#007F00">' Do we need new collections for the searched formulae and calculated ranges?</SPAN><br /><SPAN style="color:#00007F">If</SPAN> iRecurse = 0 <SPAN style="color:#00007F">Or</SPAN> rngCalc.Worksheet.Parent.Name <> sWorkbookName <SPAN style="color:#00007F">Then</SPAN><br /><br />    <SPAN style="color:#00007F">If</SPAN> colWorkbooks <SPAN style="color:#00007F">Is</SPAN> <SPAN style="color:#00007F">Nothing</SPAN> <SPAN style="color:#00007F">Then</SPAN><br />        <SPAN style="color:#00007F">Set</SPAN> colWorkbooks = <SPAN style="color:#00007F">New</SPAN> Scripting.Dictionary<br />    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br />    <br />    <SPAN style="color:#007F00">' save sets for current workbook</SPAN><br />    <SPAN style="color:#00007F">If</SPAN> <SPAN style="color:#00007F">Not</SPAN> (colWorkbooks.Exists("Ranges: " & sWorkbookName) <SPAN style="color:#00007F">Or</SPAN> colRanges <SPAN style="color:#00007F">Is</SPAN> <SPAN style="color:#00007F">Nothing</SPAN>) <SPAN style="color:#00007F">Then</SPAN><br />        colWorkbooks.Add "Ranges: " & sWorkbookName, colRanges<br />    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br />    <br />    <SPAN style="color:#007F00">' retrieve sets for newly-discovered workbook</SPAN><br />    sWorkbookName = rngCalc.Worksheet.Parent.Name<br />    <SPAN style="color:#00007F">If</SPAN> colWorkbooks.Exists("Ranges: " & sWorkbookName) <SPAN style="color:#00007F">Then</SPAN><br />        <SPAN style="color:#00007F">Set</SPAN> colRanges = colWorkbooks("Ranges: " & sWorkbookName)<br />    <SPAN style="color:#00007F">Else</SPAN><br />        <SPAN style="color:#00007F">Set</SPAN> colRanges = <SPAN style="color:#00007F">Nothing</SPAN><br />    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br />  <br /><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br /><br /><SPAN style="color:#00007F">If</SPAN> colRanges <SPAN style="color:#00007F">Is</SPAN> <SPAN style="color:#00007F">Nothing</SPAN> <SPAN style="color:#00007F">Or</SPAN> iRecurse = 0 <SPAN style="color:#00007F">Then</SPAN><br /><br />    xlPriorCalcSetting = Application.Calculation<br />    <br />    <SPAN style="color:#007F00">' Initialise the collection that prevents checking the same range twice:</SPAN><br />    <SPAN style="color:#00007F">Set</SPAN> colRanges = <SPAN style="color:#00007F">New</SPAN> Scripting.Dictionary<br />   <br />    <SPAN style="color:#007F00">' initialise and populate the array of names: this is used for a fast</SPAN><br />    <SPAN style="color:#007F00">' search to see if a named range is referenced in a formula - a test</SPAN><br />    <SPAN style="color:#007F00">' that isn't reliably executed by Excel's native 'precedents' function</SPAN><br />    <br />    iCountNames = rngCalc.Worksheet.Parent.Names.Count<br />    <br /><br />    Application.StatusBar = "Trace precedents: collating named range addresses in " & sWorkbookName & "..."<br /><br />    <SPAN style="color:#00007F">If</SPAN> bVerbose = <SPAN style="color:#00007F">True</SPAN> <SPAN style="color:#00007F">Then</SPAN><br />        Debug.Print "Trace precedents: collating named range addresses in " & sWorkbookName & "..."<br />    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br /><br />    <SPAN style="color:#00007F">If</SPAN> iCountNames > 0 <SPAN style="color:#00007F">Then</SPAN><br />    <br />        <SPAN style="color:#00007F">ReDim</SPAN> arrNames(1 <SPAN style="color:#00007F">To</SPAN> iCountNames)<br />        <br />        <SPAN style="color:#00007F">For</SPAN> i = 1 <SPAN style="color:#00007F">To</SPAN> iCountNames<br />        <br />            strName = ""<br />            strName = rngCalc.Worksheet.Parent.Names(i).NameLocal<br />            <br />            <SPAN style="color:#00007F">If</SPAN> InStr(1, strName, "!") > 0 <SPAN style="color:#00007F">Then</SPAN><br />                strName = left(strName, InStr(1, strName, "!") - 1)<br />            <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br />            <br />            arrNames(i) = strName<br />            <br />        <SPAN style="color:#00007F">Next</SPAN> i<br />        <br />        <SPAN style="color:#007F00">' Sort in descending order: looking for the longest names first allows us</SPAN><br />        <SPAN style="color:#007F00">' to prevent a match on 'ABCDE' being masked by finding 'BCD'</SPAN><br />        <br />        BubbleSortOnLen arrNames, xlDescending<br />        <br />        <br />    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN> <SPAN style="color:#007F00">'  iCountNames > 0</SPAN><br />    <br />    Application.StatusBar = "Trace precedents: analysing first cell..."<br />    <br />    <SPAN style="color:#00007F">If</SPAN> bVerbose = <SPAN style="color:#00007F">True</SPAN> <SPAN style="color:#00007F">Then</SPAN><br />        Debug.Print "Trace precedents: analysing first cell... '" & rngCalc.Worksheet.Name & "'!" & rngCalc.Address<br />    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br />    <br /><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br /><br /><br /><SPAN style="color:#007F00">' Check for ranges we've searched before.</SPAN><br /><br /><SPAN style="color:#007F00">' First check: it might be a single cell; if so, is it part of an array we've already analysed?</SPAN><br /><SPAN style="color:#00007F">If</SPAN> rngCalc.Cells.Count = 1 <SPAN style="color:#00007F">Then</SPAN><br />    <SPAN style="color:#00007F">If</SPAN> rngCalc.HasArray <SPAN style="color:#00007F">Then</SPAN><br />    <br />        <SPAN style="color:#00007F">If</SPAN> colRanges.Exists("'" & rngCalc.Worksheet.Name & "'!" & rngCalc.CurrentArray) Then<br />           <SPAN style="color:#00007F">GoTo</SPAN> ExitSub<br />        <SPAN style="color:#00007F">Else</SPAN><br />            colRanges.Add "'" & rngCalc.Worksheet.Name & "'!" & rngCalc.CurrentArray, "Recursion " & CStr(iRecurse) & vbTab & "'" & rngCalc.Worksheet.Name & "'!" & rngCalc.AddressLocal & vbTab & "{" & rngCalc.Formula & "}"<br />        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br />        <br />    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br /><br />    <SPAN style="color:#007F00">' Exit if there's no formula; there can be no precedents</SPAN><br />    <SPAN style="color:#007F00">' Note that we had to check it wan't an array beforehand</SPAN><br />    <SPAN style="color:#00007F">If</SPAN> <SPAN style="color:#00007F">Not</SPAN> (IsNull(rngCalc.HasFormula) <SPAN style="color:#00007F">Or</SPAN> (rngCalc.HasFormula = <SPAN style="color:#00007F">True</SPAN>)) <SPAN style="color:#00007F">Then</SPAN><br />        <SPAN style="color:#00007F">GoTo</SPAN> ExitSub<br />    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br />    <br /><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN>  <SPAN style="color:#007F00">' rngCalc.Cells.Count = 1</SPAN><br /><br /><SPAN style="color:#007F00">' Check that we haven't searched this range already - there's an overhead doing this, but it's better than repeated search and calculation</SPAN><br /><SPAN style="color:#00007F">If</SPAN> colRanges.Exists("'" & rngCalc.Worksheet.Name & "'!" & rngCalc.AddressLocal) Then<br />    <SPAN style="color:#00007F">GoTo</SPAN> ExitSub<br /><SPAN style="color:#00007F">Else</SPAN><br />    colRanges.Add "'" & rngCalc.Worksheet.Name & "'!" & rngCalc.AddressLocal, "Recursion " & CStr(iRecurse) & vbTab & "'" & rngCalc.Worksheet.Name & "'!" & rngCalc.AddressLocal<br /><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br /><br /><br /><SPAN style="color:#007F00">' Keep track of recursion: this tells us when the search has been completed</SPAN><br /><SPAN style="color:#00007F">If</SPAN> iRecurse < 0 <SPAN style="color:#00007F">Then</SPAN><br />    iRecurse = 0<br /><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br /><br /><SPAN style="color:#00007F">If</SPAN> iSearched Mod 10 = 0 <SPAN style="color:#00007F">Then</SPAN><br />    Application.StatusBar = "Trace precedents: searched " & Format(iSearched, "#,##0") & "    Calculated " & Format(iCalculated, "#,##0") & "    Recursion level " & iRecurse & "    Cell '" & rngCalc.Worksheet.Name & "'!" & rngCalc.Address<br /><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br /><br /><SPAN style="color:#00007F">If</SPAN> bVerbose = <SPAN style="color:#00007F">True</SPAN> <SPAN style="color:#00007F">Then</SPAN><br />    Debug.Print "Trace precedents - search " & iSearched & ":" & vbTab & " Precedents of " & vbTab & "'" & rngCalc.Worksheet.Name & "'!" & rngCalc.AddressLocal & vbTab & " Formula: " & rngCalc.Formula & vbTab & " at recursion level " & iRecurse<br /><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br /><br /><SPAN style="color:#00007F">If</SPAN> rngCalc.Cells.Count = 1 <SPAN style="color:#00007F">Then</SPAN><br /><br />    str<SPAN style="color:#00007F">For</SPAN>mula = ""<br />    strFormula = LTrim(rngCalc.Formula)<br />        <br />    <SPAN style="color:#007F00">' Check for named ranges in the formula: these are not</SPAN><br />    <SPAN style="color:#007F00">' recognized as reliably as "A1" specified addresses</SPAN><br />    <SPAN style="color:#007F00">' and will therefore not be recognised as precedents</SPAN><br />    <br />    For i = 1 <SPAN style="color:#00007F">To</SPAN> iCountNames <SPAN style="color:#00007F">Step</SPAN> 1<br />    <br />        strName = ""<br />        strName = arrNames(i)<br /><br />        <br />        iMatch = InStr(1, strFormula, strName, vbTextCompare)<br />        <SPAN style="color:#00007F">If</SPAN> iMatch > 0 <SPAN style="color:#00007F">Then</SPAN><br />        <br />            boolIsName = <SPAN style="color:#00007F">True</SPAN><br />            <br />            <SPAN style="color:#007F00">' A name like "res" might well be a substring of another name, or of a</SPAN><br />            <SPAN style="color:#007F00">' function name. So we must establish that the string we've found isn't</SPAN><br />            <SPAN style="color:#007F00">' just a match for a named range: it's got to be in use as an address.</SPAN><br />            <br />            iLen = Len(strName)<br />            iPrevChar = 0<br />            iNextChar = 0<br />            <br />            <SPAN style="color:#00007F">If</SPAN> iMatch + iLen = Len(strFormula) <SPAN style="color:#00007F">Then</SPAN><br />                iNextChar = 0<br />            <SPAN style="color:#00007F">Else</SPAN><br />                iNextChar = iMatch + iLen + 1<br />            <br />                <SPAN style="color:#00007F">Select</SPAN> <SPAN style="color:#00007F">Case</SPAN> Mid(strFormula, iNextChar, 1)<br />                <SPAN style="color:#00007F">Case</SPAN> "(", Chr(34), ".", "!", "a" <SPAN style="color:#00007F">To</SPAN> "z", "A" <SPAN style="color:#00007F">To</SPAN> "Z", 0 <SPAN style="color:#00007F">To</SPAN> 9<br />                    <SPAN style="color:#007F00">'strName definitely isn't a named range</SPAN><br />                    boolIsName = <SPAN style="color:#00007F">False</SPAN><br />                <SPAN style="color:#00007F">Case</SPAN> <SPAN style="color:#00007F">Else</SPAN><br />                    <SPAN style="color:#007F00">' no action... move to next test</SPAN><br />                <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Select</SPAN><br />                <br />            <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br />            <br />            <SPAN style="color:#00007F">If</SPAN> iMatch > 1 <SPAN style="color:#00007F">Then</SPAN><br />            <br />                iPrevChar = iMatch - 1<br />                <br />                <SPAN style="color:#00007F">Select</SPAN> <SPAN style="color:#00007F">Case</SPAN> Mid(str<SPAN style="color:#00007F">For</SPAN>mula, iPrevChar, 1)<br />                <SPAN style="color:#00007F">Case</SPAN> Chr(34), ".", "!", "a" <SPAN style="color:#00007F">To</SPAN> "z", "A" <SPAN style="color:#00007F">To</SPAN> "Z", 0 <SPAN style="color:#00007F">To</SPAN> 9<br />                    <SPAN style="color:#007F00">'strName definitely isn't a named range</SPAN><br />                    boolIsName = <SPAN style="color:#00007F">False</SPAN><br />                <SPAN style="color:#00007F">Case</SPAN> <SPAN style="color:#00007F">Else</SPAN><br />                    <SPAN style="color:#007F00">' no action... move to next test</SPAN><br />                <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Select</SPAN><br />            <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br />            <br />            <SPAN style="color:#00007F">If</SPAN> boolIsName <SPAN style="color:#00007F">Then</SPAN><br />            <br />                iSearched = iSearched + 1<br />                iRecurse = iRecurse + 1<br />                CalculatePrecedents rngCalc.Worksheet.Parent.Names(strName).RefersToRange, bVerbose<br />                iRecurse = iRecurse - 1<br />                <br />                <SPAN style="color:#007F00">' Strip the matched name out of our formula string, so we only analyse it once:</SPAN><br />                strFormula = Application.WorksheetFunction.Substitute(str<SPAN style="color:#00007F">For</SPAN>mula, strName, "")<br />                <br />            <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN> <SPAN style="color:#007F00">'boolIsName</SPAN><br />            <br />        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br />        <br />    <SPAN style="color:#00007F">Next</SPAN> i<br />    <br />    iCountPrecedents = 0<br />    iCountPrecedents = rngCalc.DirectPrecedents.Count<br />    <br />    <SPAN style="color:#00007F">If</SPAN> iCountPrecedents > 0 <SPAN style="color:#00007F">Then</SPAN><br />    <br />        For <SPAN style="color:#00007F">Each</SPAN> rPrecedent <SPAN style="color:#00007F">In</SPAN> rngCalc.DirectPrecedents<br />            iSearched = iSearched + 1<br />            iRecurse = iRecurse + 1<br />            CalculatePrecedents rPrecedent, bVerbose<br />            iRecurse = iRecurse - 1<br />        <SPAN style="color:#00007F">Next</SPAN><br />        <br />    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN> <SPAN style="color:#007F00">' .DirectPrecedents.Count = 0</SPAN><br /><br /><SPAN style="color:#00007F">Else</SPAN><br /><br />    <SPAN style="color:#007F00">' unless it's an array formula, search each cell</SPAN><br />    <SPAN style="color:#00007F">If</SPAN> IsNull(rngCalc.FormulaArray) <SPAN style="color:#00007F">Then</SPAN><br />    <br />        <SPAN style="color:#00007F">For</SPAN> <SPAN style="color:#00007F">Each</SPAN> rCell <SPAN style="color:#00007F">In</SPAN> rngCalc.SpecialCells(xlCellTypeFormulas)<br />        <br />            <SPAN style="color:#00007F">If</SPAN> rCell.HasFormula <SPAN style="color:#00007F">Then</SPAN><br />                iSearched = iSearched + 1<br />                iRecurse = iRecurse + 1<br />                CalculatePrecedents rCell, bVerbose<br />                iRecurse = iRecurse - 1<br />            <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br />            <br />        <SPAN style="color:#00007F">Next</SPAN> rCell<br />        <br />    <SPAN style="color:#00007F">Else</SPAN><br />    <br />        <SPAN style="color:#007F00">' for an array, run the precedents of the entire range:</SPAN><br />        For <SPAN style="color:#00007F">Each</SPAN> rPrecedent <SPAN style="color:#00007F">In</SPAN> rngCalc.DirectPrecedents<br />            iSearched = iSearched + 1<br />            iRecurse = iRecurse + 1<br />            CalculatePrecedents rPrecedent, bVerbose<br />            iRecurse = iRecurse - 1<br />        <SPAN style="color:#00007F">Next</SPAN><br />    <br />    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br /><br /><br /><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN> <SPAN style="color:#007F00">' cells.count = 1</SPAN><br /><br /><br />iCalculated = iCalculated + 1<br /><br /><SPAN style="color:#00007F">If</SPAN> bVerbose = <SPAN style="color:#00007F">True</SPAN> <SPAN style="color:#00007F">Then</SPAN><br />    Debug.Print "Calculating cell " & iCalculated & " (recursion layer " & iRecurse & "): " & "'" & rngCalc.Worksheet.Name & "'!" & rngCalc.AddressLocal & vbTab & vbTab & rngCalc.Formula<br /><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br /><br /><SPAN style="color:#00007F">If</SPAN> bVerbose = <SPAN style="color:#00007F">True</SPAN> <SPAN style="color:#00007F">Then</SPAN><br />    Debug.Print vbTab & "Trace precedents - Calculation " & iCalculated & ":" & vbTab & "'" & rngCalc.Worksheet.Name & "'!" & rngCalc.AddressLocal & vbTab & " <SPAN style="color:#00007F">For</SPAN>mula: "; vbTab & rngCalc.<SPAN style="color:#00007F">For</SPAN>mula & " at recursion level " & iRecurse<br /><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br /><br />rngCalc.Calculate<br /><br /><br />ExitSub:<br /><br />    <br />    <SPAN style="color:#00007F">If</SPAN> iRecurse < 0 <SPAN style="color:#00007F">Then</SPAN>  <SPAN style="color:#007F00">' this is redundant in production code, but it'll save you grief in development</SPAN><br />        iRecurse = 0<br />    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br />    <br />    <br />    <SPAN style="color:#00007F">If</SPAN> iRecurse = 0 <SPAN style="color:#00007F">Then</SPAN><br />    <br />        <SPAN style="color:#00007F">If</SPAN> bVerbose = <SPAN style="color:#00007F">True</SPAN> <SPAN style="color:#00007F">Then</SPAN><br />            Application.StatusBar = "Trace precedents searched " & <SPAN style="color:#00007F">For</SPAN>mat(iSearched, "#,##0") & "    Calculated " & <SPAN style="color:#00007F">For</SPAN>mat(iCalculated, "#,##0") & "    Recursion returned to " & iRecurse<br />        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br />    <br />        Erase arrNames<br />        Application.StatusBar = <SPAN style="color:#00007F">False</SPAN><br />        iSearched = 0<br />        iCalculated = 0<br />        <SPAN style="color:#00007F">Set</SPAN> colRanges = <SPAN style="color:#00007F">Nothing</SPAN><br />        Application.Calculation = xlPriorCalcSetting<br />        <br />    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br />        <br /><br /><br /><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br /><br /><br /><SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Sub</SPAN> BubbleSortOnLen(<SPAN style="color:#00007F">ByRef</SPAN> arrStrings() <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN>, <SPAN style="color:#00007F">Optional</SPAN> SortOrder <SPAN style="color:#00007F">As</SPAN> Excel.XlSortOrder = xlAscending)<br /><SPAN style="color:#007F00">' Modified Bubble Sort: sort an array of strings by length</SPAN><br /><br /><SPAN style="color:#00007F">Dim</SPAN> iFirst  <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN><br /><SPAN style="color:#00007F">Dim</SPAN> iLast   <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN><br /><SPAN style="color:#00007F">Dim</SPAN> i       <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN><br /><SPAN style="color:#00007F">Dim</SPAN> j       <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN><br /><SPAN style="color:#00007F">Dim</SPAN> sTemp   <SPAN style="color:#00007F">As</SPAN> String<br /><br />     <br />    iFirst = <SPAN style="color:#00007F">LBound</SPAN>(arrStrings)<br />    iLast = <SPAN style="color:#00007F">UBound</SPAN>(arrStrings)<br />    <br />    <SPAN style="color:#00007F">If</SPAN> SortOrder = xlAscending <SPAN style="color:#00007F">Then</SPAN><br />    <br />        For i = iFirst <SPAN style="color:#00007F">To</SPAN> iLast - 1<br />            For j = i + 1 <SPAN style="color:#00007F">To</SPAN> iLast<br />                <SPAN style="color:#00007F">If</SPAN> Len(arrStrings(i)) > Len(arrStrings(j)) <SPAN style="color:#00007F">Then</SPAN><br />                    sTemp = arrStrings(j)<br />                    arrStrings(j) = arrStrings(i)<br />                    arrStrings(i) = sTemp<br />                <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br />            <SPAN style="color:#00007F">Next</SPAN> j<br />        <SPAN style="color:#00007F">Next</SPAN> i<br />        <br />    <SPAN style="color:#00007F">Else</SPAN>   <SPAN style="color:#007F00">' SortOrder = xlDescending</SPAN><br />    <br />        For i = iFirst <SPAN style="color:#00007F">To</SPAN> iLast - 1<br />            For j = i + 1 <SPAN style="color:#00007F">To</SPAN> iLast<br />                <SPAN style="color:#00007F">If</SPAN> Len(arrStrings(i)) < Len(arrStrings(j)) <SPAN style="color:#00007F">Then</SPAN><br />                    sTemp = arrStrings(j)<br />                    arrStrings(j) = arrStrings(i)<br />                    arrStrings(i) = sTemp<br />                    <br />                <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br />                <br />            <SPAN style="color:#00007F">Next</SPAN> j<br />        <SPAN style="color:#00007F">Next</SPAN> i<br />    <br />    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN> <SPAN style="color:#007F00">' sortorder</SPAN><br />     <br /><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br /> <br /><br /><SPAN style="color:#00007F">Public</SPAN> <SPAN style="color:#00007F">Sub</SPAN> CalculateSelection()<br /><SPAN style="color:#007F00">' Called from a button in a menubar or popup</SPAN><br /><br /><SPAN style="color:#00007F">On</SPAN> <SPAN style="color:#00007F">Error</SPAN> <SPAN style="color:#00007F">Resume</SPAN> <SPAN style="color:#00007F">Next</SPAN><br />    Selection.Calculate<br />    <br /><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br /><br /><SPAN style="color:#00007F">Public</SPAN> <SPAN style="color:#00007F">Sub</SPAN> GetPrecedents()<br /><SPAN style="color:#007F00">' Called from a button in a menubar or popup</SPAN><br /><br />    CalculatePrecedents Selection, <SPAN style="color:#00007F">False</SPAN><br />    <br /><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN></FONT><br /><br /><br /><P Align='justify'><br />And here's the boilerplate code that puts Calculate Precedents into an add-in's 'Workbook' object module and adds our function to the right-click popup menu for an Excel worksheet:<br /></P><br /><br /><br /><font face=Courier New><SPAN style="color:#00007F">Option</SPAN> <SPAN style="color:#00007F">Explicit</SPAN><br><br><SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Sub</SPAN> Workbook_AddinInstall()<br><br><SPAN style="color:#00007F">Dim</SPAN> objCbtn <SPAN style="color:#00007F">As</SPAN> Office.CommandBarButton<br><SPAN style="color:#00007F">Dim</SPAN> objCbtn2 <SPAN style="color:#00007F">As</SPAN> Office.CommandBarButton<br><SPAN style="color:#00007F">Dim</SPAN> objCbar <SPAN style="color:#00007F">As</SPAN> Office.CommandBar<br><br><br><SPAN style="color:#00007F">With</SPAN> Application.CommandBars("Cell")<br><br>    <SPAN style="color:#00007F">Set</SPAN> objCbtn = .FindControl(, , "Calculate Precedents", , <SPAN style="color:#00007F">True</SPAN>)<br>    <br>    <SPAN style="color:#00007F">Do</SPAN> <SPAN style="color:#00007F">Until</SPAN> objCbtn <SPAN style="color:#00007F">Is</SPAN> <SPAN style="color:#00007F">Nothing</SPAN><br>        objCbtn.Delete<br>        <SPAN style="color:#00007F">Set</SPAN> objCbtn = .FindControl(, , "Calculate Precedents", , <SPAN style="color:#00007F">True</SPAN>)<br>    <SPAN style="color:#00007F">Loop</SPAN><br>    <br>    <SPAN style="color:#00007F">Set</SPAN> objCbtn = .Controls.Add(msoControlButton, , , , <SPAN style="color:#00007F">True</SPAN>)<br>     <br>     <br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN>  <SPAN style="color:#007F00">'Application.CommandBars("Cell")</SPAN><br><br><SPAN style="color:#00007F">With</SPAN> objCbtn<br><br>    .BeginGroup = <SPAN style="color:#00007F">True</SPAN><br>    .Caption = "Calculate Precedents"<br>    .DescriptionText = "Locate all precedents and calculate recursively"<br>    .OnAction = "GetPrecedents"<br>    .Tag = "Calculate Precedents"<br>    .TooltipText = "Locate all precedents and calculate recursively"<br>    .FaceId = 452<br>    <br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN> <SPAN style="color:#007F00">'objCbtn</SPAN><br>  <br><SPAN style="color:#00007F">Set</SPAN> objCbtn = <SPAN style="color:#00007F">Nothing</SPAN><br><br><br><SPAN style="color:#00007F">With</SPAN> Application.CommandBars("Cell")<br><br>    <SPAN style="color:#00007F">Set</SPAN> objCbtn = .FindControl(, , "Calculate Selection", , <SPAN style="color:#00007F">True</SPAN>)<br>    <br>    <SPAN style="color:#00007F">Do</SPAN> <SPAN style="color:#00007F">Until</SPAN> objCbtn <SPAN style="color:#00007F">Is</SPAN> <SPAN style="color:#00007F">Nothing</SPAN><br>        objCbtn.Delete<br>        <SPAN style="color:#00007F">Set</SPAN> objCbtn = .FindControl(, , "Calculate Selection", , <SPAN style="color:#00007F">True</SPAN>)<br>    <SPAN style="color:#00007F">Loop</SPAN><br>    <br>    <SPAN style="color:#00007F">Set</SPAN> objCbtn = .Controls.Add(msoControlButton, , , , <SPAN style="color:#00007F">True</SPAN>)<br>     <br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN>  <SPAN style="color:#007F00">'Application.CommandBars("Cell")</SPAN><br><br><SPAN style="color:#00007F">With</SPAN> objCbtn<br><br>    .Caption = "Calculate Selection"<br>    .OnAction = "CalculateSelection"<br>    .Tag = "Calculate Selection"<br>    .TooltipText = "Calculate the selected range"<br>    .FaceId = 346<br>    <br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN> <SPAN style="color:#007F00">'objCbtn</SPAN><br>  <br><SPAN style="color:#00007F">Set</SPAN> objCbtn = <SPAN style="color:#00007F">Nothing</SPAN><br><br><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br><br><SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Sub</SPAN> Workbook_AddinUninstall()<br><br><SPAN style="color:#00007F">Dim</SPAN> objCbtn <SPAN style="color:#00007F">As</SPAN> Office.CommandBarButton<br><br><SPAN style="color:#00007F">With</SPAN> Application.CommandBars("Cell")<br><br>    <SPAN style="color:#00007F">Set</SPAN> objCbtn = .FindControl(, , "Calculate Precedents", , <SPAN style="color:#00007F">True</SPAN>)<br>    <br>    <SPAN style="color:#00007F">If</SPAN> <SPAN style="color:#00007F">Not</SPAN> objCbtn <SPAN style="color:#00007F">Is</SPAN> <SPAN style="color:#00007F">Nothing</SPAN> <SPAN style="color:#00007F">Then</SPAN><br>        objCbtn.Delete<br>    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>        <br>    <br>    <SPAN style="color:#00007F">Set</SPAN> objCbtn = .FindControl(, , "Calculate Selection", , <SPAN style="color:#00007F">True</SPAN>)<br>    <br>    <SPAN style="color:#00007F">If</SPAN> <SPAN style="color:#00007F">Not</SPAN> objCbtn <SPAN style="color:#00007F">Is</SPAN> <SPAN style="color:#00007F">Nothing</SPAN> <SPAN style="color:#00007F">Then</SPAN><br>        objCbtn.Delete<br>    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>    <br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN>  <SPAN style="color:#007F00">'Application.CommandBars("Cell")</SPAN><br>  <br><SPAN style="color:#00007F">Set</SPAN> objCbtn = <SPAN style="color:#00007F">Nothing</SPAN><br><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br><br><SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Sub</SPAN> Workbook_BeforeClose(Cancel <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Boolean</SPAN>)<br><br><SPAN style="color:#00007F">Call</SPAN> Workbook_AddinUninstall<br><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br><br><SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Sub</SPAN> Workbook_Open()<br><br><SPAN style="color:#00007F">Call</SPAN> Workbook_AddinInstall<br><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br></FONT>Nigel Heffernanhttp://www.blogger.com/profile/08954578765691578714noreply@blogger.com0tag:blogger.com,1999:blog-1800518423097919889.post-54866874877281918002009-12-01T15:22:00.002+00:002009-12-01T15:59:50.586+00:00Who owns that file? Using WMI to identify the owner of a file<P Align='justify'><br />Every now and again, I have the job of archiving vast numbers of workbooks: a penance for failing to move the users on from using Excel for primary data storage and saving down each day's valuations in a separate sheet.<br /></P><br /><P Align='justify'><br />As you can imagine, this gets tedious, and it needs automating... Any fool can write a script to delete, zip or move files around, and many fools have done so: few were so damned by their actions in a past life as to be doomed to <i>notify the file owners by email</i>.<br /></P><br /><P Align='justify'><br /><B>But who owns the file?</B><br /></P><br /><P Align='justify'><br />Every now and again, Windows shows that a simple question can be made to have an absurdly difficult answer, and finding the owner of a named file is one of the worst I've come across. The API calls have been analysed and explained by Emmet Gray:<br /><BR /><BR /><br />http://www.emmet-gray.com/Articles/GetOwner.htm<br /><BR /><BR /><br />You are welcome to read it and try out the code: it is a remarkable feat of analysis and simplification in the face of the wilfully illogical and obscure and, despite being pared down and superbly documented, it is a truly intimidating piece of API coding. You cannot extract the Security Descriptor of a file in less than a hundred lines of code and, when you've got it, you will rapidly realise that opening up and interrogating a file's Security Descriptor for the SID of the user only leads to an even deeper travail in extracting a human-readable user name. I do not believe that it can be done in less than a thousand lines of code and I would question whether it can be done reproducibly and reliably - let lone clearly - which is to say that it probably shouldn't be done in VBA.<br /></P><br /><P Align='justify'><br />But I've still got the job of digging out the user names for all the files I'm archiving. The code snippet below uses WMI - Windows Management Information - a truly horrible API released (but not documented) by Microsoft for systems administrators. If WMI is an improvement, I shudder to think what they had to do before it existed, and I am astonished that the haven't all turned into the BOFH (Look it up. But not at work). But it is at least <i>short</i>. All it is, is a 'Get Owner' function and a small Scripting wrapper that searches a folder and lists the files...<br /></P><br /><br /><br /><BLOCKQUOTE><br /><font face=Courier New><br><br><SPAN style="color:#00007F">Private</SPAN> <SPAN style="color:#00007F">Function</SPAN> GetFileOwner(strFile <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN>, <SPAN style="color:#00007F">Optional</SPAN> WithDomainName <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Boolean</SPAN> = <SPAN style="color:#00007F">False</SPAN>) <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN><br><br><SPAN style="color:#007F00">' Returns the owner of a file or folder, or a comma-delimited list if there are multiple owners.</SPAN><br><br><SPAN style="color:#007F00">' Usage:</SPAN><br><SPAN style="color:#007F00">'     Debug.Print GetFileOwner("H:\Personal\MyFile.txt")</SPAN><br><SPAN style="color:#007F00">'       heffernann</SPAN><br><SPAN style="color:#007F00">'</SPAN><br><SPAN style="color:#007F00">'     Debug.Print GetFileOwner("H:\Personal\MyFile.txt", TRUE)</SPAN><br><SPAN style="color:#007F00">'       OLYMPUS\heffernann</SPAN><br><SPAN style="color:#007F00">'</SPAN><br><SPAN style="color:#007F00">'     Debug.Print GetFileOwner("\\OLYMPUS\Users\heffernann\Personal\MyFile.txt", TRUE)</SPAN><br><SPAN style="color:#007F00">'       [returns nothing, see below]</SPAN><br><br><br><SPAN style="color:#007F00">' This works with local drives and mapped drives, but fully-qualified network paths do not work.</SPAN><br><SPAN style="color:#007F00">' According to the documentation, WMI will return an error when the file owner is a user who has</SPAN><br><SPAN style="color:#007F00">' been purged from the system. However, all that happens here is that we get an empty collection</SPAN><br><br><SPAN style="color:#007F00">' Author: Nigel Heffernan</SPAN><br><br><br><SPAN style="color:#007F00">' The underlying technology is WMI (Windows Management Information).</SPAN><br><SPAN style="color:#007F00">' The WMI documentation is very poor, even by the standards of MSDN.</SPAN><br><SPAN style="color:#007F00">' However, Microsoft's 'Hey! Scripting Guy!' site has usable information:</SPAN><br><br><SPAN style="color:#007F00">'   http://www.microsoft.com/technet/scriptcenter/resources/qanda/oct04/hey1007.mspx</SPAN><br><br><br><br><SPAN style="color:#00007F">Static</SPAN> objWMIService <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Object</SPAN>      <SPAN style="color:#007F00">' Persistent object: this is called repeatedly,</SPAN><br>                                    <SPAN style="color:#007F00">' so you may prefer to declare it at module level</SPAN><br>                                    <SPAN style="color:#007F00">' and instantiate/dismiss it explicitly</SPAN><br><br><SPAN style="color:#00007F">Dim</SPAN> colItems <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Object</SPAN><br><SPAN style="color:#00007F">Dim</SPAN> objItem <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Object</SPAN><br><br><SPAN style="color:#00007F">Dim</SPAN> strComputer <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN><br><SPAN style="color:#00007F">Dim</SPAN> strWMI_Query <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN><br><SPAN style="color:#00007F">Dim</SPAN> strOwner <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN><br><SPAN style="color:#00007F">Dim</SPAN> strOutput <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN><br><SPAN style="color:#00007F">Dim</SPAN> iCount <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN><br><br><SPAN style="color:#00007F">Const</SPAN> wbemFlagReturnImmediately <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN> = 16<br><SPAN style="color:#00007F">Const</SPAN> wbemFlagForwardOnly <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN> = 32<br><SPAN style="color:#00007F">Dim</SPAN> IFlags <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br><br><br>    IFlags = wbemFlagReturnImmediately + wbemFlagForwardOnly<br><br><br>    strComputer = "."   <SPAN style="color:#007F00">' WMI notation for 'This machine'</SPAN><br>                        <SPAN style="color:#007F00">' WMI script sometimes works if remote machine names are specified</SPAN><br>                        <SPAN style="color:#007F00">' but you'll need to specify the local path when looking up files</SPAN><br>                            <br>    strWMI_Query = ""<br>    strWMI_Query = strWMI_Query & "ASSOCIATORS OF "<br>    strWMI_Query = strWMI_Query & "{Win32_LogicalFileSecuritySetting='" & strFile & "'}"<br>    strWMI_Query = strWMI_Query & " WHERE AssocClass=Win32_LogicalFileOwner ResultRole=Owner"<br>    <br><br><SPAN style="color:#007F00">' WMI Association classes can be instantiated directly, but the syntax is arcane.</SPAN><br><SPAN style="color:#007F00">' Querying the WMI data service is simpler, if you can find a pre-existing query template</SPAN><br><br>    <SPAN style="color:#00007F">If</SPAN> objWMIService <SPAN style="color:#00007F">Is</SPAN> <SPAN style="color:#00007F">Nothing</SPAN> <SPAN style="color:#00007F">Then</SPAN><br>        <SPAN style="color:#00007F">Set</SPAN> objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")<br>    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br><br><br>    <SPAN style="color:#007F00">' ExecQuery is relatively easy to do, but rather slow</SPAN><br>    <SPAN style="color:#00007F">Set</SPAN> colItems = objWMIService.ExecQuery(strWMI_Query, , IFlags)<br>    <br>    <SPAN style="color:#007F00">' AssociatorsOf is faster, and is documented here: http://msdn.microsoft.com/en-us/library/aa393858(VS.85).aspx</SPAN><br>    <SPAN style="color:#007F00">'Set colItems = objWMIService.AssociatorsOf("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2", "Win32_LogicalFileOwner", "SWbemObjectEx", "Owner", , , , , , IFlags)</SPAN><br><br>    strOutput = ""<br>    iCount = 0<br>    <SPAN style="color:#00007F">On</SPAN> <SPAN style="color:#00007F">Error</SPAN> <SPAN style="color:#00007F">Resume</SPAN> <SPAN style="color:#00007F">Next</SPAN><br><br>        <SPAN style="color:#00007F">For</SPAN> <SPAN style="color:#00007F">Each</SPAN> objItem <SPAN style="color:#00007F">In</SPAN> colItems<br>        <br>            strOwner = ""<br>            <SPAN style="color:#00007F">If</SPAN> WithDomainName <SPAN style="color:#00007F">Then</SPAN><br>                strOwner = objItem.ReferencedDomainName & "\" & objItem.AccountName<br>            <SPAN style="color:#00007F">Else</SPAN><br>                strOwner = objItem.AccountName & ","<br>            <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>            <br>            strOutput = strOutput & strOwner<br>            <br>        <SPAN style="color:#00007F">Next</SPAN> objItem<br>    <br><SPAN style="color:#007F00">'Trim trailing comma:</SPAN><br><br>    strOutput = Trim(strOutput)<br>    <SPAN style="color:#00007F">If</SPAN> Len(strOutput) > 0 <SPAN style="color:#00007F">Then</SPAN><br>        strOutput = Left(strOutput, Len(strOutput) - 1)<br>    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>    <br>    GetFileOwner = strOutput<br>    <br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Function</SPAN><br><br><br><SPAN style="color:#00007F">Public</SPAN> <SPAN style="color:#00007F">Sub</SPAN> RecurseFolder(strFolder <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN>, <SPAN style="color:#00007F">Optional</SPAN> RecursionLevel <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN> = 0, <SPAN style="color:#00007F">Optional</SPAN> minDateLastModified <SPAN style="color:#00007F">As</SPAN> Date = 0, <SPAN style="color:#00007F">Optional</SPAN> minSize <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Double</SPAN> = 0)<br><br><SPAN style="color:#007F00">' Recursive Subroutine to enumerate the contents of an NT folder.</SPAN><br><SPAN style="color:#007F00">' Writes the results to a log file</SPAN><br><br><SPAN style="color:#007F00">' Subfolders are enumerated by a recursive call</SPAN><br><SPAN style="color:#007F00">' For use in Excel VBA: can be converted to VBScript</SPAN><br><br><SPAN style="color:#007F00">' REQUIRES module-level declarations:</SPAN><br><br><SPAN style="color:#007F00">'       objLogStream (Scripting.TextStream)</SPAN><br><SPAN style="color:#007F00">'       objFSO (Scripting.FileSystemObject)</SPAN><br><SPAN style="color:#007F00">'       LogfileName  (string)</SPAN><br><br><SPAN style="color:#007F00">' REQUIRES Subroutines and Functions:</SPAN><br><br><SPAN style="color:#007F00">'       GetFileOwner</SPAN><br><SPAN style="color:#007F00">'       Logfile</SPAN><br><SPAN style="color:#007F00">'       CloseLogFile</SPAN><br><br><br><SPAN style="color:#007F00">' VBA Declarations:</SPAN><br><SPAN style="color:#00007F">Dim</SPAN> objFolder <SPAN style="color:#00007F">As</SPAN> Folder<br><SPAN style="color:#00007F">Dim</SPAN> objSubFolder <SPAN style="color:#00007F">As</SPAN> Folder<br><br><SPAN style="color:#00007F">Dim</SPAN> objFile     <SPAN style="color:#00007F">As</SPAN> File<br><SPAN style="color:#00007F">Dim</SPAN> strFile     <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN><br><SPAN style="color:#00007F">Dim</SPAN> strMessage  <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN><br><SPAN style="color:#00007F">Dim</SPAN> strOwner    <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN><br><SPAN style="color:#00007F">Dim</SPAN> strSize     <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN><br><SPAN style="color:#00007F">Dim</SPAN> lngCountLog <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br><br><br><br><br><br><SPAN style="color:#00007F">If</SPAN> objFSO <SPAN style="color:#00007F">Is</SPAN> <SPAN style="color:#00007F">Nothing</SPAN> <SPAN style="color:#00007F">Then</SPAN><br>    <SPAN style="color:#00007F">Set</SPAN> objFSO = <SPAN style="color:#00007F">New</SPAN> FileSystemObject<br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br><br><SPAN style="color:#00007F">Set</SPAN> objFolder = objFSO.GetFolder(strFolder)<br><br><br>Application.StatusBar = "Searching folders: " & RecursionLevel & " layers: " & strFolder<br><br><SPAN style="color:#007F00">' Use this if you're reporting progress on a worksheet (requires named range as shown):</SPAN><br>ThisWorkbook.Names("CurrentFolder").RefersToRange.Value = strFolder<br><br>strOwner = GetFileOwner(objFolder.Path)<br><br><SPAN style="color:#00007F">On</SPAN> <SPAN style="color:#00007F">Error</SPAN> <SPAN style="color:#00007F">Resume</SPAN> <SPAN style="color:#00007F">Next</SPAN><br><br><br>strMessage = ""<br>strMessage = strMessage & "FOLDER" & vbTab & objFolder.name & vbTab & 0 & vbTab & objFolder.DateLastModified & vbTab & objFolder.DateLastAccessed & vbTab & strOwner & vbTab & objFolder.Path & vbTab & RecursionLevel<br>Logfile strMessage<br><br><br>    lngCountLog = 0<br><br>    <SPAN style="color:#00007F">For</SPAN> <SPAN style="color:#00007F">Each</SPAN> objFile <SPAN style="color:#00007F">In</SPAN> objFolder.Files<br>    <br>            strFile = objFile.Path<br>            <br>            <SPAN style="color:#00007F">If</SPAN> objFile.DateLastModified >= minDateLastModified <SPAN style="color:#00007F">Then</SPAN><br>            <br>                <SPAN style="color:#00007F">If</SPAN> objFile.Size >= minSize <SPAN style="color:#00007F">Then</SPAN><br>                <br>                    strOwner = ""<br>                    strOwner = GetFileOwner(objFile.Path)<br>                <br>                    strMessage = ""<br>                    strMessage = strMessage & "FILE" & vbTab & objFile.name & vbTab & objFile.Size & vbTab & objFile.DateLastModified & vbTab & objFile.DateLastAccessed & vbTab & strOwner & vbTab & objFolder.Path & vbTab & RecursionLevel<br>                    Logfile strMessage<br>                    <br>                    lngCountLog = lngCountLog + 1<br>                    <br>                <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN>  <SPAN style="color:#007F00">'objFile.Size > minSize Then</SPAN><br>                <br>            <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN> <SPAN style="color:#007F00">' objFile.DateLastModified > minDateLastModified</SPAN><br>            <br>    <SPAN style="color:#00007F">Next</SPAN> objFile<br><br><br>    <SPAN style="color:#007F00">' Use these f you're reporting progress on a worksheet (requires named ranges as shown):</SPAN><br>    ThisWorkbook.Names("CurrentCount").RefersToRange.Value = ThisWorkbook.Names("CurrentCount").RefersToRange.Value + objFolder.Files.Count<br>    ThisWorkbook.Names("CurrentCountLogged").RefersToRange.Value = ThisWorkbook.Names("CurrentCountLogged").RefersToRange.Value + lngCountLog<br><br>    <SPAN style="color:#00007F">For</SPAN> <SPAN style="color:#00007F">Each</SPAN> objSubFolder <SPAN style="color:#00007F">In</SPAN> objFolder.SubFolders<br>    <br>        RecursionLevel = RecursionLevel + 1<br>        RecurseFolder objSubFolder.Path, RecursionLevel, minDateLastModified, minSize<br>        RecursionLevel = RecursionLevel - 1<br>        <br>    <SPAN style="color:#00007F">Next</SPAN> obj<SPAN style="color:#00007F">Sub</SPAN>Folder<br><br><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br><br><br><SPAN style="color:#00007F">Public</SPAN> <SPAN style="color:#00007F">Sub</SPAN> Logfile(strMessage)<br><br><SPAN style="color:#007F00">' Stream a message to a log file</SPAN><br><SPAN style="color:#007F00">' Opens the file if required.</SPAN><br><SPAN style="color:#007F00">' You are advised to close the file explicitly when your process has completed: use CloseLogFile for this</SPAN><br><br><SPAN style="color:#007F00">' REQUIRES module-level declarations:</SPAN><br><br><SPAN style="color:#007F00">'       objLogStream (Scripting.TextStream)</SPAN><br><SPAN style="color:#007F00">'       objFSO (Scripting.FileSystemObject)</SPAN><br><SPAN style="color:#007F00">'       LogfileName  (string)</SPAN><br><br><br><br><SPAN style="color:#00007F">Dim</SPAN> strHeader <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN><br><br><SPAN style="color:#00007F">If</SPAN> objLogStream <SPAN style="color:#00007F">Is</SPAN> <SPAN style="color:#00007F">Nothing</SPAN> <SPAN style="color:#00007F">Then</SPAN><br>    <SPAN style="color:#00007F">Set</SPAN> objLogStream = objFSO.OpenTextFile(LogfileName, ForWriting, <SPAN style="color:#00007F">True</SPAN>)<br>    strHeader = "Type" & vbTab & "Filename" & vbTab & "Size" & vbTab & "DateLastModified" & vbTab & "DateLastAccessed" & vbTab & "Owner" & vbTab & "ParentFolder" & vbTab & "PathDepth"<br>    objLogStream.WriteLine strHeader<br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br><br>objLogStream.WriteLine strMessage<br><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br><br><SPAN style="color:#00007F">Public</SPAN> <SPAN style="color:#00007F">Sub</SPAN> CloseLogFile()<br><br><SPAN style="color:#00007F">If</SPAN> objLogStream <SPAN style="color:#00007F">Is</SPAN> <SPAN style="color:#00007F">Nothing</SPAN> <SPAN style="color:#00007F">Then</SPAN><br>    <SPAN style="color:#00007F">Exit</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br><br>objLogStream.Close<br><SPAN style="color:#00007F">Set</SPAN> objLogStream = <SPAN style="color:#00007F">Nothing</SPAN><br><br><SPAN style="color:#00007F">End</SPAN> Sub<br><br></FONT><br /><br /></BLOCKQUOTE><br /><br /><P Align='justify'><br /><br /><br /><br /><P Align='justify'><br />Feel free to try out the code - and do, please, feel free to tell me how you got on. Oh, and watch out for line breaks imposed by Blogger's atomatic formatting.<br /></P>Nigel Heffernanhttp://www.blogger.com/profile/08954578765691578714noreply@blogger.com0