tag:blogger.com,1999:blog-72644798381178023462024-03-12T16:00:40.210-07:00baldy written codbaldmosher™http://www.blogger.com/profile/11281471751951639119noreply@blogger.comBlogger22125tag:blogger.com,1999:blog-7264479838117802346.post-28103185902481063282013-12-04T06:35:00.004-08:002014-01-16T05:49:36.586-08:00VBA Modules: Access: accUtils v2.00<a href="http://baldywritten.blogspot.com/2013/08/vba-modules-modzip-v502aaa.html" target="_blank">Read this</a> for full information on these modules<br />
<br />
Kudos to a number of different people who've found similar solutions...<br />
<br />
v1.00: <b>acU_RelinkTables</b><br />
Does a find & replace in linked tables<b>. </b><a href="http://www.access-programmers.co.uk/forums/showthread.php?p=1313193#post1313193" target="_blank">Cross-posted</a>. Not sure why it took me so long to find the answer to this problem,
but it did.... so after 5 years of manually updating linked tables I
finally got the answer.<br />
v1.01 improved messaging, case sensitivity bugfix<br />
<br />
v2.00: <b>acU_ChangeQueryPaths</b><br />
Does a find & replace in SQL in all queries.<br />
<br />
<br />
<blockquote class="tr_bq">
<span style="font-size: xx-small;"><span style="font-family: "Courier New",Courier,monospace;">'accUtils<br />'v2.00 2014-01-16 13:46<br /><br />'===========================================================================<br />' HELP CONTACT<br />'===========================================================================<br />' Code is provided without warranty and can be stolen and amended as required.<br />' Tom Parish<br />' TJP@tomparish.me.uk<br />' http://baldywrittencod.blogspot.com / www.baldmosher.com<br />' DGF Help Contact: see BPMHelpContact module<br />'=========================================================================<br /><br />'===========================================================================<br />' accUtils<br />'===========================================================================<br />' Various time-saving utilities for Access databases<br />'<br /><br />'===========================================================================<br />' Additional modules required:<br />'===========================================================================<br />' None<br />'<br /><br />'=========================================================================<br />' VERSION HISTORY<br />'=========================================================================<br />'v2.00 2014-01-16 13:46 - added acU_ChangeQueryPaths (does a find & replace in all queries)<br />'v1.02 2013-12-05 14:18 - acU_RelinkTables, added Debug.Print for missing tables<br />'v1.01 2013-12-04 15:06 - acU_RelinkTables, bugfix for case sensitivity, added t count, improved msgboxes<br />'v1.00 2013-12-04 14:31 - added acU_RelinkTables (does a find & replace in linked tables)<br /><br />Option Compare Database<br /><br />Public Sub acU_RelinkTables(ByVal OldBasePath As String, ByVal NewBasePath As String _<br /> , Optional ByVal AlsoChangeQueries As Boolean = True)<br />'v1.02 2013-12-05 14:18 - added Debug.Print for missing tables<br />'v1.01 2013-12-04 15:06 - bugfix for case sensitivity, added t count, improved msgboxes<br />'v1.00 2013-12-04 14:31 - original version<br />'pass old & new path to update all linked tables<br />'and it will go through all the tables in your database and link them to the new location<br />'Original source: Written by John Hawkins 20/9/99 www.fabalou.com<br />'via http://database.ittoolbox.com/groups/technical-functional/access-l/how-to-programme-the-linked-table-manager-using-vba-in-ms-access-5185870<br />'Syntax:<br />' acU_RelinkTables("\\OldShare\FolderName\", "\\NewShare\FolderName\)<br /><br />Dim Dbs As Database<br />Dim Tdf As TableDef<br />Dim Tdfs As TableDefs<br />Dim TdfCurrentPath As String<br />Dim t As Integer, u As Integer 'NB: practical limit of 65536 linked tables<br />Dim pp As String, tt As String 'for msgboxes<br /><br />Set Dbs = CurrentDb<br />Set Tdfs = Dbs.TableDefs<br /><br />Screen.MousePointer = 11 'shows as "working"<br />'Loop through the tables collection<br />For Each Tdf In Tdfs<br /> If Tdf.SourceTableName <> "" Then 'If the table source is other than a base table<br /> TdfCurrentPath = Tdf.Connect<br /> If InStr(UCase(TdfCurrentPath), UCase(OldBasePath)) > 0 Then 'If the current path needs to be changed<br /> t = t + 1 'count tables processed<br />On Error Resume Next<br /> Tdf.RefreshLink 'Refresh the link<br /> If Err = 3011 Then GoTo OriginalTdfError 'bypasses change if current linked table isn't found<br /> Tdf.Connect = Replace(TdfCurrentPath, OldBasePath, NewBasePath) 'Set the new source<br /> Tdf.RefreshLink 'Refresh the link<br /> If Err = 3011 Then GoTo EscapeOnError 'likely means error in new path - could be critical<br /> u = u + 1 'count tables updated<br />On Error GoTo 0<br /> End If<br /> End If<br />OriginalTdfError:<br />If Err = 3011 Then Debug.Print "Error 3011: " & Tdf.Name & vbLf & TdfCurrentPath<br />Next 'Goto next table<br /><br />pp = u & " tables have been relinked from " & OldBasePath & " to " & NewBasePath<br />If t > u Then pp = pp & vbLf & vbLf & "(" & t - u & " were not updated successfully because the original table was missing)"<br />tt = "Tables Relinked"<br /><br />Screen.MousePointer = 0<br />MsgBox pp, vbInformation, tt<br /><br />Exit Sub<br />EscapeOnError:<br />pp = "Possible major error: please ensure OldBasePath and NewBasePath are correct - you will now be returned to Debug"<br />tt = "WARNING"<br />MsgBox pp, vbExclamation, tt<br />On Error GoTo 0<br />Tdf.Connect = TdfCurrentPath 'return to original<br />Tdf.RefreshLink 'Refresh the link - errors here means the table was missing before... this needs to be resolved<br />'NB: to continue from where you left off, drag arrow up to Next<br />End Sub<br /><br />Public Sub acU_ChangeQueryPaths(ByVal OldBasePath As String, ByVal NewBasePath As String)<br />'v2.00 2014-01-16 13:46 - original version<br />'pass old & new path to update all queries<br />'Original source: acU_RelinkTables<br />'Syntax:<br />' acU_ChangeQueryPaths("\\OldShare\FolderName\", "\\NewShare\FolderName\)<br /><br />Dim Dbs As Database<br />Dim Qdf As QueryDef<br />Dim Qdfs As QueryDefs<br />Dim QdfOldSQL As String, QdfNewSQL As String<br />Dim q As Integer 'NB: practical limit of 65536 queries<br />Dim pp As String, tt As String 'for msgboxes<br /><br />If Right(OldBasePath, 1) = "\" And Right(NewBasePath, 1) = "\" Then<br /> pp = "This will Find & Replace in all queries. There is no validation for this. Use with caution. To Undo, simply re-run to correct the error." _<br /> & vbLf & vbLf & "find: " & OldBasePath & vbLf & "replace: " & NewBasePath<br /> tt = "WARNING"<br /> If MsgBox(pp, vbExclamation Or vbOKCancel, tt) = vbCancel Then Exit Sub<br />Else<br /> pp = "Your old and new paths must end with ""\"". Otherwise, errors may occur. Will now Exit." _<br /> & vbLf & vbLf & "find: " & OldBasePath & vbLf & "replace: " & NewBasePath<br /> tt = "CRITICAL WARNING"<br /> MsgBox pp, vbCritical, tt<br /> Exit Sub<br />End If<br /><br />Set Dbs = CurrentDb<br />Set Qdfs = Dbs.QueryDefs<br /><br />Screen.MousePointer = 11 'shows as "working"<br />For Each Qdf In Qdfs<br /> QdfOldSQL = Qdf.SQL<br /> QdfNewSQL = Replace(QdfOldSQL, OldBasePath, NewBasePath)<br /> If QdfOldSQL <> QdfNewSQL Then<br /> q = q + 1<br /> Qdf.SQL = QdfNewSQL<br /> End If<br />Next 'Goto next query<br /><br />pp = q & " queries have been updated from " & OldBasePath & " to " & NewBasePath<br />tt = "Queries Updated"<br /><br />Screen.MousePointer = 0<br />MsgBox pp, vbInformation, tt<br /><br />End Sub</span></span></blockquote>
baldmosher™http://www.blogger.com/profile/11281471751951639119noreply@blogger.com0Stretford M17 1QA, UK53.4609149 -2.318959400000039827.9388804 -43.627553400000039 78.9829494 38.98963459999996tag:blogger.com,1999:blog-7264479838117802346.post-5874185440711812082013-11-29T04:00:00.004-08:002013-11-29T05:06:08.805-08:00VBA Modules: Access: accPostCodes v1.03<a href="http://baldywritten.blogspot.com/2013/08/vba-modules-modzip-v502aaa.html" target="_blank">Read this</a> for full information on these modules<br />
<br />
<br />
I wrote this module to help me out processing and extracting GB post codes, which can have a number of combinations:<br />
<br />
A1 2BC<br />
A12 3BC<br />
AB1 2CD <br />
AB12 3CD<br />
AB1C 2DE<br />
<br />
<b>accPostCodeExtract </b>is probably the most useful function here, as it will extract the post code from the end of a long address string. There are options to work with most source string formats. By default, the result will be padded with spaces to length = 8, e.g. "AB1 2CD"<br />
<br />
<b>accPostCodePrefix </b>extracts the post code "town", e.g. "AB" from "AB1 2CD"<br />
<b>accPostCodePrefixWithNumber </b>extracts the full post code prefix, e.g. "AB1" from "AB1 2CD"<br />
<br />
<br />
<blockquote class="tr_bq">
<span style="font-size: xx-small;"><span style="font-family: "Courier New",Courier,monospace;">'accPostCodes<br />'v1.03 2013-11-29 13:03<br /><br />'===========================================================================<br />' HELP CONTACT<br />'===========================================================================<br />' Code is provided without warranty and can be stolen and amended as required.<br />' Tom Parish<br />' TJP@tomparish.me.uk<br />' http://baldywrittencod.blogspot.com/2013/11/vba-modules-access-accpostcodes.html<br />' DGF Help Contact: see BPMHelpContact module<br />'=========================================================================<br /><br />' v1.03 accPostCodeExtract: bugfix where original post code already padded to len=8<br />' v1.02 accPostCodeExtract: added bPadResult option, bugfix where string is just post code<br />' v1.01 added accPostCodeExtract<br />' v1.00 original version<br /><br />Option Explicit<br />Option Compare Database<br /><br />Function accPostCode(ByRef PCode, Optional ByVal FWSrcSys) As String<br />'v1.00 2013-11-29 11:53<br /><br />Dim sPCode As String, sFWsys As String<br />On Error Resume Next<br />sPCode = PCode<br />sFWsys = FWSrcSys<br />On Error GoTo 0<br /><br />If sFWsys = "LO" Then Exit Function<br /><br />'extract "GB/" from start of NFE PCode<br />Dim b As Byte<br />b = InStr(sPCode, "/")<br />sPCode = Mid(sPCode, b + 1, Len(sPCode))<br /><br />If sPCode = "" Or sPCode = "0" Or sPCode = "." Or sPCode = "#" Then Exit Function<br /><br />accPostCode = sPCode<br /><br />End Function<br /><br />Function accPostCodePrefix(ByRef PCode, Optional ByVal FWSrcSys) As String<br />'v1.00 2013-11-29 11:53<br />'checks first 1-2 characters for alpha prefix<br /><br />Dim sPCode As String, sFWsys As String<br />On Error Resume Next<br />sPCode = PCode<br />sFWsys = FWSrcSys<br />On Error GoTo 0<br /><br />If sFWsys = "LO" Then Exit Function<br /><br />Dim s As String<br />sPCode = accPostCode(sPCode)<br />If sPCode = "" Then Exit Function<br />s = Left(sPCode, 1)<br />If IsNumeric(s) Then Exit Function Else accPostCodePrefix = s<br />s = Mid(sPCode, 2, 1)<br />If IsNumeric(s) Then Exit Function Else accPostCodePrefix = accPostCodePrefix & s<br /><br />End Function<br /><br />Function accPostCodePrefixWithNumber(ByVal PCode, Optional ByVal FWSrcSys) As String<br />'v1.00 2013-11-29 11:53<br />'checks first 2 characters for alpha prefix then checks following 2-3 chars for numeric<br /><br />Dim sPCode As String, sFWsys As String<br />On Error Resume Next<br />sPCode = PCode<br />sFWsys = FWSrcSys<br />On Error GoTo 0<br /><br />If sFWsys = "LO" Then Exit Function<br /><br />Dim b As Byte, APfx As String, ANPfx As String<br />APfx = accPostCodePrefix(sPCode)<br />If APfx = "" Then Exit Function<br />b = InStr(sPCode, " ")<br />If b > 0 Then<br />'just use characters before space<br /> ANPfx = Left(sPCode, b - 1)<br />Else<br />'no space, deduce logically<br />'e.g. for AB123CD need AB12, take APfx plus all except last following numeric character<br /> ANPfx = APfx & Mid(sPCode, Len(APfx) + 1, 3)<br /> 'e.g. AB123 or AB12C or AB1C2<br /> If ANPfx = sPCode Then<br /> 'e.g. AB12[] so only prefix anyway<br /> ElseIf IsNumeric(Mid(ANPfx, Len(ANPfx), 1)) Then<br /> 'e.g. AB123[CD] so AB12 3CD<br /> ANPfx = Left(ANPfx, Len(ANPfx) - 1)<br /> ElseIf IsNumeric(Mid(ANPfx, Len(ANPfx) - 1, 1)) Then<br /> 'e.g. AB12C[D] so AB1 2CD<br /> ANPfx = Left(ANPfx, Len(ANPfx) - 2)<br /> ElseIf IsNumeric(Mid(ANPfx, 3, 1)) And Not IsNumeric(Mid(ANPfx, 4, 1)) Then<br /> 'e.g. AB1C2[DE] so AB1C 2DE<br /> ANPfx = Left(ANPfx, Len(ANPfx) - 1)<br /> Else<br /> 'cannot identify<br /> ANPfx = ""<br /> End If<br />End If<br /><br />accPostCodePrefixWithNumber = ANPfx<br /><br />End Function<br /><br />Function accPostCodeExtract(ByVal FullAddressString, Optional ByVal bPostCodeNoSpace As Boolean = False _<br /> , Optional ByVal bCommaSeparated As Boolean = False, Optional bPadResult As Boolean = True) As String<br />'v1.03 2013-11-29 13:03<br />'extracts the post code from the end of a long address string (after the last-but-one space [or comma])<br />'e.g. "CITY, County, AB12 3CD" becomes "AB12 3CD"<br />'NB: with "AB123CD" post code formats, use bPostCodeNoSpace = True<br />'NB: with "City,County,AB12 3CD" format strings, use bCommaSeparated = True<br />'NB: to pad result to fixed 8 characters, use bPadResult = True<br /><br />On Error Resume Next<br /><br />Dim FullString As String<br />FullString = FullAddressString<br />If FullString = "" Then Exit Function<br /><br />Dim sSearchString As String, sCount As Byte<br />If bCommaSeparated Then<br /> sSearchString = ","<br /> sCount = 1<br />Else<br /> sSearchString = " "<br /> If bPostCodeNoSpace Then sCount = 1 Else sCount = 2<br /> While InStr(FullString, " ") > 0<br /> FullString = Replace(FullString, " ", " ")<br /> Wend<br />End If<br /><br />Dim findspaces() As Integer, f As Integer, fCount As Byte<br />fCount = 1<br />While InStr(f + 1, FullString, sSearchString) > 0<br />ReDim Preserve findspaces(1 To fCount) As Integer<br />f = InStr(f + 1, FullString, sSearchString)<br />findspaces(fCount) = f<br />fCount = fCount + 1<br />Wend<br />accPostCodeExtract = Mid(FullString, findspaces(fCount - sCount) + 1, Len(FullString))<br />If accPostCodeExtract = "" Then accPostCodeExtract = FullString<br />If bPostCodeNoSpace Then accPostCodeExtract = Left(accPostCodeExtract, Len(accPostCodeExtract) - 3) & " " & Right(accPostCodeExtract, 3)<br />If bPadResult Then<br /> While Len(accPostCodeExtract) < 8<br /> accPostCodeExtract = Left(accPostCodeExtract, Len(accPostCodeExtract) - 3) & " " & Right(accPostCodeExtract, 3)<br /> Wend<br />End If<br /><br />End Function</span></span><span style="font-size: xx-small;"><span style="font-family: "Courier New",Courier,monospace;"></span></span></blockquote>
baldmosher™http://www.blogger.com/profile/11281471751951639119noreply@blogger.com0Stretford M17 1QA, UK53.4609149 -2.318959400000039827.9388804 -43.627553400000039 78.9829494 38.98963459999996tag:blogger.com,1999:blog-7264479838117802346.post-70938805055468637662013-10-08T08:08:00.000-07:002013-12-03T02:52:14.832-08:00VBA Modules: Access: accCompactRepair v2.03<a href="http://baldywritten.blogspot.com/2013/08/vba-modules-modzip-v502aaa.html" target="_blank">Read this</a> for full information on these modules<br />
<br />
This nifty little module performs a compact & repair on an Access database, or for all Access databases under a specified path.<b> </b><br />
<br />
<b>accSweepForDatabases </b>runs <b>acCompactRepair </b>on all *.accdb and *.mdb files within [and beneath] the specified folder. (NB: you'll need to comment out the line for .accdb if you only have Access 2003 installed because it won't open those files.)<br />
<br />
Syntax to auto-compact all databases under a path:<br />
<br />
Access 2007/2010:<br />
<pre class="lang-sql prettyprint prettyprinted"><code></code></pre>
<pre class="lang-sql prettyprint prettyprinted"><code><span class="pln">accSweepForDatabases </span><span class="str">"C:\Folder\"</span><span class="pun">,</span><span class="pln"> True, False, False</span></code></pre>
<br />
Access 2003:<b><br /></b><br />
<pre class="lang-sql prettyprint prettyprinted"><code></code></pre>
<pre class="lang-sql prettyprint prettyprinted"><code><span class="pln"><code><span class="pln">accSweepForDatabases</span></code> </span><span class="str">"C:\Folder\"</span><span class="pun">,</span><span class="pln"> True, False, True</span></code></pre>
<br />
<br />
<b>acCompactRepair </b>launches Access, opens
the database, sets the "Compact on Close" option to "True", then quits.<br /><br />
Syntax to auto-compact:<br />
<pre class="lang-sql prettyprint prettyprinted"><code><span class="pln">acCompactRepair </span><span class="str">"C:\Folder\Database.accdb"</span><span class="pun">,</span><span class="pln"> True</span></code></pre>
<br />
I tend to use it after running a Delete query or removing a single table object from a database.<br />
<br />
Syntax to return to default* afterwards:<br />
<pre class="lang-sql prettyprint prettyprinted"><code></code></pre>
<pre class="lang-sql prettyprint prettyprinted"><code><span class="pln">acCompactRepair </span><span class="str">"C:\Folder\Database.accdb"</span><span class="pun">,</span><span class="pln"> False</span></code></pre>
<br />
*not necessary, but if your back end database is >1GB this can be
rather annoying when you go into it directly and it then takes >2 minutes to
quit.<br />
<br />
<blockquote class="tr_bq">
<span style="font-size: xx-small;"><span style="font-family: "Courier New",Courier,monospace;">'accCompactRepair<br />'v2.03 2013-11-28 17:43<br /><br />'===========================================================================<br />' HELP CONTACT<br />'===========================================================================<br />' Code is provided without warranty and can be stolen and amended as required.<br />' Tom Parish<br />' TJP@tomparish.me.uk<br />' http://baldywrittencod.blogspot.com/2013/10/vba-modules-access-compact-repair.html<br />' DGF Help Contact: see BPMHelpContact module<br />'=========================================================================<br /><br />'includes code from<br />'http://www.ammara.com/access_image_faq/recursive_folder_search.html<br />'tweaked slightly for improved error handling<br /><br />' v2.03 added option for Access 2003 users<br />' improved code annotation<br />' v2.02 bugfix preventing Compact when bAutoCompact set to False<br />' bugfix with "OLE waiting for another application" msgbox<br />' added "MB" to start & end sizes of message box at end<br />' v2.01 added size reduction to message box<br />' v2.00 added recurse<br />' v1.00 original version<br /><br />Option Explicit<br /><br />Function accSweepForDatabases(ByVal strFolder As String, Optional ByVal bIncludeSubfolders As Boolean = True _<br /> , Optional bAutoCompact As Boolean = False, Optional bOnlyAccess2003 As Boolean) As String<br />'v2.03 2013-11-28 17:43<br />'sweeps path for .accdb and .mdb files, compacts and repairs all that it finds<br />'NB: leaves AutoCompact on Close as False unless specified, then leaves as True<br /><br />'syntax:<br />' accSweepForDatabases "path", [False], [True]<br /><br />'code for ActiveX CommandButton on sheet module named "admin" with two named ranges "vPath" and "vRecurse":<br />' accSweepForDatabases admin.Range("vPath"), admin.Range("vRecurse") [, admin.Range("vLeaveAutoCompact")]<br /><br />Application.DisplayAlerts = False<br /><br />Dim colFiles As New Collection, vFile As Variant, i As Integer, j As Integer, sFails As String, t As Single<br />Dim SizeBefore As Long, SizeAfter As Long<br />t = Timer<br /><br />'scan path for any .mdb and .accdb files<br /> If bOnlyAccess2003 = False Then RecursiveDir colFiles, strFolder, "*.accdb", True<br /> RecursiveDir colFiles, strFolder, "*.mdb", True<br /><br />'now compact & repair the list of databases<br /> For Each vFile In colFiles<br /> 'Debug.Print vFile<br /> SizeBefore = SizeBefore + (FileLen(vFile) / 1048576)<br />On Error GoTo CompactFailed<br /> If InStr(vFile, "Geographical Configuration.accdb") > 0 Then MsgBox "yes"<br /> acCompactRepair vFile, bAutoCompact<br /> i = i + 1 'counts successes<br /> GoTo NextCompact<br />CompactFailed:<br />On Error GoTo 0<br /> j = j + 1 'counts failures<br /> sFails = sFails & vFile & vbLf 'records failure<br />NextCompact:<br />On Error GoTo 0<br /> SizeAfter = SizeAfter + (FileLen(vFile) / 1048576)<br /><br /> Next vFile<br /><br />Application.DisplayAlerts = True<br /><br />'display message box, mark end of process<br /> accSweepForDatabases = i & " databases compacted successfully, taking " & CInt(Timer - t) & " seconds, and reducing storage overheads by " & Int(SizeBefore - SizeAfter) & "MB" & vbLf & vbLf & "Size Before: " & Int(SizeBefore) & "MB" & vbLf & "Size After: " & Int(SizeAfter) & "MB"<br /> If j > 0 Then accSweepForDatabases = accSweepForDatabases & vbLf & j & " failures:" & vbLf & vbLf & sFails<br /> MsgBox accSweepForDatabases, vbInformation, "accSweepForDatabases"<br /><br />End Function<br /><br />Function acCompactRepair(ByVal pthfn As String, Optional doEnable As Boolean = True) As Boolean<br />'v2.02 2013-11-28 16:22<br />'if doEnable = True will compact and repair pthfn<br />'if doEnable = False will then disable auto compact on pthfn<br /><br />On Error GoTo CompactFailed<br /><br />Dim A As Object<br />Set A = CreateObject("Access.Application")<br />With A<br /> .OpenCurrentDatabase pthfn<br /> .SetOption "Auto compact", True<br /> .CloseCurrentDatabase<br /> If doEnable = False Then<br /> .OpenCurrentDatabase pthfn<br /> .SetOption "Auto compact", doEnable<br /> End If<br /> .Quit<br />End With<br />Set A = Nothing<br />acCompactRepair = True<br />Exit Function<br />CompactFailed:<br />End Function<br /><br /><br />'source: http://www.ammara.com/access_image_faq/recursive_folder_search.html<br />'tweaked slightly for error handling<br /><br />Private Function RecursiveDir(colFiles As Collection, _<br /> strFolder As String, _<br /> strFileSpec As String, _<br /> bIncludeSubfolders As Boolean)<br /><br /> Dim strTemp As String<br /> Dim colFolders As New Collection<br /> Dim vFolderName As Variant<br /><br /> 'Add files in strFolder matching strFileSpec to colFiles<br /> strFolder = TrailingSlash(strFolder)<br />On Error Resume Next<br /> strTemp = ""<br /> strTemp = Dir(strFolder & strFileSpec)<br />On Error GoTo 0<br /> Do While strTemp <> vbNullString<br /> colFiles.Add strFolder & strTemp<br /> strTemp = Dir<br /> Loop<br /><br /> If bIncludeSubfolders Then<br /> 'Fill colFolders with list of subdirectories of strFolder<br />On Error Resume Next<br /> strTemp = ""<br /> strTemp = Dir(strFolder, vbDirectory)<br />On Error GoTo 0<br /> Do While strTemp <> vbNullString<br /> If (strTemp <> ".") And (strTemp <> "..") Then<br /> If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then<br /> colFolders.Add strTemp<br /> End If<br /> End If<br /> strTemp = Dir<br /> Loop<br /><br /> 'Call RecursiveDir for each subfolder in colFolders<br /> For Each vFolderName In colFolders<br /> Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)<br /> Next vFolderName<br /> End If<br /><br />End Function<br /><br />Private Function TrailingSlash(strFolder As String) As String<br /> If Len(strFolder) > 0 Then<br /> If Right(strFolder, 1) = "\" Then<br /> TrailingSlash = strFolder<br /> Else<br /> TrailingSlash = strFolder & "\"<br /> End If<br /> End If<br />End Function</span></span></blockquote>
baldmosher™http://www.blogger.com/profile/11281471751951639119noreply@blogger.com0tag:blogger.com,1999:blog-7264479838117802346.post-66562472389769939162013-09-02T03:24:00.000-07:002013-12-02T09:54:23.082-08:00VBA Modules: Outlook/Access/Excel: modProcedures v2.14<a href="http://baldywritten.blogspot.com/2013/08/vba-modules-modzip-v502aaa.html" target="_blank">Read this</a> for full information on these modules<br />
<br />
One major down side of the <b>OL_BPMProcess </b>and <b>modAppsFirefox </b>routines was that they locked up the Outlook session while they're running. This module came about because I was fed up of losing Outlook for an entire Monday while it was busy waiting to download huge CSV files, particularly as the routines would invariably get stuck somewhere random and unexpected and I'd have to set them going again on Monday morning. Storing the URL and other variables from the email triggers allows me to move on, and pick up those routines where they left off, much later on, when it's more convenient for me.<br />
<br />
A few tweaks to the other modules have allowed me to <u>force</u> all downloads to complete during weekends and evenings (my routines usually run on Sundays), but to <u>never</u> wait for too long during business hours (in case something got stuck and I have to fix an issue on Monday). Manually running the procedures doesn't invoke the same protections, so I can still consciously forego Outlook during the day if I want to run these saved procedures, or I can just wait until I leave the office at night or go on lunch.<br />
<br />
Firefox (for me) will only download a maximum of 6 simultaneous streams so there are protections built into <b>modFirefox </b>for that too. Rather than start downloading the file, store the Excel or Access procedure and pick those up later when the file has downloaded, it just stores the Download procedure for triggering later on.<br />
<br />
When the procedure is running it updates the worksheet to "In Progress" then to "OK" when completed. (You can choose to rerun Failed procedures, but it's not really recommended, owing to the way the routines are stored and will run -- if it fails once it'll usually fail again. I usually delete all the procedures from the file once a week just for good housekeeping.)<br />
<br />
This module should be added to an Excel workbook with sheets named <b>Excel</b>, <b>Access</b>, and <b>Download</b> with the appropriate column headings in place:<br />
<br />
<b>Excel: </b><br />
<table border="0" cellpadding="0" cellspacing="0" style="width: 925px;"><colgroup><col span="2" width="111"></col><col span="4" width="132"></col><col width="64"></col><col width="111"></col></colgroup><tbody>
<tr height="20">
<td class="xl65" height="20" style="height: 15.0pt; width: 83pt;" width="111">mpTimestamp</td>
<td class="xl65" style="width: 83pt;" width="111">mpURL</td>
<td class="xl63" style="width: 99pt;" width="132">mpDownloadingFile</td>
<td class="xl63" style="width: 99pt;" width="132">mpMoveToFile</td>
<td class="xl63" style="width: 99pt;" width="132">mpPathFile</td>
<td class="xl63" style="width: 99pt;" width="132">mpMacro</td>
<td class="xl63" style="width: 48pt;" width="64">rResult</td>
<td class="xl65" style="width: 83pt;" width="111">rTimestamp</td>
</tr>
</tbody></table>
<b>Access:</b><br />
<table border="0" cellpadding="0" cellspacing="0" style="width: 925px;"><colgroup><col span="2" width="111"></col><col span="4" width="132"></col><col width="64"></col><col width="111"></col></colgroup><tbody>
<tr height="20">
<td class="xl67" height="20" style="height: 15.0pt; width: 83pt;" width="111">mpTimestamp</td>
<td class="xl67" style="width: 83pt;" width="111">mpURL</td>
<td class="xl65" style="width: 99pt;" width="132">mpDownloadingFile</td>
<td class="xl65" style="width: 99pt;" width="132">mpMoveToFile</td>
<td class="xl65" style="width: 99pt;" width="132">mpPathFile</td>
<td class="xl65" style="width: 99pt;" width="132">mpMacro</td>
<td class="xl65" style="width: 48pt;" width="64">rResult</td>
<td class="xl67" style="width: 83pt;" width="111">rTimestamp</td>
</tr>
</tbody></table>
<b>Download:</b><br />
<table border="0" cellpadding="0" cellspacing="0" style="width: 845px;"><colgroup><col span="2" width="111"></col><col width="52"></col><col span="3" width="132"></col><col width="64"></col><col width="111"></col></colgroup><tbody>
<tr height="20">
<td class="xl67" height="20" style="height: 15.0pt; width: 83pt;" width="111">mpTimestamp</td>
<td class="xl67" style="width: 83pt;" width="111">mpURL</td>
<td class="xl68" style="width: 39pt;" width="52">mpApp</td>
<td class="xl65" style="width: 99pt;" width="132">mpMoveToFile</td>
<td class="xl65" style="width: 99pt;" width="132">mpPathFile</td>
<td class="xl65" style="width: 99pt;" width="132">mpMacro</td>
<td class="xl65" style="width: 48pt;" width="64">rResult</td>
<td class="xl67" style="width: 83pt;" width="111">rTimestamp</td>
</tr>
</tbody></table>
<br />
<blockquote class="tr_bq">
<span style="font-size: xx-small;"><span style="font-family: "Courier New",Courier,monospace;">'modProcedures<br />'v2.14 2013-12-02 13:05<br /><br />'===========================================================================<br />' HELP CONTACT<br />'===========================================================================<br />' Code is provided without warranty and can be stolen and amended as required.<br />' Tom Parish<br />' TJP@tomparish.me.uk<br />' http://baldywrittencod.blogspot.com<br />' DGF Help Contact: see BPMHelpContact module<br />'=========================================================================<br /><br />'===========================================================================<br />' modProcedures<br />'===========================================================================<br />' mp_Procedure_Store: stores list of procedures to be run later, prevents<br />' indefinite hangs when downloading large files from Outlook.<br />'<br />' mp_Run_Procedures: runs stored list of procedures sequentially (or just one)<br /><br />'===========================================================================<br />' Additional modules required:<br />'===========================================================================<br />' modAppsOffice<br />'<br />' [automation requires modAppsFireFox v3.00 and OL_BPMprocess v6.00, but not used here]<br /><br />'===========================================================================<br />' Additional References required:<br />'===========================================================================<br />' Microsoft Excel Object Library<br /><br />'===========================================================================<br />' External applications required:<br />'===========================================================================<br />' Microsoft Outlook (for automation)<br />' Microsoft Access (for Access functions)<br />' Microsoft Excel (for Excel functions)<br /><br />'=========================================================================<br />' VERSION HISTORY<br />'=========================================================================<br />' v2.14 mpDefaultStoreWorkbook changed to C:\SHARES\ as more robust than UNC<br />' v2.13 mp_Run_Procedures: recalcs after each item is run<br />' v2.12 mp_Run_Procedures: bugfix, resets mpApp on Downloads sheet<br />' v2.11 mp_Run_Procedures: bugfix, doesn't run Excel/Access if nothing to do<br />' v2.10 mpXLapp, prevents conflict with modAppsOffice<br />' v2.09 mp_Run_Procedures: bugfix prevents WB.Open Read-Only<br />' v2.08 mp_Procedure_Store: bugfix prevents WB.Open Read-Only<br />' v2.07 mp_Procedure_Store: bugfix prevents looping for Download proc<br />' v2.06 mp_Procedure: bugfixes<br />' v2.05 mp_Procedure_Store: bugfix for Downloads store<br />' v2.04 mp_Run_Procedures: will Download then run relevant App procedure<br />' v2.03 mp_Procedure: bugfix if mpDownloadedFile not found<br />' v2.02 mp_Procedure_Store: bugfix<br />' v2.01 mp_Procedure_Store: bugfix<br />' v2.00 mp_Procedure_Store now stores URL and allows queued Downloads<br />' v1.01 errorhandlers, bugfix in mp_run_Procedures<br />' v1.00 mp_Procedure_Store, mp_Run_Procedures, mp_Procedure<br /><br />Option Explicit<br /><br />Private mpXLapp As Excel.Application '2.10 bugfix prevents issues with modAppsOffice XLapp<br /><br />Private Const mpDefaultStoreWorkbook As String = "C:\SHARES\VS\ProcStore.xlsb" 'v2.13<br />'can specify a different WB when storing procedures<br /><br />Public Enum mpApps<br />'v2.00 2013-08-27 13:05<br />'sheet number matched to each application type<br /> mpExcel = 1<br /> mpAccess = 2<br /> mpDownload = 3 'v2.00<br />End Enum<br /><br />Function mp_Procedure_Store(ByVal mpURL As String, ByVal mpDownloadingFile As String, ByVal mpMoveToFile As String _<br /> , ByVal mpApp As mpApps, ByRef mpPathFile As String, Optional ByVal mpMacro As String _<br /> , Optional ByVal mpProceduresWorkbook As String = mpDefaultStoreWorkbook) As Boolean<br />'v2.08 2013-09-16 13:05<br />'runs Excel, opens mpProceduresWorkbook, records downloading filename and procedure details for later<br /><br />'SYNTAX<br />' Store Excel procedure:<br />' mp_Procedure_Store "http://url.com", "C:\Users\bpmgb\Downloads\downloadingfile.xls", "C:\Users\bpmgb\Downloads\Downloaded File.xls", mpExcel, "C:\Users\bpmgb\Downloads\", "runtest.xlsm", ""<br />' Store Access procedure:<br />' mp_Procedure_Store "http://url.com", "C:\Users\bpmgb\Downloads\downloadingfile.xls", "C:\Users\bpmgb\Downloads\Downloaded File.csv", mpAccess, "C:\Users\bpmgb\Downloads\", "runtest.accdb", "runtest"<br />' Store Download procedure: mpDownloadingFile = "" qualifies<br />' mp_Procedure_Store "http://url.com", "", "C:\Users\bpmgb\Downloads\Downloaded File.xls", mpExcel, "C:\Users\bpmgb\Downloads\", "runtest.xlsm", ""<br /><br />mp_Procedure_Store = True<br /><br />Dim WB As Excel.Workbook, pwSheet As Excel.Worksheet, pwRow As Excel.Range<br />Dim rTimestamp As Excel.Range, rDownloadingFile As Excel.Range, rMoveToFile As Excel.Range _<br /> , rPathFile As Excel.Range, rMacro As Excel.Range, rDLfiles As Excel.Range _<br /> , rURL As Excel.Range, rApp As Excel.Range, a As Byte<br /><br />'run Excel (or use this Excel session for testing)<br />Dim mpNative As Boolean<br />On Error Resume Next<br />If UCase(ThisWorkbook.FullName) <> UCase(mpProceduresWorkbook) Then 'v2.08 stops looping<br /> Set mpXLapp = XLlaunch(True, False)<br />Else<br /> Set mpXLapp = Application<br />End If<br />On Error GoTo 0<br /><br />With mpXLapp<br /> .DisplayAlerts = False<br /><br />'open WB (if not open), store details for processing later<br /> If mpXLapp <> Application Then<br /> Set WB = .Workbooks.Open(mpProceduresWorkbook)<br /> Else<br /> If UCase(ThisWorkbook.FullName) = UCase(mpProceduresWorkbook) _<br /> Then Set WB = ThisWorkbook _<br /> Else: Set WB = .Workbooks.Open(mpProceduresWorkbook)<br /> End If<br /> <br /> With WB<br /> If mpApp <> mpDownload And mpDownloadingFile <> "" Then 'v2.07 bugfix, doesn't loop<br /> 'check this file is not already being downloaded on Excel and Access sheets<br /> For a = mpApps.mpExcel To mpApps.mpAccess<br /> Set pwSheet = .Sheets(a)<br /> With pwSheet<br /> Set rDLfiles = .Columns(mpXLapp.Match("mpDownloadingFile", .Rows(1), 0)) 'v2.01<br /> If mpXLapp.CountIf(rDLfiles, mpDownloadingFile) > 0 Then<br /> 'error: this mpDownloadingFile file is already being used for another procedure?<br /> 'store this procedure to try downloading it again later from source URL<br /> mp_Procedure_Store mpURL, "", mpMoveToFile, mpApp, mpPathFile, mpMacro, mpProceduresWorkbook<br /> GoTo CleanUp<br /> End If<br /> End With<br /> Next a<br /> End If<br /> 'this is a new file being downloaded / to be downloaded<br /> If mpDownloadingFile = "" Then Set pwSheet = .Sheets(3) Else Set pwSheet = .Sheets(mpApp) 'v2.05<br /> With pwSheet<br /> Set pwRow = .Rows(mpXLapp.CountA(.Columns(1)) + 1)<br /> Set rTimestamp = pwRow.Columns(mpXLapp.Match("mpTimestamp", .Rows(1), 0))<br /> rTimestamp.Value = Now()<br /> Set rURL = pwRow.Columns(mpXLapp.Match("mpURL", .Rows(1), 0))<br /> rURL.Value = mpURL<br /> If mpDownloadingFile = "" Then 'v2.05 'store app, only for Download sheet<br /> Set rApp = pwRow.Columns(mpXLapp.Match("mpApp", .Rows(1), 0))<br /> rApp.Value = mpApp<br /> Else 'store downloading file name, not for Download sheet<br /> Set rDownloadingFile = pwRow.Columns(mpXLapp.Match("mpDownloadingFile", .Rows(1), 0))<br /> rDownloadingFile.Value = mpDownloadingFile<br /> End If<br /> Set rMoveToFile = pwRow.Columns(mpXLapp.Match("mpMoveToFile", .Rows(1), 0))<br /> rMoveToFile.Value = mpMoveToFile<br /> Set rPathFile = pwRow.Columns(mpXLapp.Match("mpPathFile", .Rows(1), 0))<br /> rPathFile.Value = mpPathFile<br /> Set rMacro = pwRow.Columns(mpXLapp.Match("mpMacro", .Rows(1), 0))<br /> rMacro.Value = mpMacro<br /> End With<br />CleanUp:<br />On Error Resume Next<br /> If mpNative = False Then .Close SaveChanges:=True Else .Save<br /> Set pwSheet = Nothing<br /> Set WB = Nothing<br /> End With<br /> If mpNative = False Then .Quit<br /> Set mpXLapp = Nothing<br />End With<br /><br />End Function<br /><br />Sub mp_Run_Procedures(ByRef mpApp As mpApps, ByVal bRerun As Boolean _<br /> , Optional ByVal mpProceduresWorkbook As String = mpDefaultStoreWorkbook)<br />'v2.13 2013-11-26 16:00<br />'runs all Procedures that have not yet been completed OK<br />'[and reruns all failed Procedures if bRerun = True]<br />'SYNTAX: mp_Run_Procedures mpExcel, False<br /><br />Dim WB As Excel.Workbook, pwSheet As Excel.Worksheet, pwRow As Excel.Range, pwRows() As Long<br />Dim rURL As Range, rApp As Range, rDownloadingFile As Excel.Range, rMoveToFile As Excel.Range _<br /> , rPathFile As Excel.Range, rMacro As Excel.Range _<br /> , rResult As Excel.Range, rTimestamp As Excel.Range, rTimestamps As Excel.Range<br />Dim mpDownloadingFile As String, mpMoveToFile As String _<br /> , mpPathFile As String, mpMacro As String, mpFileExt As String, mpFileName As String, r As Long<br />Dim b As Integer, c As Integer, d As Integer<br /><br />Const rOK As String = "OK"<br />Const rFail As String = "Fail"<br />Const rIP As String = "In Progress"<br /><br />'run Excel (use this WB preferably) 'v2.09<br />Dim mpNative As Boolean<br />If UCase(ThisWorkbook.FullName) = UCase(mpProceduresWorkbook) Then<br />'NB: differences in path e.g. UNC vs Local will cause to open again Read-Only<br /> Set mpXLapp = Application<br /> mpNative = True<br />Else<br /> Set mpXLapp = XLlaunch(True, False)<br />End If<br /><br />With mpXLapp<br /> .DisplayAlerts = False<br /><br />'open WB, store details for processing later<br /> If mpNative = True Then 'v2.09<br /> Set WB = ThisWorkbook<br /> Else<br /> Set WB = .Workbooks.Open(mpProceduresWorkbook)<br /> End If<br /> <br /> With WB<br /> Set pwSheet = .Sheets(mpApp)<br /> With pwSheet<br /> Set rTimestamps = .Cells(1, 1)<br /> Set rTimestamps = .Range(rTimestamps, rTimestamps.End(xlDown))<br /> r = rTimestamps.Cells.Count 'total rows (timestamps) in table incl. header<br /> Set rTimestamps = .Columns(mpXLapp.Match("rTimestamp", .Rows(1), 0)) 'in/complete rows<br /> Set rResult = .Columns(mpXLapp.Match("rResult", .Rows(1), 0)) 'result (allows rerun)<br /> Set rURL = .Columns(mpXLapp.Match("mpURL", .Rows(1), 0)) 'v2.04 URL for download or in case need to download again<br /> If mpApp = mpApps.mpDownload Then 'v2.04<br /> Set rApp = .Columns(mpXLapp.Match("mpApp", .Rows(1), 0))<br /> Set rDownloadingFile = .Columns(mpXLapp.Match("mpMoveToFile", .Rows(1), 0)) 'v2.12 bugfix in Downloads process<br /> Else<br /> Set rDownloadingFile = .Columns(mpXLapp.Match("mpDownloadingFile", .Rows(1), 0))<br /> End If<br /> Set rMoveToFile = .Columns(mpXLapp.Match("mpMoveToFile", .Rows(1), 0))<br /> Set rPathFile = .Columns(mpXLapp.Match("mpPathFile", .Rows(1), 0))<br /> Set rMacro = .Columns(mpXLapp.Match("mpMacro", .Rows(1), 0))<br /> For r = 2 To r 'all reports, ignore header row<br /> If rTimestamps.Cells(r) = "" Then<br /> If (bRerun = True And rResult.Cells(r) <> "OK") Or rResult.Cells(r) <> "Fail" Then 'v2.04<br /> 'run this procedure<br /> mpMoveToFile = rMoveToFile.Cells(r).Value<br /> b = InStr(mpMoveToFile, ".")<br /> Do While b > 0<br /> c = b<br /> b = InStr(c + 1, mpMoveToFile, ".")<br /> Loop<br /> If c > 0 Then mpFileExt = Mid(mpMoveToFile, c, 8)<br /> b = InStr(mpMoveToFile, "\")<br /> Do While b > 0<br /> d = b<br /> b = InStr(d + 1, mpMoveToFile, "\")<br /> Loop<br /> If d > 0 Then mpFileName = Mid(mpMoveToFile, d + 1, Len(mpMoveToFile) - d)<br /> mpPathFile = rPathFile.Cells(r).Value<br /> mpMacro = rMacro.Cells(r).Value<br /> rResult.Cells(r).Value = "In Progress"<br /> If mpApp = mpApps.mpDownload Then<br /> 'Downloads: mp_Procedure will use URL to download file, then run procedure in relevant App<br /> mpApp = rApp.Cells(r).Value<br /> mpDownloadingFile = rURL.Cells(r).Value 'starts with "http://" or "https://"<br /> Else<br /> 'Apps: mp_Procedure will check if downloading file is finished yet, then run procedure in relevant App<br /> mpDownloadingFile = rDownloadingFile.Cells(r).Value<br /> End If<br /> If mp_Procedure(mpApp, mpDownloadingFile, mpMoveToFile, mpPathFile, mpMacro) = True _<br /> Then rResult.Cells(r).Value = "OK" _<br /> Else: rResult.Cells(r).Value = "Fail"<br /> rTimestamps.Cells(r).Value = Now()<br /> mpApp = .Index 'v2.12 bugfix, resets mpApp<br /> End If<br /> End If<br /> Application.Calculate 'v2.13, updates admin sheet counts<br /> Next r<br /> End With<br /> If mpNative = False Then .Close SaveChanges:=True Else .Save<br /> Set pwSheet = Nothing<br /> Set WB = Nothing<br /> End With<br /> If mpNative = False Then .Quit<br /> Set mpXLapp = Nothing<br />End With<br /><br />End Sub<br /><br />Private Function mp_Procedure(ByRef mpApp As mpApps, ByRef mpDownloadingFile As String, ByRef mpMoveToFile As String _<br /> , ByVal mpPathFile As String, ByVal mpMacro As String) As Boolean<br />'v2.11 2013-09-23 11:18<br />'only run from mp_Run_Procedures<br /><br />On Error GoTo ErrorHandler 'mp_Procedure = False<br /><br />Dim mp_DownloadedFile As String, mp_FileExt As String, b As Byte, c As Byte<br /><br />'v2.04 if URL is specified, download file then change variables and run relevant procedure<br />' NB: mpApp is never 3 at this point<br />If Left(mpDownloadingFile, 7) = "http://" Or Left(mpDownloadingFile, 8) = "https://" Then 'v2.05 handles https<br /> b = InStr(mpMoveToFile, ".") 'check end of string for file ext<br /> Do Until b = 0<br /> mp_FileExt = Mid(mpMoveToFile, b, 1 + Len(mpMoveToFile) - b) '".csv"<br /> c = b<br /> b = InStr(b + 1, mpMoveToFile, ".") 'check end of string for file ext<br /> Loop<br /> mpDownloadingFile = modAppsFirefox.ff_GetDownload(mpDownloadingFile, mp_FileExt, mpMoveToFile, True) 'True always waits for completion<br />End If<br /><br />'original code from modFireFox, second part is changed for this procedure<br />'whilst downloading, file.ext placeholder will exist with 0 bytes, file.ext.part is temporary downloading file<br />'on completion, file.ext wil be deleted, then file.ext.part will be renamed, so file.ext will be >0 bytes<br /> Dim f1 As Double<br />On Error Resume Next<br /> If Dir(mpDownloadingFile) = "" Then GoTo ErrorHandler<br /> f1 = FileLen(mpDownloadingFile)<br /> Do While f1 = 0<br /> 'when download completes, mpDownloadingFile is deleted (i.e. error) then reappears with f1 > 0<br /> f1 = FileLen(mpDownloadingFile)<br /> Loop<br />On Error GoTo 0<br /><br />On Error GoTo ErrorHandler 'mp_Procedure = False<br /><br />'rename downloaded file if specified<br />'NB: renaming .csv to .xls will cause you problems!<br /> If mpMoveToFile <> "" Then<br /> 'use specified filename<br /> mp_DownloadedFile = mpMoveToFile<br /> Else<br /> 'use default download filename<br /> Const cDefaultFilename As String = "Downloaded Web Server Report." ' & mp_FileExt<br /> Const cPrd As String = "."<br /> mp_FileExt = Replace(LCase(mp_FileExt), cPrd, "")<br /> mp_DownloadedFile = cDefaultFilename & mp_FileExt<br /> End If<br />'before moving/renaming download file, kill target file<br /> If mpDownloadingFile <> mp_DownloadedFile Then 'v2.06 not necessary where filenames the same<br /> If Dir(mpDownloadingFile) <> "" And Dir(mp_DownloadedFile) <> "" Then Kill mp_DownloadedFile 'v2.06 stops deletion where files not found<br /> 'rename/move downloaded file<br /> Name mpDownloadingFile As mp_DownloadedFile<br /> End If<br /> <br />'validity check to confirm download completed<br /> If Dir(mp_DownloadedFile) = "" Then<br /> 'downloaded file doesn't exist, something went wrong<br /> MsgBox "Downloaded file not found", vbCritical, "Error in mp_DownloadedFile"<br /> GoTo ErrorHandler<br /> End If<br /><br />'run relevant application (only if required) 'v2.11<br /> If mpPathFile <> "" Then<br /> If mpApp = 1 Then run_Excel "", mpPathFile, mpMacro, False<br /> If mpApp = 2 Then run_Access "", mpPathFile, mpMacro<br /> End If<br /> <br />mp_Procedure = True<br />Exit Function<br />ErrorHandler:<br />End Function</span></span></blockquote>
baldmosher™http://www.blogger.com/profile/11281471751951639119noreply@blogger.com0Stretford M17 1QA, UK53.4609149 -2.318959400000039827.9388804 -43.627553400000039 78.9829494 38.98963459999996tag:blogger.com,1999:blog-7264479838117802346.post-41066342938093117022013-08-05T09:36:00.000-07:002013-12-02T10:00:07.015-08:00VBA Modules: Outlook: OL_BPMProcess v6.22<br />
<a href="http://baldywritten.blogspot.com/2013/08/vba-modules-modzip-v502aaa.html" target="_blank">Read this</a> for full information on these modules<br />
<br />
This module is getting into serious space-age coding territory here (well, for me anyway). If you're a data analyst, and you are fed up with having to deal with a hundred emailed reports, if you can make full use of this, you'll shave at least a day off your workload. If you can do it without anyone finding out, you can achieve the same amount of work with zero effort, and spend the rest of your time clearing your other workload and developing other automation solutions, so that eventually, everyone thinks you're incredibly busy, when actually, you're just sat back watching Outlook do everything for you and browsing Monster for new jobs.<br />
<br />
To give you a rough idea of what I achieve with this, I use this module to process approximately 5GB of data downloads from a web server, update 32GB of local databases, and push out 4GB of Excel reports, and all before I get into the office on Monday morning.<br />
<br />
Now, I could be very sneaky and change the schedule so it only runs during the day, and makes me look like some kind of high throughput automaton, but I'm not sneaky. I prefer to make myself out to be some kind of code wizard, even though I work for a company that prefers to employ Indians, Mexicans and Filipinos in a data centre instead of talented analysts & coders in-country. Now, we're not the only globocorp who does that, so I don't feel remotely ashamed by admitting that we're creating jobs in the third world, and coincidentally we outsource some of this to a "service" centre run by one of my previous blue chip globocorp employers, so I do feel that one day I might have to do this very thing for someone else. Transferable skills are the only advantage we have left -- so learn as many as you can and move on to something else.<br />
<br />
Anyway, mini-rant over, here's the code.<br />
<br />
<br />
Note that I use Outlook Rules to launch the relevant script when keywords are found in the email subject. There is another very elegant way of doing this using Event triggers, but as with many elegant solutions, I find they aren't always reliable once you start making things complicated. This approach works like a sledgehammer. Something gone wrong? Kill Outlook and start again and it'll put the mangled wreckage of failure to one side, pick up the mallet, and start bashing again where it left off.<br />
<br />
Downsides: it's annoying when it gets stuck, which for me is quite often, because I'm a messy coder.<br />
<br />
Also note that the following uses <b>modAppsFirefox</b> to download a file from a URL. As of v6, it uses <b>modProcedures </b>to store Excel/Access/Download procedures for running later.<br />
<br />
<blockquote class="tr_bq">
<span style="font-size: x-small;"><span style="font-family: "Courier New",Courier,monospace;"><span style="font-size: xx-small;">'OL_BPMprocess<br />'v6.22 2013-12-02 17:31<br />'always export to \\GBMNCWSA050\BPMpublic\VBA Modules\Outlook\<br /><br />'===========================================================================<br />' HELP CONTACT<br />'===========================================================================<br />' Code is provided without warranty and can be stolen and amended as required.<br />' Tom Parish<br />' TJP@tomparish.me.uk<br />' http://baldywrittencod.blogspot.com<br />' DGF Help Contact: see BPMHelpContact module<br />'=========================================================================<br /><br />'*************************************************************<br />' NOTE: all prior versions MUST be upgraded to v4.02 or later<br />'*************************************************************<br /><br />'*****************************************************<br />'***** WARNING: SETTINGS BELOW MUST BE AMENDED *****<br />'*****************************************************<br /><br />'===========================================================================<br />' OL_BPMprocess<br />'===========================================================================<br />' OL_ProcessANYREPORT<br />' Routines for copying XLS/CSV (and extracting ZIP) attachments, and for<br />' downloading reports from URL.<br />'<br />' OL_ProcessDATABASE<br />' Routines for processing database updates automatically by trigger email.<br />' Triggered by specific subject, e.g. "BPMAUTORUN DATABASE MONTHEND"<br />'<br />' OL_ProcessZIPIT<br />' Routines for zipping attachments sent back by return (size limit applies).<br />' Triggered by subject, e.g. "BPMAUTORUN ZIPIT free text"<br />'<br />' OLV_xxxxxxx<br />' Simple functions for Outlook<br /><br />'===========================================================================<br />' Additional modules required:<br />'===========================================================================<br />' modAppsFirefox v3 (v2 if DL_WaitForCompletion = False)<br />' modAppsOffice v4<br />' modProcedures (if DL_WaitForCompletion = True)<br />' modZip v6<br />' xlSharePoint (for SP_fn_val)<br /><br />'===========================================================================<br />' Additional References required:<br />'===========================================================================<br />' BPMGB Outlook rule: BPMAUTORUN ANYREPORT<br />' BPMGB Outlook rule: BPMAUTORUN DATABASE<br />' BPMGB Outlook rule: BPMAUTORUN ZIPIT<br /><br />'===========================================================================<br />' External applications required:<br />'===========================================================================<br />' MS Access<br />' MS Excel<br /><br />'=========================================================================<br />' VERSION HISTORY<br />'=========================================================================<br />' v6.22 OL_DATABASE: won't run if specified DBs are locked (see CRP/CRA)<br />' olV_SubmitLog: renamed variables to make more sense<br />' v6.21 OL_DATABASE: changed CRPCRA log file name<br />' v6.20 OL_ANYREPORT: hides Excel window by default, allows automatic report updates<br />' v6.19 OL_DATABASE: added GCCSDBREPORTS trigger<br />' v6.18 OL_DATABASE: added pause to GCCS, prevent issues<br />' v6.17 swapped email address for OL_DefaultEmail in module<br />' OL_DATABASE: minor code tweaks, fixed Logis FTP code<br />' v6.16 OL_DATABASE: added GCCS propagate routine<br />' v6.15 OL_DATABASE: added Logis FTP routine (405)<br />' v6.14 OL_DATABASE: better error handling for unrecognised routines<br />' v6.13 OL_ANYREPORT: bugfix for false error report in simple download, added bNothingElseToDo<br />' v6.12 OL_ANYREPORT: bugfix for false error report when saving attachments, added bAttSaved<br />' v6.11 olXLapp: prevents bugs when using modAppsOffice.XLapp<br />' v6.10 OL_Simple_Archive: bugfix for subject/folder name<br />' v6.09 OL_v_URL: extracts URL from HTML tags <A HREF="url"><br />' OL_v_URL: workaround to prefix incomplete URL in emails with Forwin DLL URL<br />' OL_v_URL: bugfix for when forwarding trigger email to BPM.GB@dhl.com<br />' OL_v_var: bugfix for when forwarding trigger email to BPM.GB@dhl.com<br />' OL_Simple_Archive: bugfix for single-word subfolders<br />' v6.08 OL_ProcessANYREPORT: major process fix for storing Downloads<br />' v6.07 OL_ProcessANYREPORT: bugfix for stored Downloads<br />' v6.06 OL_ProcessDATABASE: CRP/CRA conf email to triggerer, CC group mailboxes<br />' v6.05 OL_ProcessANYREPORT: error handler for stored Download failure<br />' v6.04 OL_ProcessDATABASE: updated CRP/CRA Control List v2 filename<br />' olV_SubmitLog: added triggerer/recipient email address to log, bugfix<br />' v6.03 OL_ProcessANYREPORT: bugfix<br />' OL_SendEmail updated to v1.06<br />' v6.02 OL_ProcessANYREPORT: modProcedures stores URL<br />' v6.01 OL_ProcessANYREPORT: modProcedures error handling<br />' v6.00 OL_ProcessANYREPORT: added modProcedures functionality<br />' v5.00 merged code from modSpecialFolders<br />' v4.05 OL_ProcessANYREPORT: handles dbn including pth<br />' v4.04 OL_Simple_Archive: code rearrangement; marks read, flags complete<br />' v4.03 OL_Simple_Archive: minor bugfix for failed email move (happens during debugging for some reason)<br />' OL_ProcessANYREPORT: added cBsl and cFsl constants<br />' v4.02 OL_SaveAttachment: stopped deleting ofn where pth & ofn = logpthfn<br />' OL_ProcessANYREPORT: validity check for pth, includes \ or /<br />' v4.01 external download routine now in modAppsFirefox<br />' v4.00a annotations only<br />' v4.00 OL_v_vvar: rebuild<br />' OL_ProcessZIPIT: rebuild<br />' OL_ProcessANYREPORT: annotations<br />' OL_ProcessDATABASE: merged modules, renamed macro<br />' merged modules: OL_varPublic, OL_Attachments, OL_DBmacros<br />' retired: OL_ProcessForwinReport, olV_get_From, olV_chk_Auto, olV_do_Auto<br />'***********************************************************************<br />' PRIOR VERSIONS MUST BE UPGRADED<br />'***********************************************************************<br />'=========================================================================<br />' OL_Attachments VERSION HISTORY<br />'=========================================================================<br />' v3.06 OL_v_URL: works for any file format hyperlink<br />' v3.05 OL_ProcessANYREPORT: changes to syntax in trigger failure reply<br />' v3.04 OL_ProcessANYREPORT: bugfix in download errors<br />' v3.03 OL_Simple_Archive: tgt folder dictated by UPPER CASE words<br />' added OL_UpperCase<br />' added OL_LowerCase (for posterity only, not used)<br />' v3.02 OL_Simple_Archive: handles multiple attachments<br />' OL_SaveAttachment: handles multiple attachments<br />' OL_ProcessANYREPORT: handles multiple attachments<br />' OL_ProcessANYREPORT: downloads files from Forwin CSV hyperlink<br />' OL_v_URL: checks for specified pipe variable first<br />' v3.01 merged olS and olZ modules into olA<br />' v3.00 OL_ProcessForwinReport retired<br />' v2.12 OL_ProcessAnyReport (replaces OL_ProcessForwinReport)<br />'=========================================================================<br />' OL_DBmacros VERSION HISTORY<br />'=========================================================================<br />' v1.07 olD_ProcessDatabaseUpdates: runs OL_Simple_Archive<br />' v1.06 olD_ProcessDatabaseUpdates: writes result to log, sends email<br />' v1.05 olD_ProcessDatabaseUpdates: opens ReadOnly<br />' v1.04 olD_ProcessDatabaseUpdates: XL quits afterwards<br />' v1.03 olD_ProcessDatabaseUpdates: added CRP/CRA trigger and log<br />'=========================================================================<br />' OL_varPublic VERSION HISTORY<br />'=========================================================================<br />' v2.15 removed xlShellAndWait and Excel references<br />' v2.14 olV_submitlog: sends confirmation/failure email<br />' v2.13 annotations only (no material effect)<br />' v2.12 olV_submitlog: added logTimeTaken, logRecipientEmail, logpthfn<br />' v2.11 bugfix for xlShellAndWait<br />' updated log file path to GBMNCWSA050 share<br />' v2.10 moved to GBMNCWSA050<br /><br />Option Explicit<br /><br />'*****************************************************<br />'***** WARNING: SETTINGS BELOW MUST BE AMENDED *****<br />'*****************************************************<br /><br />'max email attachment size in BYTES (10000000 = 10MB)<br />Private Const maxAttSize As Double = 10000000<br /><br />'log file location should be changed for end user, write access is required<br />Public Const LogFolder As String _<br /> = "\\GBMNCWSA050\BPMpublic\LogFiles\" 'v2.11<br /><br />'CSV will be created/updated in above LogFolder<br />Public Const LogFileName As String _<br /> = "OutlookSaveAttachmentsLog.csv"<br /><br />Private Const DL_WaitForCompletion As Boolean = False<br />'v6.00 True will always wait for completion of downloads, False requires modProcedures<br /><br />'default email address for Trigger Failure and if recipient is specified as "" (mainly for testing)<br />Private Const OL_DefaultEmail As String = "bpm.gb@dhl.com" 'v5.00<br /><br />'Specify name of default Mailbox - case sensitive<br />Private Const OL_MYmbx As String = "BPM.GB@dhl.com" 'v5.00<br /><br />'*****************************************************<br /><br /><br /><br />Private olXLapp As Excel.Application 'v6.11<br /><br />Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliSeconds As Long)<br /><br />'==========================================================================<br />'==========================================================================<br />'==========================================================================<br />'==========================================================================<br /><br />'<br />' Code from modSpecialFolders module:<br />'<br /><br />'http://answers.microsoft.com/en-us/office/forum/office_2010-customize/how-2-refer-to-desktop/97eba910-54c9-409f-9454-6d7c8d54d009<br />Private Declare Function SHGetSpecialFolderLocation _<br /> Lib "shell32" (ByVal hwnd As Long, _<br /> ByVal nFolder As Long, ppidl As Long) As Long<br /><br />Private Declare Function SHGetPathFromIDList _<br /> Lib "shell32" Alias "SHGetPathFromIDListA" _<br /> (ByVal Pidl As Long, ByVal pszPath As String) As Long<br /><br />Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal pvoid As Long)<br /><br />'Desktop<br />Private Const CSIDL_INTERNET = &H1 'Internet Explorer (icon on desktop)<br />Private Const CSIDL_PROGRAMS = &H2 'Start Menu\Programs<br />Private Const CSIDL_CONTROLS = &H3 'My Computer\Control Panel<br />Private Const CSIDL_PRINTERS = &H4 'My Computer\Printers<br />Private Const CSIDL_PERSONAL = &H5 'My Documents<br />Private Const CSIDL_FAVORITES = &H6 '<user name>\Favorites<br />Private Const CSIDL_STARTUP = &H7 'Start Menu\Programs\Startup<br />Private Const CSIDL_RECENT = &H8 '<user name>\Recent<br />Private Const CSIDL_SENDTO = &H9 '<user name>\SendTo<br />Private Const CSIDL_BITBUCKET = &HA '<desktop>\Recycle Bin<br />Private Const CSIDL_STARTMENU = &HB '<user name>\Start Menu<br />Private Const CSIDL_DESKTOPDIRECTORY = &H10 '<user name>\Desktop<br />Private Const CSIDL_DRIVES = &H11 'My Computer<br />Private Const CSIDL_NETWORK = &H12 'Network Neighborhood<br />Private Const CSIDL_NETHOOD = &H13 '<user name>\nethood<br />Private Const CSIDL_FONTS = &H14 'Windows\fonts<br />Private Const CSIDL_TEMPLATES = &H15<br />Private Const CSIDL_COMMON_STARTMENU = &H16 'All Users\Start Menu<br />Private Const CSIDL_COMMON_PROGRAMS = &H17 'All Users\Programs<br />Private Const CSIDL_COMMON_STARTUP = &H18 'All Users\Startup<br />Private Const CSIDL_COMMON_DESKTOPDIRECTORY = &H19 'All Users\Desktop<br />Private Const CSIDL_APPDATA = &H1A '<user name>\Application Data<br />Private Const CSIDL_PRINTHOOD = &H1B '<user name>\PrintHood<br />Private Const CSIDL_LOCAL_APPDATA = &H1C '<user name>\Local Settings\Application Data (non roaming)<br />Private Const CSIDL_ALTSTARTUP = &H1D 'non localized startup<br />Private Const CSIDL_COMMON_ALTSTARTUP = &H1E 'non localized common startup<br />Private Const CSIDL_COMMON_FAVORITES = &H1F<br />Private Const CSIDL_INTERNET_CACHE = &H20<br />Private Const CSIDL_COOKIES = &H21<br />Private Const CSIDL_HISTORY = &H22<br />Private Const CSIDL_COMMON_APPDATA = &H23 'All Users\Application Data<br />Private Const CSIDL_WINDOWS = &H24 'Windows Directory<br />Private Const CSIDL_SYSTEM = &H25 'System Directory<br />Private Const CSIDL_PROGRAM_FILES = &H26 'C:\Program Files<br />Private Const CSIDL_MYPICTURES = &H27 'C:\Program Files\My Pictures<br />Private Const CSIDL_PROFILE = &H28 'USERPROFILE<br />Private Const CSIDL_SYSTEMX86 = &H29 'x86 system directory on RISC<br />Private Const CSIDL_PROGRAM_FILESX86 = &H2A 'x86 C:\Program Files on RISC<br />Private Const CSIDL_PROGRAM_FILES_COMMON = &H2B 'C:\Program Files\Common<br />Private Const CSIDL_PROGRAM_FILES_COMMONX86 = &H2C 'x86 Program Files\Common on RISC<br />Private Const CSIDL_COMMON_TEMPLATES = &H2D 'All Users\Templates<br />Private Const CSIDL_COMMON_DOCUMENTS = &H2E 'All Users\Documents<br />Private Const CSIDL_COMMON_ADMINTOOLS = &H2F 'All Users\Start Menu\Programs\Administrative Tools<br />Private Const CSIDL_ADMINTOOLS = &H30 '<user name>\Start Menu\Programs\Administrative Tools<br />Private Const CSIDL_CONNECTIONS = &H31 'Network and Dial-up Connections<br />Private Const MAX_PATH = 260<br />Private Const NOERROR = 0<br /><br />Private Function SpecFolder(ByVal lngFolder As Long) As String<br />Dim lngPidlFound As Long<br />Dim lngFolderFound As Long<br />Dim lngPidl As Long<br />Dim strPath As String<br /><br />strPath = Space(MAX_PATH)<br />lngPidlFound = SHGetSpecialFolderLocation(0, lngFolder, lngPidl)<br />If lngPidlFound = NOERROR Then<br /> lngFolderFound = SHGetPathFromIDList(lngPidl, strPath)<br /> If lngFolderFound Then<br /> SpecFolder = Left$(strPath, _<br /> InStr(1, strPath, vbNullChar) - 1)<br /> End If<br />End If<br />CoTaskMemFree lngPidl<br />End Function<br /><br />'==========================================================================<br />'==========================================================================<br />'==========================================================================<br />'==========================================================================<br /><br />Sub OL_ProcessANYREPORT(Item As Outlook.MailItem)<br />'v6.20 2013-11-26 15:09<br />'saves a copy of attachment (if one exists) and renames it (if ofn specified)<br />'!! ZIP extract & rename only possible if true extension is part of zip filename<br />'!! e.g. Report.csv.zip<br />'and/or downloads file from any URL (if url specified)<br />'and/or downloads file from any* hyperlink embedded in email<br />'!! *tested for Forwin CSV only - but can be adapted easily for other hyperlinks<br />'and/or run DB update (if dbn and dbm specified)<br />'and/or run XLS macros (if xls specified)<br />'and/or send confirmation email (if cfm specified)<br />'then move email into ANYREPORT folder<br /><br />'SYNTAX to test:<br />'OL_ProcessANYREPORT OL_GetCurrentItem<br /><br />' SUBJECT HEADER FOR EMAIL MUST BE ENTERED AS FOLLOWS:<br />'====================================================================<br />' BPMAUTORUN ANYREPORT [Report identification free text]<br />'====================================================================<br /><br />' VARIABLES MUST BE ENTERED IN EMAIL BODY (PLAIN TEXT) AS FOLLOWS:<br />' BPMAUTORUN variables must be on separate lines, in "quote marks",<br />' and separated by pipes |<br />' NB: pattern match looks for e.g. "|pth=" at start and ""|" at end<br />' pth is mandatory, others are optional<br />'====================================================================<br />'|subj="BPMAUTORUN ANYREPORT [Report identification free text]"<br /> 'NB: subj is not actually used, just helps with making copies of schedule template<br />'|pth="\\SERVER\Share Name\Folder\Subfolder\"<br />' 'NB: required<br />'|ofn="Filename.ext"<br /> 'NB: if not specified, simply uses original filename<br />'|dbn="Database.mdb/.accdb"<br />'|dbm="reload ALL"<br /> 'NB: this machine must have Access 2007+ installed for .accdb<br />'|xls="UPDATE MACRO.xls"<br /> 'NB: can specify full path to override pth above, otherwise looks in pth for this file<br />'|cfm="recipient.email@domain.com"<br /> 'NB: separate multiple recipients with semicolon and space "; "<br />'|url="http://domain.com/folder/file.ext"<br />'| 'NB: final pipe is required to prevent errors with last quotation mark<br />'<br />'CSV (hyperlink)<br /> 'NB: may only extract URL from Forwin notification hyperlinks - to be tested<br />'====================================================================<br /><br />Dim pth As String, ofn As String, dbn As String, dbm As String, xls As String, cfm As String, url As String<br />pth = OL_v_var(Item, "pth") 'REQUIRED - if none of the following are specified, will simply save attachment to pth<br />ofn = OL_v_var(Item, "ofn") 'optional (required if URL is used)<br />dbn = OL_v_var(Item, "dbn") 'optional (required if dbm is provided)<br />dbm = OL_v_var(Item, "dbm") 'optional (required if dbn is provided)<br />xls = OL_v_var(Item, "xls") 'optional (NB: if a UNC is specified here, note that if testing by forwarding, Outlook converts to HYPERLINK automatically)<br />cfm = OL_v_var(Item, "cfm") 'optional (specifies recipient for email confirmation when done)<br />url = OL_v_URL(Item) 'optional (required for download)<br /><br />Dim cfmmsg As String, cfmsub As String, blnFailed As Boolean<br />Dim dl_PathFile As String 'v6.00<br />Dim bStoreProc As Boolean, bStoreURL As Boolean 'v6.02 'v6.03<br />Dim bAttSaved As Boolean 'v6.12<br />Dim bNothingElseToDo As Boolean 'v6.13<br /><br />If cfm = "" Then cfm = Item.SenderEmailAddress<br /><br />Const cBsl As String = "\"<br />Const cFsl As String = "/"<br /><br />If pth <> vbNullString Then<br /> If InStr(pth, cBsl) > 0 Or InStr(pth, cFsl) > 0 Then<br /> <br /> 'EITHER<br /> 'optional: save attachment(s)<br /> If Item.Attachments.Count > 0 Then<br /> If Item.Attachments.Count > 1 And ofn <> "" Then<br /> 'blnFailed = True 'not a total failure<br /> cfmmsg = "Error: ofn cannot be specified with multiple attachments." & vbLf & vbLf<br /> OL_SaveAttachment Item, pth<br /> bAttSaved = True 'v6.12<br /> cfmmsg = cfmmsg & "Attachments saved to: " & pth & vbLf & vbLf<br /> Else<br /> OL_SaveAttachment Item, pth, ofn<br /> bAttSaved = True 'v6.12<br /> cfmmsg = "Attachment saved to: " & pth & ofn & vbLf & vbLf<br /> End If<br /> 'OR<br /> 'optional: download from URL<br /> ElseIf url <> vbNullString Then<br /> 'url and pth are BOTH required to download file<br /> '!! ofn is mandatory for URL downloads as the downloaded filename is always gibberish<br /> If ofn = "" Then<br /> blnFailed = True<br /> cfmmsg = "Error: ofn is required to download from URL to " & pth & vbLf & vbLf<br /> Else<br /> 'download file<br /> dl_PathFile = modAppsFirefox.ff_GetDownload(url, "", pth & ofn, DL_WaitForCompletion) 'v6.00<br /> If dl_PathFile = "" Then<br /> blnFailed = True<br /> cfmmsg = "Error: file could not be downloaded from URL to:" & pth & ofn & vbLf & vbLf<br /> ElseIf dl_PathFile = pth & ofn Then<br /> bNothingElseToDo = True<br /> cfmmsg = url & vbLf & vbLf & "File downloaded to: " & pth & ofn & vbLf & vbLf<br /> ElseIf dl_PathFile = url Then '6.02<br /> bStoreURL = True<br /> cfmmsg = "File not downloaded, URL will be stored and should be downloaded later" & vbLf & vbLf & dl_PathFile & vbLf & pth & ofn & vbLf & vbLf<br /> Else<br /> bStoreProc = True<br /> cfmmsg = "File still downloading, procedure will be stored and should be run later" & vbLf & vbLf & dl_PathFile & vbLf & pth & ofn & vbLf & vbLf<br /> End If<br /> End If<br /> End If<br /> <br /> 'optional: DB macros are not always required<br /> If dbn <> vbNullString And dbm <> vbNullString And blnFailed = False Then<br /> If (dbn <> vbNullString And dbm = vbNullString) Or (dbn = vbNullString And dbm <> vbNullString) Then<br /> blnFailed = True<br /> cfmmsg = cfmmsg & "Error: Database could not be updated, dbn and dbm are both required" & vbLf & vbLf<br /> Else<br /> If InStr(dbn, cBsl) > 0 Or InStr(xls, cFsl) > 0 Then<br /> 'path is included within dbn string<br /> If bStoreURL = True Then<br /> 'download later<br /> If modProcedures.mp_Procedure_Store(url, "", pth & ofn, mpApps.mpAccess, dbn, dbm) = False Then 'v6.07<br /> blnFailed = True<br /> cfmmsg = "Error: couldn't store Download procedure" & vbLf & vbLf & url & vbLf & vbLf & pth & ofn & vbLf & vbLf<br /> End If<br /> ElseIf bStoreProc = True Then<br /> 'run procedure later<br /> If modProcedures.mp_Procedure_Store(url, dl_PathFile, pth & ofn, 2, dbn, dbm) = False Then<br /> blnFailed = True<br /> cfmmsg = "Error: couldn't store procedure, dl_Pathfile already in use" & vbLf & vbLf & dl_PathFile & vbLf & vbLf<br /> End If<br /> Else<br /> run_Access vbNullString, dbn, dbm<br /> If DBapp Is Nothing Then<br /> cfmmsg = cfmmsg & "Database updated: " & dbn & vbLf & vbLf<br /> Else<br /> Set DBapp = Nothing<br /> blnFailed = True<br /> cfmmsg = cfmmsg & "Database not updated, something went wrong: " & dbn & vbLf & vbLf<br /> End If<br /> End If<br /> Else<br /> 'path is same as saved report<br /> If bStoreURL = True Then<br /> 'download later<br /> If modProcedures.mp_Procedure_Store(url, "", pth & ofn, mpApps.mpAccess, dbn, dbm) = False Then 'v6.07<br /> blnFailed = True<br /> cfmmsg = "Error: couldn't store Download procedure" & vbLf & vbLf & url & vbLf & vbLf & pth & ofn & vbLf & vbLf<br /> End If<br /> ElseIf bStoreProc = True Then<br /> If modProcedures.mp_Procedure_Store(url, dl_PathFile, pth & ofn, 2, pth & dbn, dbm) = False Then<br /> blnFailed = True<br /> cfmmsg = "Error: couldn't store procedure, dl_Pathfile already in use" & vbLf & vbLf & dl_PathFile & vbLf & vbLf<br /> End If<br /> Else<br /> run_Access pth, dbn, dbm<br /> If DBapp Is Nothing Then<br /> cfmmsg = cfmmsg & "Database updated: " & dbn & vbLf & vbLf<br /> Else<br /> Set DBapp = Nothing<br /> blnFailed = True<br /> cfmmsg = cfmmsg & "Database not updated, something went wrong: " & dbn & vbLf & vbLf<br /> End If<br /> End If<br /> End If<br /> End If<br /> End If<br /> <br /> 'optional: XL macros are not always required, but advisable, because you can<br /> 'autorun Access macros, or long series of SQL queries, with Excel VBA<br /> If xls <> vbNullString And blnFailed = False Then<br /> If InStr(xls, cBsl) > 0 Or InStr(xls, cFsl) > 0 Then<br /> 'path is included within xls string<br /> If bStoreURL = True Then<br /> 'download later<br /> If modProcedures.mp_Procedure_Store(url, "", pth & ofn, mpApps.mpExcel, xls, "") = False Then 'v6.07<br /> blnFailed = True<br /> cfmmsg = "Error: couldn't store Download procedure" & vbLf & vbLf & url & vbLf & vbLf & pth & ofn & vbLf & vbLf<br /> End If<br /> ElseIf bStoreProc = True Then<br /> 'run procedure later<br /> If modProcedures.mp_Procedure_Store(url, dl_PathFile, pth & ofn, mpApps.mpExcel, xls) = False Then<br /> blnFailed = True<br /> cfmmsg = "Error: couldn't store procedure, dl_Pathfile already in use" & vbLf & vbLf & dl_PathFile & vbLf & vbLf<br /> End If<br /> Else<br /> run_Excel XLpth:=vbNullString, XLfn:=xls, bForceVisibility:=False 'v6.20 bForceVisibility fixes issue with automatic update of some reports, only updates when invisible<br /> If olXLapp Is Nothing Then<br /> cfmmsg = cfmmsg & "Excel macros run: " & pth & xls & vbLf & vbLf<br /> Else<br /> Set olXLapp = Nothing<br /> blnFailed = True<br /> cfmmsg = cfmmsg & "Excel macros not run, something went wrong: " & pth & xls & vbLf & vbLf<br /> End If<br /> End If<br /> Else<br /> 'path is same as saved report<br /> If bStoreURL = True Then<br /> 'download later<br /> If modProcedures.mp_Procedure_Store(url, "", pth & ofn, mpApps.mpExcel, xls, "") = False Then 'v6.07<br /> blnFailed = True<br /> cfmmsg = "Error: couldn't store Download procedure" & vbLf & vbLf & url & vbLf & vbLf & pth & ofn & vbLf & vbLf<br /> End If<br /> ElseIf bStoreProc = True Then<br /> If modProcedures.mp_Procedure_Store(url, dl_PathFile, pth & ofn, mpApps.mpExcel, pth & xls) = False Then<br /> blnFailed = True<br /> cfmmsg = "Error: couldn't store procedure, dl_Pathfile already in use" & vbLf & vbLf & dl_PathFile & vbLf & vbLf<br /> End If<br /> Else<br /> run_Excel XLpth:=pth, XLfn:=xls, bForceVisibility:=False 'v6.20 bForceVisibility fixes issue with automatic update of some reports, only updates when invisible<br /> If olXLapp Is Nothing Then<br /> cfmmsg = cfmmsg & "Excel macros run: " & pth & xls & vbLf & vbLf<br /> Else<br /> Set olXLapp = Nothing<br /> blnFailed = True<br /> cfmmsg = cfmmsg & "Excel macros not run, something went wrong: " & pth & xls & vbLf & vbLf<br /> End If<br /> End If<br /> End If<br /> End If<br /> <br /> 'optional: just move downloading file once completed if no XL macros or DB specified 'v6.08<br /> If bAttSaved = False And xls = vbNullString And dbn = vbNullString And blnFailed = False And bNothingElseToDo = False Then 'v6.13 'v6.12<br /> 'eventual path can be different or same as current download location<br /> If bStoreURL = True Then<br /> 'download later<br /> If modProcedures.mp_Procedure_Store(url, "", pth & ofn, mpApps.mpExcel, "", "") = False Then 'v6.07<br /> blnFailed = True<br /> cfmmsg = "Error: couldn't store Download procedure" & vbLf & vbLf & url & vbLf & vbLf & pth & ofn & vbLf & vbLf<br /> End If<br /> ElseIf bStoreProc = True Then<br /> 'run procedure later (actually doesn't run any procedure, because xls is "", could equally put it on Access sheet)<br /> If modProcedures.mp_Procedure_Store(url, dl_PathFile, pth & ofn, mpApps.mpExcel, "") = False Then<br /> blnFailed = True<br /> cfmmsg = "Error: couldn't store procedure, dl_Pathfile already in use?" & vbLf & vbLf & dl_PathFile & vbLf & vbLf<br /> End If<br /> Else<br /> blnFailed = True<br /> cfmmsg = cfmmsg & "Download process not stored, something went wrong: " & vbLf & vbLf & pth & ofn & vbLf & vbLf<br /> End If<br /> End If<br /> <br /> 'send failure notification if nothing was done<br /> If cfmmsg = "" Then<br /> blnFailed = True<br /> cfmmsg = "Error: nothing to do." & vbLf & vbLf<br /> End If<br /> <br /> Else<br /> 'pth doesn't contain any slashes, can't be valid, send failure notification<br /> blnFailed = True<br /> cfmmsg = "Error: pth invalid, no slashes."<br /> End If<br />Else<br />'pth not specified, send failure notification<br /> blnFailed = True<br /> cfmmsg = "Error: pth not specified, pth is mandatory."<br />End If<br /><br /><br />'send confirmation email<br />'NB: if cfm (optional) not specified, will send confirmation to modEmail.OL_DefaultEmail<br />If blnFailed = True Then<br /> Const cNotUsed = " (not used)"<br /> Const cMandatory = " (Mandatory)"<br /> Const cOptional = " (Optional)"<br /> Const cForwinURLOnly = " (NB: currently only tested with Forwin hyperlinks)"<br /> cfmsub = "Trigger Failed: " & Replace(Item.Subject, "BPMAUTORUN ANYREPORT ", "")<br /> cfmmsg = cfmmsg & vbLf _<br /> & vbLf _<br /> & "Original Message Body:" & vbLf _<br /> & Item.Body & vbLf _<br /> & vbLf _<br /> & "Correct Syntax for Email Body:" & vbLf & vbLf _<br /> & "|subj=" & Chr(34) & "BPMAUTORUN ANYREPORT FOLDER1 FOLDER2 [Report identification free text]" & Chr(34) & cNotUsed & vbLf _<br /> & "|pth=" & Chr(34) & "\\SERVER\Share Name\Folder\Subfolder\" & Chr(34) & cMandatory & vbLf _<br /> & "|ofn=" & Chr(34) & "Filename.ext" & Chr(34) & cOptional & "*" & vbLf _<br /> & "|dbn=" & Chr(34) & "Database.mdb/.accdb" & Chr(34) & cOptional & vbLf _<br /> & "|dbm=" & Chr(34) & "DB macro name" & Chr(34) & cOptional & vbLf _<br /> & "|xls=" & Chr(34) & "UPDATE MACRO.xls/m" & Chr(34) & cOptional & vbLf _<br /> & "|cfm=" & Chr(34) & "recipient.email@domain.com" & Chr(34) & cOptional & vbLf _<br /> & "|url=" & Chr(34) & "http://domain.com/folder/file.ext" & Chr(34) & cOptional & vbLf _<br /> & "| (Mandatory, this 'pipe' marks the end of the body text)" & vbLf _<br /> & vbLf _<br /> & "NB:" & vbLf _<br /> & " - UPPER CASE subject controls where completed trigger is filed (i.e. ANYREPORT > UPPER > CASE > Lower case text folder name)" & vbLf _<br /> & " - pipes | indicate the start of a variable" & vbLf _<br /> & " - anything on the line after " & Chr(34) & "variabletext" & Chr(34) & " is ignored" & vbLf _<br /> & " - attachment(s) will be saved to pth automatically" & vbLf _<br /> & " - ofn cannot be used with multiple attachments" & vbLf _<br /> & " - Hyperlinks within body text can also be downloaded, e.g.:" & vbLf _<br /> & " CSV [hyperlink]" & cForwinURLOnly & vbLf _<br /> & " * ofn is Mandatory for hyperlink downloads" & vbLf<br /><br />ElseIf bStoreProc = True Then<br /> cfmsub = "Procedure Stored: " & Replace(Item.Subject, "BPMAUTORUN ANYREPORT ", "")<br /> cfmmsg = cfmmsg & vbLf _<br /> & vbLf _<br /> & "Original Message Body:" & vbLf _<br /> & Item.Body<br /><br />Else<br /> cfmsub = "Trigger Processed: " & Replace(Item.Subject, "BPMAUTORUN ANYREPORT ", "")<br /> cfmmsg = cfmmsg & vbLf _<br /> & vbLf _<br /> & "Original Message Body:" & vbLf _<br /> & Item.Body<br />End If<br /><br />OL_Simple_Archive Item<br /><br />OL_SendEmail _<br /> Email_Recipient:=cfm, _<br /> Email_RecipientBCC:=OL_DefaultEmail, _<br /> Email_Subject:=cfmsub, _<br /> Email_BodyText:=cfmmsg<br /><br />End Sub<br /><br />Sub OL_ProcessZIPIT(Item As Outlook.MailItem)<br />'v6.17 2013-10-31 11:20<br />'save a copy of attachment [to specified path]<br />'then zip and email back to sender [OR specified recipient]<br />'with default subject and body text [OR as specified]<br /><br />'NB: this text is repeated below and used as body text syntax<br /><br />' SUBJECT HEADER FOR EMAIL MUST BE ENTERED AS FOLLOWS:<br />'====================================================================<br />' BPMAUTORUN ZIPIT [Report identification free text]<br />'====================================================================<br /><br />' VARIABLES MUST BE ENTERED IN EMAIL BODY (PLAIN TEXT) AS FOLLOWS:<br />' BPMAUTORUN variables must be on separate lines, in "quote marks",<br />' and separated by pipes |<br />' NB: pattern match looks for e.g. "|pth=" at start and ""|" at end<br />' all are optional<br />'====================================================================<br />'|subj="BPMAUTORUN ZIPIT [Report identification free text]"<br />'|fwd="email.address@domain.com"<br />'|pth="\\ServerName\ShareName\Folder\"<br />'|subj="Subject Header for Email"<br />'|sbod="Body text for email including signature, use VB character codes"<br />'|att="Attachment Name.zip"<br />'====================================================================<br /><br />Const subjDef As String = "Zipped file attached"<br />Const sattDef As String = "Attachment.zip"<br />Dim sbodDef As String<br />sbodDef = "Please find your zipped attachment." & vbLf _<br /> & vbLf _<br /> & "Kind regards," & vbLf _<br /> & vbLf _<br /> & "BPM Autoresponder" & vbLf _<br /> & OL_DefaultEmail & vbLf _<br /> & vbLf _<br /> & "SUBJECT HEADER FOR EMAIL MUST BE ENTERED AS FOLLOWS:" & vbLf _<br /> & "====================================================================" & vbLf _<br /> & " BPMAUTORUN ZIPIT [Report identification free text]" & vbLf _<br /> & "====================================================================" & vbLf _<br /> & vbLf _<br /> & " VARIABLES MUST BE ENTERED IN EMAIL BODY (PLAIN TEXT) AS FOLLOWS:" & vbLf _<br /> & " BPMAUTORUN variables must be on separate lines, in " & Chr(34) & "quote marks" & Chr(34) & "," & vbLf _<br /> & " and separated by pipes |" & vbLf _<br /> & " NB: pattern match looks for e.g. " & Chr(34) & "|pth=" & Chr(34) & " at start and " & Chr(34) & " at end" & vbLf _<br /> & " all are optional" & vbLf _<br /> & "====================================================================" & vbLf _<br /> & "|subj=" & Chr(34) & "BPMAUTORUN ZIPIT [Report identification free text]" & Chr(34) & " (not used)" & vbLf _<br /> & "|fwd=" & Chr(34) & "email.address@domain.com" & Chr(34) & vbLf _<br /> & "|pth=" & Chr(34) & "\\ServerName\ShareName\Folder\" & Chr(34) & " NB: this UNC share must be accessible to BPM.GB@dhl.com" & vbLf _<br /> & "|subj=" & Chr(34) & "Subject Header for Email" & Chr(34) & vbLf _<br /> & "|sbod=" & Chr(34) & "Body text for email including signature, use VB character codes" & Chr(34) & vbLf _<br /> & "|att=" & Chr(34) & "Attachment Name.zip" & Chr(34) & vbLf _<br /> & "===================================================================="<br /><br />Dim pthdefault, pth As String, fwd As String, subj As String, sbod As String<br />Dim bPathFail As Boolean<br />Dim oMail As Outlook.MailItem<br />Set oMail = Application.Session.GetItemFromID(Item.EntryID)<br />Dim src As String, tgt As String<br />pth = OL_v_var(oMail, "pth") 'optional<br />fwd = OL_v_var(oMail, "fwd") 'optional<br />subj = OL_v_var(oMail, "subj") 'optional<br />'use defaults if not specified<br />If fwd = vbNullString Then fwd = oMail.SenderEmailAddress<br />If subj = vbNullString Then subj = subjDef<br />If sbod = vbNullString Then sbod = "Dear " & oMail.SenderName & "," & vbLf & vbLf & sbodDef<br /><br />'check for multiple attachments<br />If oMail.Attachments.Count > 1 Then<br /> OL_SendEmail fwd, , OL_DefaultEmail, subj, "ZIPIT Error: cannot process multiple attachments", False<br /> Exit Sub<br />End If<br /><br />'set default path<br />pthdefault = SpecFolder(CSIDL_PERSONAL) & "\BPM Tools\"<br />On Error Resume Next<br />MkDir pthdefault<br />pthdefault = pthdefault & "ZIPIT\"<br />MkDir pthdefault<br />On Error GoTo 0<br /><br />'pth is optional to save original attachment<br />If pth <> vbNullString Then<br />'check the specified path exists and is accessible<br /> If Dir(pth, vbDirectory) <> "." Then bPathFail = True<br />Else<br /> bPathFail = True<br />End If<br /><br />If bPathFail = True Then<br />'pth not specified or doesn't exist, save to default folder<br /> pth = pthdefault<br />End If<br /><br />'save attachment to pth, delete from original email<br />src = OL_SaveAttachment(oMail, pth)<br /><br />'set tgt zip in default folder<br />tgt = pthdefault & sattDef<br /><br />'zip it<br />If Zip7Sub(src, tgt, True) <> 0 Then<br /> OL_SendEmail fwd, , OL_DefaultEmail, subj, "ZIPIT Error: please contact bpm.gb@dhl.com for advice", False<br /> Exit Sub<br />End If<br /><br />'check zip file is below allowable size limit<br />Dim zAttSize As Long 'MB<br />zAttSize = FileLen(tgt) / 1048576 '(1024 * 1024)<br />If zAttSize > (maxAttSize / 1048576) Then<br /> OL_SendEmail fwd, , OL_DefaultEmail, subj, "ZIPIT Error: maximum attachment size of " & (maxAttSize / 1048576) & "MB exceeded, zip was " & zAttSize & "MB", False<br /> Exit Sub<br />End If<br /><br />'send the email with zipped attachment<br />OL_SendEmail fwd, , , subj, sbod, False, tgt<br /><br />'file email in ZIPIT folder<br />OL_Simple_Archive oMail<br /><br />'log success at this point?<br /><br />End Sub<br /><br />Sub OL_ProcessDATABASE(Item As Outlook.MailItem)<br />'v6.22 2013-12-02 17:31<br /><br />'triggers in scope, e.g. "BPMAUTORUN DATABASE MONTHEND"<br />'also need to replicate code below for new database process<br />Dim sProcess As String, bDoArchive As Boolean<br />Const cMONTHEND As String = "MONTHEND"<br />Const cCRPCRA As String = "CRP/CRA"<br />Const cGCCSprop As String = "GCCSPROPAGATE" 'v6.16<br />Const cGCCSreports As String = "GCCSDBREPORTS" 'v6.19<br />'NB: this doesn't use BPMAUTORUN DATABASE prefix:<br />Const cLogisFTP As String = "File transfer completed successfully."<br /><br />Dim oMail As Outlook.MailItem<br />Set oMail = Application.Session.GetItemFromID(Item.EntryID)<br /><br />Dim subj As String, rcpt As String, sbody As String, updname As String _<br /> , olAppObj As Object, WB As Object, logpthfn As String _<br /> , macroname As String, queryname As String, pthfn As String _<br /> , t As Single, s As Long<br /><br />Dim DBIsLocked As Boolean, DBdependents() As String, d As Byte 'v6.22<br /><br />'Dim logDateTime As String, logPathFile As String, logResult As String<br />'logResult = False<br /><br />t = Now()<br /><br />With oMail<br />'flag red, cleared later when completed<br />'NB: different code for Outlook 2007+<br />If val(Application.Version) < 12 Then<br />'2003 and before<br /> .FlagStatus = olFlagMarked<br /> .FlagIcon = olRedFlagIcon<br /> .Save<br />Else<br />'2007 and later<br /> .FlagStatus = olFlagMarked<br /> .FlagIcon = olRedFlagIcon<br /> .Save<br />End If<br /> subj = .Subject<br /> rcpt = .SenderEmailAddress<br /> sbody = .Body<br />End With<br /><br />'------------------------------------------------------------------------------------------------------------<br />' Month End database updates (doesn't work on GBMNCWSA050 yet?)<br />'------------------------------------------------------------------------------------------------------------<br />sProcess = cMONTHEND<br /> If InStr(subj, " " & sProcess) > 0 Then<br /> logpthfn = "C:\Documents and Settings\bpmgb\Documents\MONTHEND log.csv"<br /> macroname = ") RELOAD ALL"<br /> 'this isn't set yet! need to migrate to shared drive first<br /> pthfn = "C:\Documents and Settings\All Users\"<br /> Set olAppObj = XLlaunch(True)<br /> 'do anything else?<br /> Set WB = olAppObj.Workbooks.Open(pthfn)<br /> WB.Sheets(1).Range("SelectedQuery").Value = macroname<br /> WB.Macros.CBDoThisMacro_Click True<br /> WB.Close SaveChanges:=True<br /> olAppObj.Quit<br /> t = CSng(Now() - t) 'time in decimal<br /> s = t * 60 * 60 * 24 'converts decimal to seconds<br /> olV_SubmitLog Now(), sProcess, "Processed", s, OL_DefaultEmail, ""<br /> olAppObj.Quit<br /> Set olAppObj = Nothing<br /> bDoArchive = True<br /> GoTo CleanUp<br /> End If<br /><br />'------------------------------------------------------------------------------------------------------------<br />' Customer Reporting Pack - Customer Revenue Analysis<br />'------------------------------------------------------------------------------------------------------------<br />sProcess = cCRPCRA<br /> If InStr(subj, " " & sProcess) > 0 Then<br /> d = 2 'v6.22<br /> ReDim DBdependents(d) As String<br /> DBdependents(1) = "\\GBMNCWSA050\Databases\Forwin\Shipment Level\Forwin Shipment Level.laccdb"<br /> DBdependents(2) = "\\GBMNCWSA050\Databases\ComboData\GBSTSWSA030\CoRA.laccdb"<br /> For d = 1 To d<br /> If Dir(DBdependents(d)) <> "" Then<br /> DBIsLocked = True<br /> Exit For<br /> Next d<br /> Next d<br /> logpthfn = "\\ishare.dhl.com\sites\DGFUK\CR\CRP\CRPCRA trigger log.csv" 'v6.21<br /> macroname = ""<br /> updname = "CRP / CRA database"<br /> If DBIsLocked Then 'v6.22<br /> olV_SubmitLog Now(), sProcess, "Failed - database(s) locked", 0, , logpthfn<br /> modEmail.SendEmail rcpt _<br /> , "DGFUK_CustomerReportingOS@DHL.com; DGFUK_CustomerReportingCT@DHL.com" _<br /> , OL_DefaultEmail _<br /> , "GBMNCWSA050 Automated Response: " & updname & " NOT updated" _<br /> , updname & " could not be updated, as per trigger sent by " & oMail.Sender & ", because a source database is locked (in use). Please contact bpm.gb@dhl.com for more information before sending another trigger." & vbLf & vbLf _<br /> & "Database locked:" & vbLf & DBdependents(d) 'v6.22 'v6.06<br /> Else<br /> pthfn = "\\ishare.dhl.com\sites\DGFUK\CR\CRP\CRP Control List v2.xlsm" 'v6.04<br /> Set olAppObj = XLlaunch(True)<br /> 'do anything else?<br /> Set WB = olAppObj.Workbooks.Open(FileName:=pthfn, ReadOnly:=True)<br /> 'the following is done automatically in WB<br /> 'wb.Sheets(1).Range("SelectedQuery").Value = macroname<br /> 'wb.Macros.CBDoThisMacro_Click True<br /> 'wb.Close SaveChanges:=True<br /> 'olAppObj.Quit<br /> t = CSng(Now() - t) 'time in decimal<br /> s = t * 60 * 60 * 24 'converts decimal to seconds<br /> olV_SubmitLog Now(), sProcess, "Processed", s, , logpthfn<br /> modEmail.SendEmail rcpt _<br /> , "DGFUK_CustomerReportingOS@DHL.com; DGFUK_CustomerReportingCT@DHL.com" _<br /> , OL_DefaultEmail _<br /> , "GBMNCWSA050 Automated Response: " & updname & " updated" _<br /> , updname & " updated and CSV updated on iShare, as per trigger sent by " & oMail.Sender 'v6.06<br /> olAppObj.Quit<br /> Set olAppObj = Nothing<br /> End If<br /> bDoArchive = True 'v6.22: NB: this is necessary otherwise infinite failure loop occurs (until DB is unlocked)<br /> GoTo CleanUp<br /> End If<br /><br />'------------------------------------------------------------------------------------------------------------<br />' FTP file transfer - reports from Logis - v6.15<br />'------------------------------------------------------------------------------------------------------------<br />sProcess = cLogisFTP<br /> If InStr(subj, " " & sProcess) > 0 And UCase(rcpt) = "NBC.COMPUTEROPS@DHL.COM" Then<br /> logpthfn = "\\GBMNCWSA050\Databases\Logis\LogisFTP log.csv"<br /> If InStr(UCase(sbody), "405 REPORT") > 0 Then<br /> updname = "Logis 405 database"<br /> pthfn = "\\GBMNCWSA050\Databases\Logis\405.accdb"<br /> macroname = "sweep_FTP_for_405()" 'runs VBA function<br /> End If<br /> Set olAppObj = run_Access("", pthfn, macroname)<br /> Set olAppObj = Nothing<br /> t = CSng(Now() - t) 'time in decimal<br /> s = t * 60 * 60 * 24 'converts decimal to seconds<br /> olV_SubmitLog Now(), sProcess, "Processed", s, , logpthfn<br /> modEmail.SendEmail OL_DefaultEmail _<br /> , _<br /> , _<br /> , "GBMNCWSA050 Automated Response: " & updname & " updated" _<br /> , updname & " updated, as per trigger sent by " & oMail.Sender<br /> bDoArchive = True<br /> GoTo CleanUp<br /> End If<br /><br />'------------------------------------------------------------------------------------------------------------<br />' GCCS PROPAGATION - v6.16<br />'------------------------------------------------------------------------------------------------------------<br />sProcess = cGCCSprop<br /> If InStr(subj, " " & sProcess) > 0 Then<br /> Sleep 20000 'this is necessary to ensure the upload to iShare is completed by triggerer before running process<br /> logpthfn = "\\GBMNCWSA050\Databases\GCCS\GCCS user propagation log.csv"<br /> updname = "GCCS user propagation"<br /> pthfn = "\\ishare.dhl.com\sites\DGFUK\Admin\GCCS\GCCS Users.xlsm"<br /> Set olAppObj = run_Excel(XLpth:="", XLfn:=pthfn, rxlOpenReadOnly:=True)<br /> Set olAppObj = Nothing<br /> t = CSng(Now() - t) 'time in decimal<br /> s = t * 60 * 60 * 24 'converts decimal to seconds<br /> olV_SubmitLog Now(), sProcess, "Processed", s, , logpthfn<br /> modEmail.SendEmail rcpt _<br /> , _<br /> , OL_DefaultEmail _<br /> , "GBMNCWSA050 Automated Response: " & updname & " completed" _<br /> , updname & " completed, as per trigger sent by " & oMail.Sender<br /> bDoArchive = True<br /> GoTo CleanUp<br /> End If<br /><br />'------------------------------------------------------------------------------------------------------------<br />' GCCS DB AND REPORTS - v6.19<br />'------------------------------------------------------------------------------------------------------------<br />sProcess = cGCCSreports<br /> If InStr(subj, " " & sProcess) > 0 Then<br /> Sleep 20000 'this is necessary to ensure the upload to iShare is completed by triggerer before running process<br /> logpthfn = "\\GBMNCWSA050\Databases\GCCS\GCCS reports log.csv"<br /> updname = "GCCS reports update"<br /> pthfn = "\\GBMNCWSA050\Databases\GCCS\GCCS MASTER v4.xlsm"<br /> Set olAppObj = run_Excel(XLpth:="", XLfn:=pthfn, rxlOpenReadOnly:=True)<br /> Set olAppObj = Nothing<br /> t = CSng(Now() - t) 'time in decimal<br /> s = t * 60 * 60 * 24 'converts decimal to seconds<br /> olV_SubmitLog Now(), sProcess, "Processed", s, , logpthfn<br /> modEmail.SendEmail rcpt _<br /> , _<br /> , OL_DefaultEmail _<br /> , "GBMNCWSA050 Automated Response: " & updname & " completed" _<br /> , updname & " completed, as per trigger sent by " & oMail.Sender<br /> bDoArchive = True<br /> GoTo CleanUp<br /> End If<br /><br /><br />CleanUp:<br /><br />If bDoArchive Then<br />'remove flag and Save<br /> With oMail<br /> .FlagStatus = False<br /> .FlagIcon = False<br /> .ReminderSet = False<br /> .UnRead = False<br /> .Save<br /> End With 'oMail<br /> OL_Simple_Archive Item<br />Else<br />'send failure notification<br /> modEmail.SendEmail Email_Recipient:=rcpt, Email_RecipientBCC:=OL_DefaultEmail, Email_Subject:=subj & " failed"<br />End If<br /><br />End Sub<br /><br />Private Function OL_SaveAttachment(Item As Outlook.MailItem _<br /> , pth As String, Optional ofn As String) As String<br />'v4.02 2013-08-06 14:49<br />'saves attachment(s) (requires pth to be set in parent macro)<br />'if AttCount > 1, renames if ofn specified (doesn't work for ZIP attachments)<br />'deletes attachment(s) from email ONLY if successful<br />'ZIP attachments MUST be named "Original Filename.csv.zip" and only contain that one file<br /><br />Dim OLapp As Outlook.Application<br />Set OLapp = CreateObject("Outlook.Application")<br />'Set OLapp = Application<br /><br />Dim myAttachments As Outlook.Attachments, AttName As String, AttCount As Byte, Att As Byte<br />Dim objItem As Outlook.MailItem<br /><br />Dim logDateTime As String, logPathFile As String, logResult As String<br />logResult = False<br /><br />Const zext As String = ".zip"<br /><br />With Item<br />'flag red, cleared later when completed<br />'NB: different code for Outlook 2007+<br />If val(Application.Version) < 12 Then<br />'2003 and before<br /> .FlagStatus = olFlagMarked<br /> .FlagIcon = olRedFlagIcon<br /> .Save<br />Else<br />'2007 and later<br /> .FlagStatus = olFlagMarked<br /> .FlagIcon = olRedFlagIcon<br /> .Save<br />End If<br />End With<br /><br />Set myAttachments = Item.Attachments<br />AttCount = myAttachments.Count<br />If AttCount = 0 Then GoTo ResultFalseNoAttachment<br />On Error GoTo ResultFalseNoAttachment<br />For Att = 1 To AttCount<br /> With myAttachments.Item(Att)<br /> On Error GoTo 0<br /> logDateTime = CStr(Now())<br /> <br />'save attachment as ZIP then unzip and process contents<br /> If Right(.DisplayName, 4) = zext Then<br /> <br /> 'attachment name is "Trimmed Text - Report Name.csv.zip"<br /> logPathFile = pth & .DisplayName<br /> 'On Error Resume Next<br /> If Dir(logPathFile) <> "" Then Kill logPathFile 'deletes old temporary zip file if still there<br /> 'On Error GoTo 0<br /> On Error GoTo ResultFalseZipFail<br /> .SaveAsFile logPathFile<br /> 'saved file is "Trimmed Text - Report Name.ext.zip"<br /> 'extract original file from temporary ZIP<br /> Zip7Sub pth, logPathFile, False '=0 is success<br /> On Error GoTo 0<br /> Kill logPathFile 'deletes temporary ZIP, no longer required<br /> 'extracted file is now "Report Name.ext" so change logPathFile<br /> logPathFile = pth & Replace(logPathFile, ".zip", "")<br /> 'logPathFile is now "Report Name.ext"<br /> 'rename logPathFile if ofn specified<br /> 'rename logPathFile if ofn specified<br /> If ofn <> "" Then<br /> On Error Resume Next 'only usually fails if file doesn't exist<br /> Kill pth & ofn<br /> On Error GoTo 0<br /> On Error GoTo ResultFalseRenameFail<br /> Name logPathFile As pth & ofn<br /> On Error GoTo 0<br /> OL_SaveAttachment = pth & ofn<br /> Else<br /> OL_SaveAttachment = logPathFile<br /> End If<br /> <br /> <br />'save attachment as original file (not zipped)<br /> Else<br /> <br /> 'attachment name is "Trimmed Text - Report Name.ext"<br /> On Error GoTo ResultFalseSaveFail<br /> logPathFile = pth & OL_fn_trim(.DisplayName)<br /> .SaveAsFile logPathFile<br /> 'rename logPathFile if ofn specified<br /> If ofn <> "" And pth & ofn <> logPathFile Then 'v4.02 was deleting if ofn same filename<br /> 'can only do this for one file<br /> If AttCount > 1 Then GoTo ResultFalseMultipleAttachmentsRenameFail<br /> On Error Resume Next<br /> Kill pth & ofn<br /> On Error GoTo 0<br /> On Error GoTo ResultFalseRenameFail<br /> Name logPathFile As pth & ofn<br /> On Error GoTo 0<br /> OL_SaveAttachment = pth & ofn<br /> Else<br /> OL_SaveAttachment = logPathFile<br /> End If<br /> 'saved file is "Report Name.csv"<br /> On Error GoTo 0<br /> <br /> End If<br /> <br /> 'completed with no errors<br /> logResult = "Success"<br /> End With 'Attachment<br />Next Att<br /><br />'only gets this far if no errors (including writing to log)<br />With Item<br />'remove flag and save<br /> .FlagStatus = False<br /> .FlagIcon = False<br /> .ReminderSet = False<br /> .UnRead = False<br /> .Save 'is this required? probably not - saves during move step<br />'remove attachment and move to relevant folder<br /> OL_Simple_Archive Item<br />End With<br /><br />GoTo ResultSubmit<br /><br />ResultFalseNoAttachment:<br />logResult = "Failure: report not attached to email"<br />GoTo ResultSubmit<br /><br />ResultFalseZipFail:<br />logResult = "Failure: ZIP attachment " & Att & " could not be saved/unzipped"<br />GoTo ResultSubmit<br /><br />ResultFalseMultipleAttachmentsRenameFail:<br />logResult = "Failure: multiple (" & AttCount & ") attachments, cannot be renamed to " & ofn<br />GoTo ResultSubmit<br /><br />ResultFalseRenameFail:<br />logResult = "Failure: saved attachment " & Att & " could not be renamed to " & ofn<br />GoTo ResultSubmit<br /><br />ResultFalseSaveFail:<br />logResult = "Failure: CSV attachment " & Att & " could not be saved"<br />GoTo ResultSubmit<br /><br />ResultFalseAttDelFail:<br />logResult = "Failure: attachment " & Att & " could not be removed"<br />GoTo ResultSubmit<br /><br /><br />ResultSubmit:<br />On Error GoTo 0<br />'report success/failure to log file<br />olV_SubmitLog logDateTime, logPathFile, logResult<br /><br /><br />'myOlApp.Quit<br />'Set myOlApp = Nothing<br /><br />End Function<br /><br />Private Function OL_fn_trim(ByVal DisplayName As String) As String<br />'v2.04 2012-11-08 09:19<br />'removes any of specified strings from attachment filename<br />'(could use Replace function instead)<br /><br />'specify TOTAL strings to remove<br />Const smax As Byte = 2<br />Dim sr(1 To smax) As String, s As Byte, is_pos As Byte, sr_len As Byte<br />'specify each string to remove<br />sr(1) = "Lookups - "<br />sr(2) = " en"<br /><br />OL_fn_trim = DisplayName<br />For s = 1 To smax<br /> sr_len = Len(sr(s))<br /> is_pos = InStr(OL_fn_trim, sr(s))<br /> If is_pos = 0 Then<br /> 'sr(s) not found in OL_fn_trim<br /> Exit For<br /> Else<br /> 'remove sr(s) from OL_fn_trim<br /> OL_fn_trim = Left(OL_fn_trim, is_pos - 1) & Mid(OL_fn_trim, is_pos + sr_len, Len(OL_fn_trim))<br /> End If<br />Next s<br /><br />End Function<br /><br />Private Function OL_v_URL(ByVal Item As Outlook.MailItem) As String<br />'v6.09 2013-09-20 13:00<br />'extracts "|url="http://specificurl.com/filename.ext"<br />' --> if not found, tries to extract "HYPERLINK " from plain text email<br />' --> if not found, extracts <a href="url"> from HTML (not tested)<br /><br />'first check for user-specified URL variable, quit if found<br />OL_v_URL = OL_v_var(Item, "url")<br />If OL_v_URL <> "" Then Exit Function<br /><br />Dim a As Long, b As Long, c As Integer, sbody As String<br />Const ptnHLNK As String = "HYPERLINK """<br />Const ptnHEnd As String = """" 'was """CSV", file type suffix is not relevant, just look for quot mark after URL<br />Const ptnATag As String = "<a href="""<br />Const ptnAEnd As String = """>"<br />Const ptnHTTP As String = "http" 'need this to validate HTML hyperlink extraction. NB: may be http:// or https:// in valid URL<br />Const ptnFwin As String = "https://forwin.dhl.com/cognos8/cgi-bin/cognosisapi.dll" 'prefix added to "?b=" shortened URL<br /><br />'extract URL from Body Text, quit if found<br />sbody = Item.Body<br />a = InStr(sbody, ptnHLNK) 'finds FIRST hyperlink, Forwin always adds this to end<br />If a > 0 Then<br /> c = a<br /> Do Until c = 0<br /> c = InStr(a + 1, sbody, ptnHLNK) 'finds NEXT hyperlink, Forwin always adds to END<br /> If c <> a And c <> 0 Then a = c<br /> Loop<br /> a = a + Len(ptnHLNK)<br /> b = InStr(a, sbody, ptnHEnd)<br /> c = b - a<br /> OL_v_URL = Mid(sbody, a, c)<br />End If<br />If OL_v_URL <> "" And Left(OL_v_URL, Len(ptnHTTP)) = ptnHTTP Then Exit Function 'second test helps when re-sending email to yourself, Outlook will convert UNC into hyperlinks<br /><br />'extract URL from HTML links, quit if found - v6.09<br />sbody = Item.HTMLBody<br />a = InStr(sbody, ptnATag)<br />If a > 0 Then<br />'HTML A tag found<br /> c = a<br /> Do Until c = 0 'find LAST hyperlink, Forwin always adds to end<br /> c = InStr(a + 1, sbody, ptnATag) 'finds NEXT hyperlink<br /> If c <> a And c <> 0 Then a = c<br /> Loop<br /> a = a + Len(ptnATag)<br /> b = InStr(a, sbody, ptnAEnd)<br /> c = b - a<br /> OL_v_URL = Mid(sbody, a, c)<br /> 'URL from Forwin sometimes excludes Forwin site DLL location for report downloads, so add that manually<br /> If Left(OL_v_URL, Len(ptnHTTP)) <> ptnHTTP Then<br /> OL_v_URL = ptnFwin & OL_v_URL<br /> End If<br /> 'cleanup<br /> OL_v_URL = Replace(OL_v_URL, "&amp;", "&")<br />End If<br /><br />End Function<br /><br />Private Function OL_v_var(ByVal Item As Outlook.MailItem _<br /> , ByVal vvar As String) As String<br />'v6.09 2013-09-20 12:17<br />'retrieves specified variable from email body text<br />'vvar is "pth", will be amended to "|pth="<br />'variable must be surrounded by quote marks, i.e. |pth="http://somepath"<br />'returns no string if vvar not found<br /><br />Dim iStartQuot As Integer, iEndQuot As Integer, iNextPipe As Integer<br />Dim btxt As String 'bodytext<br />Dim oMail As Outlook.MailItem<br />Set oMail = Application.Session.GetItemFromID(Item.EntryID)<br />btxt = oMail.Body<br />Const vpipe As String = "|" 'Chr(124)<br />Const vequa As String = "=" 'Chr(61)<br />Const vquot As String = """" 'Chr(34)<br />Const ptnHLNK As String = "HYPERLINK """<br />Const ptnFILE As String = "file:///"<br />vvar = vpipe & vvar & vequa & vquot 'now searching for "|pth=" not "pth"<br /><br />iStartQuot = InStr(btxt, vvar) 'position of vvar<br />If iStartQuot = 0 Then<br />'error, variable with pipe "|pth=" not found, exit<br /> OL_v_var = vbNullString<br /> Exit Function<br />End If<br /><br />iStartQuot = iStartQuot + Len(vvar) 'position AFTER opening vquot (marks start of variable)<br />If Mid(btxt, iStartQuot, Len(ptnHLNK)) = ptnHLNK Then 'v6.09 workaround for forwarding triggers to retrigger, b/c Outlook converts UNC pth to hyperlink<br /> iStartQuot = iStartQuot + Len(ptnHLNK)<br />End If<br />iEndQuot = InStr(iStartQuot + 1, btxt, vquot) 'vEnd = position of NEXT vquot AFTER vvar (marks end of variable)<br />iNextPipe = InStr(iStartQuot + 1, btxt, vpipe) 'position of next pipe (for validity check)<br /><br />If iEndQuot = 0 Or (iNextPipe > 0 And iEndQuot > iNextPipe) Then<br />'error, variable not surrounded by "", exit<br /> OL_v_var = vbNullString<br /> Exit Function<br />End If<br /><br />OL_v_var = Replace(Mid(btxt, iStartQuot, iEndQuot - iStartQuot), ptnFILE, "") 'v6.09 workaround for forwarding triggers to retrigger, b/c Outlook converts UNC pth to hyperlink<br /><br />End Function<br /><br />Function OL_GetCurrentItem() As Object<br />'source: http://www.outlookcode.com/article.aspx?id=49<br /> <br /> Dim objApp As Outlook.Application<br /> Set objApp = Application<br /> <br /> On Error Resume Next<br /> Select Case TypeName(objApp.ActiveWindow)<br /> Case "Explorer"<br /> Set OL_GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1)<br /> Case "Inspector"<br /> Set OL_GetCurrentItem = objApp.ActiveInspector.CurrentItem<br /> Case Else<br /> ' anything else will result in an error, which is<br /> ' why we have the error handler above<br /> End Select<br /> <br /> Set objApp = Nothing<br /><br />End Function<br /><br />Sub OL_Simple_Archive(Item As Outlook.MailItem)<br />'v6.10 2013-09-23 10:36<br />'puts email in folder according to email subject, deletes attachment(s), marks read & flags complete<br />'NB: Outlook rule should be set to prevent email replies on this subject from being processed this way<br /><br />Dim OLapp As Outlook.Application<br />'Set OlApp = CreateObject("Outlook.Application")<br />Set OLapp = Application<br /><br />Dim objNS As Outlook.NameSpace, objFolder As Outlook.MAPIFolder, ParentFolder As Outlook.MAPIFolder<br />Set objNS = OLapp.GetNamespace("MAPI")<br />Set objFolder = objNS.Folders(OL_MYmbx).Folders("Inbox")<br /><br />Dim blnFolderCreated As Boolean<br /><br />'identify subfolder from CAPITALISED SUBJECT PREFIX<br />'e.g. "BPMAUTORUN ANYREPORT FORWIN MAPPING Free Text" goes in BPMAUTORUN > ANYREPORT > FORWIN > MAPPING > Free Text<br />Dim subj As String, s As Integer, olFolderName As String, CapturePrefix As String<br /><br />Dim oMail As Outlook.MailItem<br />Set oMail = Application.Session.GetItemFromID(Item.EntryID)<br />subj = SP_fn_val(oMail.Subject, "") 'v6.10 fixes issue with slash etc. in folder name<br /><br />'capture "Report: " (generic scheduled reports)<br /> CapturePrefix = "Report: "<br /> If InStr(subj, CapturePrefix) Then<br /> 'create/use FOLDERNAME<br /> olFolderName = "REPORTS"<br /> Set ParentFolder = objFolder<br /> blnFolderCreated = OL_Create_objFolder(olFolderName, ParentFolder)<br /> If blnFolderCreated = True Then Set ParentFolder = Nothing<br /> Set objFolder = ParentFolder.Folders(olFolderName)<br /> subj = Mid(subj, Len(CapturePrefix) + 1, Len(subj))<br /> End If<br /><br />s = InStr(subj, " ")<br />Do While s > 0<br /> s = InStr(subj, " ") 'v6.09 bugfix for 1-word subfolders e.g. "ANYREPORT FORWIN TSP Routing"<br /> If s = 0 Then s = Len(subj) + 1<br /> olFolderName = Left(subj, s - 1)<br /> If OL_UpperCase(olFolderName) Then<br /> 'create/use FOLDERNAME<br /> Set ParentFolder = objFolder<br /> blnFolderCreated = OL_Create_objFolder(olFolderName, ParentFolder)<br /> If blnFolderCreated = True Then Set ParentFolder = Nothing<br /> Set objFolder = objFolder.Folders(olFolderName)<br /> If olFolderName = "DATABASE" Then Exit Do 'v6.10 bugfix for v6.09 doing DATABASE triggers<br /> subj = Mid(subj, s + 1, Len(subj))<br /> Else<br /> 'finished extracting CAPSFOLDERNAMES, use remaining free text as destination folder<br /> olFolderName = subj<br /> Set ParentFolder = objFolder<br /> blnFolderCreated = OL_Create_objFolder(olFolderName, ParentFolder)<br /> If blnFolderCreated = True Then Set ParentFolder = Nothing<br /> Set objFolder = objFolder.Folders(olFolderName)<br /> s = 0<br /> End If<br />Loop<br /><br />Set oMail = Nothing<br /><br />'delete any attachments from mail (saves on mailbox storage)<br />Dim AttCount As Byte, Att As Byte<br />On Error Resume Next<br />If Item.Attachments.Count > 0 Then<br /> For Att = 1 To Item.Attachments.Count<br /> Item.Attachments.Item(Att).Delete<br /> Next Att<br />End If<br />On Error GoTo 0<br /><br /><br />'mark unread, flag complete, move to specified subfolder<br />With Item<br />On Error Resume Next<br /> .UnRead = False<br /> .FlagStatus = olFlagComplete<br /> .Save<br /> .Move objFolder 'on error, check whether blnFolderCreated is True/False, usually False means it already exists!<br />On Error GoTo 0<br />End With<br /><br />End Sub<br /><br />Private Function OL_Create_objFolder(FolderName As String _<br /> , Optional ParentFolder As Outlook.MAPIFolder) As Boolean<br />'v2.11 2013-01-10 13:15<br /><br />Dim olOutlook As Outlook.Application<br /><br />On Error GoTo ErrorHandler<br />Set olOutlook = Application<br />'if using outside Outlook e.g. within Excel:<br />'Set olOutlook = CreateObject("Outlook.Application")<br />If ParentFolder Is Nothing Then<br /> Dim ns As Outlook.NameSpace<br /> Set ns = olOutlook.GetNamespace("MAPI")<br /> Set ParentFolder = ns.GetDefaultFolder(olFolderInbox)<br />End If<br />ParentFolder.Folders.Add FolderName<br />On Error GoTo 0<br /><br />Set olOutlook = Nothing<br />Set ns = Nothing<br />Set ParentFolder = Nothing<br /><br />OL_Create_objFolder = True<br />Exit Function<br /><br />ErrorHandler:<br />On Error GoTo 0<br />OL_Create_objFolder = False<br /><br />End Function<br /><br />Private Function OL_UpperCase(stringToCheck As String) As Boolean<br />'v3.03 2013-07-19 18:21<br />'source: http://www.freevbcode.com/ShowCode.asp?ID=5198<br /> OL_UpperCase = StrComp(stringToCheck, UCase(stringToCheck), vbBinaryCompare) = 0<br />End Function<br /><br />Private Function OL_LowerCase(stringToCheck As String) As Boolean<br />'v3.03 2013-07-19 18:21<br />'source: http://www.freevbcode.com/ShowCode.asp?ID=5198<br /> OL_LowerCase = StrComp(stringToCheck, LCase(stringToCheck), vbBinaryCompare) = 0<br />End Function<br /><br />Function olV_SubmitLog(ByVal logDateTime As String, ByVal logPathFileProcessed As String _<br /> , ByVal logResult As String _<br /> , Optional ByVal logTimeTaken As Integer, Optional ByVal logRecipientEmail As String _<br /> , Optional ByVal logToPathFilename As String)<br />'v6.22 2013-12-02 17:14<br />'also sends email to administrator/triggerer on success/failure<br /><br />If logToPathFilename = "" Then logToPathFilename = LogFolder & LogFileName 'default log file location, unless specified<br />'commented, v6.04 creates log<br />'If Dir(logToPathFilename) = vbNullString Then MsgBox "CSV not found at " & logToPathFilename<br /><br />On Error Resume Next<br /><br />Dim logmsg(1 To 5) As String<br />logmsg(1) = Chr(34) & logDateTime & Chr(34) & "," 'timestamp<br />logmsg(2) = Chr(34) & logPathFileProcessed & Chr(34) & "," 'file that succeeded/failed, required, but can be "" if not relevant<br />logmsg(3) = Chr(34) & logResult & Chr(34) & "," 'result<br />If logTimeTaken > 0 Then logmsg(4) = logTimeTaken & "," Else logmsg(4) = "," 'time taken in seconds<br />If logRecipientEmail <> "" Then logmsg(5) = Chr(34) & logRecipientEmail & Chr(34) 'trigger sender (if specified)<br /><br />'append log file (CSV)<br />Dim echostring As String<br />If Dir(logToPathFilename) = "" Then<br /> echostring = "cmd /c echo " _<br /> & """Date"",""Routine"",""Result"",""Duration"",""Triggered By Email""" _<br /> & " >> " _<br /> & Chr(34) & logToPathFilename & Chr(34)<br /> Shell echostring, vbHide<br /> Dim p As Byte<br /> Do While Dir(logToPathFilename) = "" And p < 100<br /> Sleep 100 'v6.04 waits to create logToPathFilename<br /> p = p + 1 'v6.04 stops infinite loop<br /> Loop<br />End If<br /><br />logToPathFilename = Chr(34) & logToPathFilename & Chr(34) 'adds speech marks for CSV and result notification<br /><br />If p < 100 Then<br /> echostring = "cmd /c echo " _<br /> & logmsg(1) _<br /> & logmsg(2) _<br /> & logmsg(3) _<br /> & logmsg(4) _<br /> & logmsg(5) _<br /> & " >> " _<br /> & logToPathFilename<br /> Shell echostring, vbHide<br />Else 'v6.04, couldn't add to log<br /> logToPathFilename = logToPathFilename & vbLf & "NB: couldn't create log, check this path is correct"<br />End If<br /><br />'send result email<br />If logRecipientEmail <> "" Then<br /> OL_SendEmail logRecipientEmail, "", OL_MYmbx, "GBMNCWSA050 Automated Response: " & logPathFileProcessed & " " & logResult, "The triggered update request is now completed. Result: " & logResult & vbLf & vbLf & logToPathFilename, False<br />End If<br /><br />'On Error GoTo 0 'only required if causing problems<br /><br />End Function<br /><br />Sub OL_test()<br /><br />With OL_GetCurrentItem<br />'flag as Completed and Save<br /> .FlagStatus = False<br /> .FlagIcon = False<br /> .ReminderSet = False<br /> .UnRead = False<br /> .Save<br />End With<br /><br />End Sub<br /><br />Function OL_SendEmail(ByVal Email_Recipient As String, Optional ByVal Email_RecipientCC As String _<br /> , Optional ByVal Email_RecipientBCC As String, Optional ByVal Email_Subject As String _<br /> , Optional ByVal Email_BodyText As String, Optional ByVal DisplayMsg As Boolean = False _<br /> , Optional AttachmentPath) As Byte<br />'code matched to modEmail.SendEmail<br />'v1.06 2013-09-02 10:56<br />'results: 0=success, 1=fail<br />'original source: http://support.microsoft.com/kb/161088<br />'v1.05 bugfix: http://stackoverflow.com/questions/13019651/automated-email-generation-not-resolving-multiple-recipients<br /><br />On Error GoTo SendEmailError<br /><br />Dim objOutlook As Object 'Outlook.Application<br />'Dim objOutlookMsg 'As Object 'Outlook.MailItem<br />Dim objOutlookRecip As Object 'Outlook.Recipient<br />Dim objOutlookAttach As Object 'Outlook.Attachment<br />'http://stackoverflow.com/questions/13019651/automated-email-generation-not-resolving-multiple-recipients<br />Dim EmailList As Variant, NumEmails As Long, AddEmailLoop As Long<br /><br />' Create the Outlook session.<br />If InStr(Application.Name, "Outlook") = 0 Then<br /> Set objOutlook = CreateObject("Outlook.Application")<br />Else<br /> Set objOutlook = Application<br />End If<br /><br />' Create the message.<br />'Set objOutlookMsg = objOutlook.CreateItem(0) 'olMailItem<br />Set objOutlook = objOutlook.CreateItem(0) 'olMailItem<br /><br />'With objOutlookMsg<br />With objOutlook<br /> ' Add the To recipient(s) to the message.<br /> If Email_Recipient = "" Then<br /> Set objOutlookRecip = .Recipients.Add(cDefaultEmail) 'for testing/blunt force only<br /> Else<br /> 'http://stackoverflow.com/questions/13019651/automated-email-generation-not-resolving-multiple-recipients<br /> Email_Recipient = Replace(Email_Recipient, ";", "; ") 'v1.06<br /> EmailList = Split(Email_Recipient, ";")<br /> NumEmails = UBound(EmailList)<br /> For AddEmailLoop = 0 To NumEmails<br /> Set objOutlookRecip = .Recipients.Add(EmailList(AddEmailLoop))<br /> objOutlookRecip.Type = 1 'olTo<br /> objOutlookRecip.Resolve<br /> Next<br /> End If<br /><br /> ' Add the CC recipient(s) to the message.<br /> If Email_RecipientCC <> "" Then<br /> Email_RecipientCC = Replace(Email_RecipientCC, ";", "; ") 'v1.06<br /> EmailList = Split(Email_RecipientCC, "; ")<br /> NumEmails = UBound(EmailList)<br /> For AddEmailLoop = 0 To NumEmails<br /> Set objOutlookRecip = .Recipients.Add(EmailList(AddEmailLoop))<br /> objOutlookRecip.Type = 2 'olCC<br /> objOutlookRecip.Resolve<br /> Next<br /> End If<br /> <br /> ' Add the BCC recipient(s) to the message.<br /> If Email_RecipientBCC <> "" Then<br /> Email_RecipientBCC = Replace(Email_RecipientBCC, ";", "; ") 'v1.06<br /> EmailList = Split(Email_RecipientBCC, "; ")<br /> NumEmails = UBound(EmailList)<br /> For AddEmailLoop = 0 To NumEmails<br /> Set objOutlookRecip = .Recipients.Add(EmailList(AddEmailLoop))<br /> objOutlookRecip.Type = 3 'olBCC<br /> objOutlookRecip.Resolve<br /> Next<br /> End If<br /><br /> ' Set the Subject, Body, and Importance of the message.<br /> .Subject = Email_Subject<br /> .Body = Email_BodyText & vbCrLf & vbCrLf<br /> .Importance = 2 'olImportanceHigh 'High importance<br /><br /> ' Add attachments to the message.<br /> If Not IsMissing(AttachmentPath) Then<br /> Set objOutlookAttach = .Attachments.Add(AttachmentPath)<br /> End If<br /><br /> ' Resolve each Recipient's name. 'v1.06 now resolved separately on addition<br />' For Each objOutlookRecip In .Recipients<br />' objOutlookRecip.Resolve<br />' Next<br /><br /> ' Should we display the message before sending?<br /> If DisplayMsg Then<br /> .Display<br /> Else<br /> .Save<br /> .Send<br /> End If<br />End With<br /><br />Set objOutlook = Nothing<br />OL_SendEmail = 0 'no error<br />Exit Function<br /><br />SendEmailError:<br />OL_SendEmail = 1 'general failure<br />End Function<br /></span></span></span></blockquote>
baldmosher™http://www.blogger.com/profile/11281471751951639119noreply@blogger.com0Stretford M17 1QA, UK53.4609149 -2.318959400000039853.4514614 -2.3391294000000395 53.4703684 -2.29878940000004tag:blogger.com,1999:blog-7264479838117802346.post-55783512391898790562013-08-05T09:20:00.000-07:002014-01-16T06:44:34.933-08:00VBA Modules: Excel: xlUtils v2.19<br />
<a href="http://baldywritten.blogspot.com/2013/08/vba-modules-modzip-v502aaa.html" target="_blank">Read this</a> for full information on these modules<br />
<br />
This module is my real timesaver. A bunch of Excel functions that I use all the time and as I can't stand repitition, I've automated and streamlined most of what I do. Too many functions to explain here, but most are simple and self-explanatory. Some are stolen from other resources, but most I've just thrown together myself because the vanilla "solutions" online weren't very n00b-friendly, or I just couldn't understand why someone would write half a solution and not spend an extra 10 minutes coding it properly. I've posted a lot of these on various support functions, so if you see my name around the place with some code attached, you'll probably find my suggested code has found its way here, after a bit of tweaking.<br />
<br />
Note that this uses <a href="http://www.cpearson.com/excel/keytest.aspx" target="_blank">Chip Pearson's <b>modKeyState</b></a> module.<br />
<br />
<blockquote class="tr_bq">
<span style="font-size: x-small;"><span style="font-family: "Courier New",Courier,monospace;"><span style="font-size: xx-small;">'xlUtils<br />'v2.19 2014-01-16 13:01<br /><br />'===========================================================================<br />' HELP CONTACT<br />'===========================================================================<br />' Code is provided without warranty and can be stolen and amended as required.<br />' Tom Parish<br />' TJP@tomparish.me.uk<br />' http://baldywrittencod.blogspot.com<br />' DGF Help Contact: see BPMHelpContact module<br />'=========================================================================<br /><br />'===========================================================================<br />' xlUtils<br />'===========================================================================<br />' various MS Excel wizardry<br /><br />'===========================================================================<br />' Additional modules required:<br />'===========================================================================<br />' modKeyState<br /><br />'=========================================================================<br />' VERSION HISTORY<br />'=========================================================================<br />'v2.19 2014-01-16 13:01 - xlU_SafeToQuitExcel: option to quit/close automatically<br />'v2.18 2013-12-10 17:04 - xlU_SafeToQuitExcel: bugfix in numbers where PERSONAL.XLSB is not open<br />' v2.17 xlU_Transfer_Ranges: bugfix<br />' v2.16 xlU_Ranges_Change_Scope: bugfix when converting to Workbook<br />' v2.15 added xlU_WorkbookIsReadOnly<br />' v2.14 added xlU_SafeToQuitExcel<br />' v2.13 added xlU_Ranges_Change_Scope<br />' v2.12 added xlU_UpdateLinks<br />' v2.11 added xlU_Transfer_Ranges<br />' v2.10 added xlU_Convert_File<br />' v2.09 added xlU_ValidationList<br />' v2.08 added xlU_Export_Single_Sheets<br />' added xlU_Protect_All_Sheets<br />' v2.07 added xlU_BreakLinks<br />' v2.06 xlU_Ranges_Set_To_Column_1_Data_Rows: bugfix (private const)<br />' v2.05 added xlU_Numeric_To_Text<br />' xlU_Clean_Special: removes needless _ from end of string<br />' xlU_Clean_Special: bugfix, VB removes '<br />' removed xlU_Check_Special (now xlSharePoint.SP_Check_Special)<br />' added from xlRanges: xlU_Ranges_Add_Named_After_Column_Headers<br />' added from xlRanges: xlU_Ranges_Set_To_Column_1_Data_Rows<br />' v2.04 added Private constants<br />' v2.03b added xlU_Pause_for_Timeout (BETA - doesn't work?)<br />' v2.02 added xlU_Find_And_Replace_Text<br />' v2.01 bugfix xlU_Check_Special; annotations changed<br />' v2.00 option to specify wb/ws in various macros<br />' improved xlU_Clean_Special code and annotations<br />' improved xlU_EmptyFolder warning msgbox<br />' improved xlU_Remove_Spaces warning msgbox<br />' v1.09 improved xlU_Remove_Spaces<br />' Capitalised Macro Names<br />' removed Public from Subs and Functions<br />' annotations improved<br />' v1.08 bugfix in xlU_Check_Special<br />' improved xlU_SheetExists<br />' v1.07 added xlU_Check_Special<br />' added xlU_RemoveAllConnections<br />' improved xlU_removespaces<br />' v1.06 added xlU_reset_comment_sizes<br />' v1.05 xlU_cut_multiple_rows_to_new_location<br /><br />Option Explicit<br /><br />Private Const cSpc As String = " "<br />Private Const cFsl As String = "/"<br />Private Const cBsl As String = "\"<br />'Private Const cHyp As String = "-"<br />'Private Const cAst As String = "*"<br />'Private Const cPrd As String = "."<br />'Excel <=2003<br />Private Const xxls As String = ".xls" 'FileFormat:=56, Office 2003 macro enabled workbook<br />Private Const xxlt As String = ".xlt" 'FileFormat:=??, Office 2003 macro enabled template<br />Private Const x2k3 As String = " (2003)" 'added to filename during zip upload, i.e. "Report Name (2003).zip"<br />'Excel >2003<br />Private Const xxlx As String = ".xlsx" 'FileFormat:=51, Office 2007/10 workbook<br />Private Const xxlm As String = ".xlsm" 'FileFormat:=52, Office 2007/10 macro enabled workbook<br />Private Const xxlb As String = ".xlsb" 'FileFormat:=??, Office 2007/10 binary workbook<br />Private Const xxtm As String = ".xltm" 'FileFormat:=??, Office 2007/10 macro enabled template<br />'Other<br />Private Const xcsv As String = ".csv" 'FileFormat:=6, CSV file<br /><br />Enum xluScopeChangeType<br /> xluWorksheetToWorkbook<br /> xluWorkbookToWorksheet<br />End Enum<br /><br /><br />Sub xlU_SelectLotsOfSheets(ByVal str As String, Optional ByRef wb As Workbook)<br />'v2.00 2013-05-22 11:51<br />'selects all sheets where ws.Name contains str<br />'or selects all if str = ""<br /><br />If wb Is Nothing Then Set wb = ActiveWorkbook<br /><br />Dim blnASU As Boolean<br />blnASU = Application.ScreenUpdating<br />Application.ScreenUpdating = False<br /><br />Dim blnreplace As Boolean, sh As Worksheet<br />blnreplace = True<br />For Each sh In wb.Worksheets<br /> If InStr(1, sh.Name, str) Or str = "" Then<br /> sh.Select blnreplace<br /> blnreplace = False<br /> End If<br />Next sh<br /><br />Application.ScreenUpdating = blnASU<br /><br />End Sub<br /><br />Sub xlU_ShowAllObjects(Optional ByRef ws As Worksheet)<br />'v2.00 2013-05-22 11:51<br />'shows all objects on sheet and sets to Move and Size with cells<br />'(permits deletion of columns if hidden comments prevent this)<br /><br />If ws Is Nothing Then Set ws = ActiveSheet<br /><br />Dim blnASU As Boolean<br />blnASU = Application.ScreenUpdating<br />Application.ScreenUpdating = False<br /><br />Dim s As Shape<br />On Error Resume Next<br />For Each s In ws.Shapes<br /> s.Placement = xlMoveAndSize<br />Next<br /><br />Application.ScreenUpdating = blnASU<br /><br />End Sub<br /><br />Sub xlU_DeleteAllObjects(Optional ByRef ws As Worksheet)<br />'v2.00 2013-05-22 11:51<br /><br />If ws Is Nothing Then Set ws = ActiveSheet<br /><br />Dim blnASU As Boolean<br />blnASU = Application.ScreenUpdating<br />Application.ScreenUpdating = False<br /><br />Dim s As Shape<br />On Error Resume Next<br />For Each s In ws.Shapes<br /> s.Delete<br />Next<br /><br />Application.ScreenUpdating = blnASU<br /><br />End Sub<br /><br />Sub xlU_ShowAllSheets(Optional ByRef wb As Workbook)<br />'v2.00 2013-05-22 11:51<br /><br />If wb Is Nothing Then Set wb = ActiveWorkbook<br /><br />Dim blnASU As Boolean<br />blnASU = Application.ScreenUpdating<br />Application.ScreenUpdating = False<br /><br />Dim s As Byte<br />For s = 1 To wb.Sheets.Count<br /> wb.Sheets(s).Visible = True<br />Next s<br /><br />Application.ScreenUpdating = blnASU<br /><br />End Sub<br /><br />Function xlU_Remove_Spaces(Optional ByVal str As String) As String<br />'v2.00 2013-05-22 12:23<br />'...from END of string only<br />'works through Selection range if str not specified<br /><br />Const pp As String = "WARNING: cannot undo this action"<br />Const tt As String = "xlU_Remove_Spaces"<br />If MsgBox(pp, vbOKCancel Or vbCritical, tt) = vbCancel Then Exit Function<br /><br />Dim bln As Boolean<br />bln = Application.ScreenUpdating<br />Application.ScreenUpdating = False<br /><br />If str <> vbNullString Then<br /> Do Until Not Right(str, 1) = " "<br /> str = Left(str, Len(str) - 1)<br /> Loop<br /> xlU_Remove_Spaces = str<br />Else<br />'string not specified, so work on all cells in Selection<br /> Dim r As Range<br /> For Each r In Selection.Cells<br /> Do Until Not Right(r.Value, 1) = " "<br /> r.Value = Left(r.Value, Len(r) - 1)<br /> Loop<br /> Next r<br />End If<br /><br />Application.ScreenUpdating = bln<br /><br />End Function<br /><br />Sub xlU_Exit_Design_Mode()<br />'v1.00<br />'always exits<br />'!! running any blank macro will also do this?<br /><br />With Application.CommandBars("Exit Design Mode").Controls(1)<br /> If .State = msoButtonDown Then .Execute<br />End With<br /> <br />End Sub<br /><br />Sub xlU_Enter_Design_Mode()<br />'v1.00<br />'!! sometimes enters, sometimes toggles?<br /><br />Application.CommandBars("Exit Design Mode").Controls(1).Execute<br />'Application.CommandBars.FindControl(ID:=1605).Execute<br /> <br />End Sub<br /><br />Sub xlU_EmptyFolder(ByVal fdr As String, Optional ByVal AlsoRmDir As Boolean _<br /> , Optional ByVal DoMsgs As Boolean)<br />'v2.00 2013-05-22 12:22<br />'delete all files from specified folder [and remove folder]<br /><br />Const pp As String = "WARNING: cannot undo this action"<br />Const tt As String = "xlU_EmptyFolder"<br />If MsgBox(pp, vbOKCancel Or vbCritical, tt) = vbCancel Then Exit Sub<br /><br />Const cBsl As String = "\"<br />Const cFsl As String = "/"<br />Const cSdS As String = "*.*"<br />Const emsg As String = "xlU_EmptyFolder failed: path not valid, no slashes"<br /><br />Dim fn As String, sl As String<br />If InStr(fdr, cBsl) > 0 Then sl = cBsl<br />If InStr(fdr, cFsl) > 0 Then sl = cFsl<br />If sl = vbNullString Then<br /> If DoMsgs = True Then MsgBox emsg, vbCritical, tt<br /> Exit Sub<br />End If<br /><br />If Right(fdr, 1) <> sl Then fdr = fdr & sl<br /><br />fn = Dir(fdr & cSdS)<br />Do While fn <> vbNullString<br />On Error Resume Next<br /> Kill fdr & fn<br />On Error GoTo 0<br /> fn = Dir<br />Loop 'all files in folder<br /><br />If AlsoRmDir = True Then RmDir fdr<br /><br />End Sub<br /><br />Function xlU_Clean_Special(ByVal str As String, Optional ByVal CropLength As Boolean = True _<br /> , Optional ByVal OnlyFilename As Boolean _<br /> , Optional ByVal OnlyVBObjectName As Boolean) As String<br />'v2.05 2013-07-25 19:31<br />'removes invalid special characters from path/file/VBObject name string<br />' CropLength:=True stops message box warnings and autocrops string to 128 chars<br />' OnlyFilename:=True also removes slashes \ /<br />' OnlyVBObjectName:=True also removes slashes, spaces, hyphens, commas, periods<br /><br />'constants (commented if defined below)<br />'Const scUS As String = "_"<br />Const VBNameLength = 35<br />Const SharePointFileNameLength = 128<br />'consistency checks are done below for the following constants<br />Const uniMin As Byte = 0 'first universally forbidden character, MUST BE ZERO<br />Const uniMax As Byte = 13 'last universally forbidden character, number set according to how many forbidden characters<br />Const slaFSL As Byte = 14 'first slash, always Fsl, AWAYS uniMax+1<br />Const slaBSL As Byte = 15 'last slash, always Bsl, AWAYS slaFSL+1<br />Const vboMin As Byte = 16 'first VBA forbidden character, AWAYS slaBSL+1<br />Const vboMax As Byte = 22 'last VBA forbidden character, number set according to how many forbidden characters<br /><br />Dim b As Integer, c As Integer, pp As String<br />Const tt As String = "ERROR in xlU_Clean_Special"<br />Dim sc(uniMin To vboMax) As String<br />sc(uniMin) = "~" 'unimin referenced specifically below<br />sc(uniMin + 1) = Chr(34) 'Chr(34) = " (quotemark)<br />sc(uniMin + 2) = "#"<br />sc(uniMin + 3) = "%"<br />sc(uniMin + 4) = "&"<br />sc(uniMin + 5) = "*"<br />sc(uniMin + 6) = ":"<br />sc(uniMin + 7) = "<"<br />sc(uniMin + 8) = ">"<br />sc(uniMin + 9) = "?"<br />sc(uniMin + 10) = "{"<br />sc(uniMin + 11) = "|"<br />sc(uniMin + 12) = "}"<br />If uniMin + 13 <> uniMax Then 'consistency check<br /> pp = "uniMin + 13 <> uniMax"<br /> MsgBox pp, vbCritical, tt<br /> End<br />End If<br />sc(uniMax) = ".."<br />'slashes for filenames and VB Object names (NOT paths)<br />sc(slaFSL) = "/"<br />sc(slaBSL) = "\"<br />'hyphen & space & comma & period & brackets & apostrophe for VB Object names<br />sc(vboMin) = "-"<br />sc(vboMin + 1) = " "<br />sc(vboMin + 2) = ","<br />sc(vboMin + 3) = "."<br />sc(vboMin + 4) = "("<br />sc(vboMin + 5) = "'"<br />If vboMin + 6 <> vboMax Then 'consistency check<br /> pp = "vboMin + 6 <> vboMax"<br /> MsgBox pp, vbCritical, tt<br /> End<br />End If<br />sc(vboMax) = ")"<br /><br />'remove special characters from all<br />For b = uniMin To uniMax<br /> str = Replace(str, sc(b), vbNullString)<br />Next b<br /><br />'check filename length (length AFTER the LAST slash max 128 chars)<br />b = InStr(1, str, sc(slaFSL)) 'look for fwd slash<br />If b > 0 Then<br /> str = Replace(str, sc(slaBSL), sc(slaFSL)) 'remove all back slashes<br /> Do Until b = 0 'until last slash found<br /> c = b 'c is position of last slash<br /> b = b + 1 'next position<br /> b = InStr(b, str, sc(slaFSL)) 'next position<br /> Loop<br />Else 'no fwd slashes<br /> b = InStr(1, str, sc(slaBSL)) 'look for back slash<br /> If b > 0 Then<br /> str = Replace(str, sc(slaFSL), sc(slaBSL)) 'remove all fwd slashes<br /> Do Until b = 0 'until last slash found<br /> c = b 'c is position of last slash<br /> b = b + 1 'next position<br /> b = InStr(b, str, sc(slaBSL)) 'next position<br /> Loop<br /> End If<br />End If<br />'c is position of last slash, or 0 if no slashes<br />If Len(str) - c > SharePointFileNameLength Then<br /> If CropLength = True Then<br /> str = Left(str, VBNameLength)<br /> Else<br /> pp = "WARNING: filename > " & SharePointFileNameLength & " chars" & vbLf & vbLf & str<br /> MsgBox pp, vbCritical, tt<br /> End<br /> End If<br />End If<br /><br />If OnlyFilename = True Or OnlyVBObjectName = True Then<br />'swap all slashes for spaces - NOT suitable for paths!<br /> For b = slaFSL To slaBSL<br /> c = InStr(str, sc(b))<br /> Do While c > 0<br /> str = Left(str, c - 1) & Replace(Right(str, Len(str) - c), sc(b), cSpc)<br /> c = InStr(str, sc(b))<br /> Loop<br /> Next b<br />End If<br /><br />If OnlyVBObjectName = True Then<br />'swap hyphens & spaces & periods for underscore in VB object name<br /> Const scUS As String = "_"<br /> For b = slaFSL To vboMax<br /> str = Replace(str, sc(b), scUS)<br /> Next b<br />'then remove invalid characters from start of string<br /> Dim c1 As String<br /> c1 = Left(str, 1)<br /> Do While c1 = scUS Or c1 = sc(18) Or IsNumeric(c1)<br /> str = Right(str, Len(str) - 1)<br /> c1 = Left(str, 1)<br /> Loop<br />'remove double underscore<br /> Do While InStr(str, scUS & scUS) > 0<br /> str = Replace(str, scUS & scUS, scUS)<br /> Loop<br /> 'check object name length<br /> If Len(str) > VBNameLength Then<br /> If CropLength = True Then<br /> str = Left(str, VBNameLength)<br /> Else<br /> pp = "WARNING: object name > 35 chars"<br /> MsgBox pp, vbCritical, tt<br /> End If<br /> End If<br />End If<br /><br />'remove needless underscores from end of string<br />Do While Right(str, 1) = scUS<br /> str = Left(str, Len(str) - 1)<br />Loop<br /><br />xlU_Clean_Special = str<br /><br />End Function<br /><br />Function xlU_SheetExists(ByVal wsname As String _<br /> , Optional ByRef wb As Workbook) As Boolean<br />'v1.08 2013-04-12 15:00<br />'returns TRUE if the sheet exists in the active (or specified) workbook<br /><br />If wb Is Nothing Then Set wb = ActiveWorkbook<br /><br />xlU_SheetExists = False<br />On Error GoTo NoSuchSheet<br />If Len(wb.Sheets(wsname).Name) > 0 Then<br /> xlU_SheetExists = True<br /> Exit Function<br />End If<br /><br />NoSuchSheet:<br />End Function<br /><br />Function xlU_FileFolderExists(ByVal strFullPath As String) As Boolean<br />'v1.00<br />'Author : Ken Puls (www.excelguru.ca)<br />'URL : http://www.excelguru.ca/node/30<br />'Macro Purpose: Check if a file or folder exists<br /><br /> On Error GoTo Skip<br /> If Not Dir(strFullPath, vbDirectory) = vbNullString Then xlU_FileFolderExists = True<br /> <br />Skip:<br /> On Error GoTo 0<br /><br />End Function<br /><br />Function xlU_GetSpecialFolderNames(Optional ByVal DoDebug As Boolean = True)<br />'v2.00 2013-05-22 12:06<br />'examples of legacy code only, better to use modSpecialFolders<br />'DoDebug = True [default] outputs to Immediate window<br />'DoDebug = False pops up series of MsgBoxes<br /><br />Dim objFolders As Object<br />Set objFolders = CreateObject("WScript.Shell").SpecialFolders<br /><br />Select Case DoDebug<br /> Case True<br /> Debug.Print objFolders("desktop")<br /> Debug.Print objFolders("allusersdesktop")<br /> Debug.Print objFolders("sendto")<br /> Debug.Print objFolders("startmenu")<br /> Debug.Print objFolders("recent")<br /> Debug.Print objFolders("favorites")<br /> Debug.Print objFolders("mydocuments")<br /> Case False<br /> MsgBox objFolders("desktop")<br /> MsgBox objFolders("allusersdesktop")<br /> MsgBox objFolders("sendto")<br /> MsgBox objFolders("startmenu")<br /> MsgBox objFolders("recent")<br /> MsgBox objFolders("favorites")<br /> MsgBox objFolders("mydocuments")<br />End Select<br /><br />End Function<br /><br />Sub xlU_Reset_Comment_Sizes(Optional ByRef ws As Worksheet _<br /> , Optional ByVal CmtHeight As Single _<br /> , Optional ByVal CmtWidth As Single)<br />'v1.06 2013-03-19 11:18<br />'resets all comments on ActiveSheet<br />'NB: superseded by version in Delivery KPI Template v3.13b<br /><br />If ws Is Nothing Then Set ws = ActiveSheet<br /><br />Dim c As Comment, ch As Single, cw As Single<br />If CmtHeight = 0 Then ch = 60 Else ch = CmtHeight<br />If CmtWidth = 0 Then cw = 100 Else ch = CmtWidth<br /><br />For Each c In ws.Comments<br /> c.Shape.Height = ch<br /> c.Shape.Width = cw<br />Next c<br /><br />End Sub<br /><br />Sub xlU_Cut_Multiple_Rows_to_New_Location(Optional ByVal DeleteEmptyRows As Boolean _<br /> , Optional ByRef ws As Worksheet)<br />'v2.00 2013-05-22 13:10<br /><br />If ws Is Nothing Then Set ws = ActiveSheet<br /><br />Dim xl As Application<br />Set xl = Application<br /><br />Const RangeToCut As String = "temp_range"<br />MsgBox "Highlight all rows to copy, and then name that range 'temp_range'", vbOKCancel<br /><br />Dim BlankRow As Integer<br />BlankRow = CInt(InputBox("Enter a blank row number (normally somewhere below the bottom of the table) where the rows will be pasted"))<br />If BlankRow = 0 Then BlankRow = ActiveSheet.Columns(1).Rows(ActiveSheet.Rows.Count).End(xlUp).Offset(1)<br /><br />xl.Calculation = xlCalculationManual<br />Dim blnASU As Boolean<br />blnASU = xl.ScreenUpdating<br />xl.ScreenUpdating = False<br /><br />Dim rp As Range, rC As Range<br />On Error GoTo Error_norange<br />For Each rC In ws.Range(RangeToCut).Rows<br />On Error GoTo 0<br /> Set rp = ws.Rows(BlankRow)<br /> If rp.Cells(1).Value <> "" Then GoTo Error_notblank<br /> If rC.Cells(1).Value <> "" Then<br /> 'ignores blank rows<br /> rp.EntireRow.Insert<br /> rC.EntireRow.Copy<br /> rp.PasteSpecial xlPasteAll<br />xl.CutCopyMode = False<br /> End If<br /> 'clear [and delete] rc row<br /> rC.EntireRow.ClearContents<br /> If DeleteEmptyRows = True Then rC.EntireRow.Delete<br />Next rC<br />GoTo DoTheRest<br /><br />Error_norange:<br /> MsgBox "range name " & RangeToCut & " not found"<br />GoTo DoTheRest<br /><br />Error_notblank:<br /> MsgBox "blank row not blank"<br />GoTo DoTheRest<br /><br />DoTheRest:<br />xl.ScreenUpdating = blnASU<br />xl.Calculation = xlCalculationSemiautomatic<br />End Sub<br /><br />Sub xlU_RemoveAllConnections(ByRef wb As Workbook)<br />'v1.07 2013-04-10 10:32<br />'removes active connections EXCEPT first connection (necessary for pivot functions)<br />'source: http://vbcity.com/forums/t/163459.aspx<br /><br />If wb.Connections.Count > 1 Then<br />Dim i As Integer<br />For i = 2 To wb.Connections.Count<br /> wb.Connections.Item(1).Delete<br />Next i<br />Else<br />'MsgBox wb.Connections.Count<br />End If<br /><br />End Sub<br /><br />Sub xlU_RemoveUnusedConnections(ByRef wb As Workbook)<br />'v1.08b 2013-04-12 14:46<br />'removes only inactive connections<br />MsgBox "xlu_RemoveUnusedConnections doesn't work yet, causes big problems, don't run it"<br />Exit Sub '!!<br /><br />If wb.Connections.Count > 0 Then<br />Dim i As Integer<br />For i = 1 To wb.Connections.Count<br /> With wb.Connections.Item(i)<br /> Debug.Print .Name<br /> .Refresh<br /> '.Delete<br /> End With<br />Next i<br />Else<br />'MsgBox wb.Connections.Count<br />End If<br /><br />End Sub<br /><br />Sub xlU_Find_And_Replace_Text(ByVal OldString As String, ByVal NewString As String _<br /> , Optional ByRef RangeToFindAndReplace As Range)<br />'v2.02 2013-06-11 13:18<br />'bypasses sheet protection restrictions on normal text-only f&r<br /><br />Dim s As String, spre As String, ssuf As String, c As Range, b As Byte<br />If RangeToFindAndReplace Is Nothing Then Set RangeToFindAndReplace = Selection<br />For Each c In RangeToFindAndReplace<br /> s = c.Value<br /> b = InStr(s, OldString)<br /> If b > 0 Then<br /> spre = Left(s, b - 1)<br /> ssuf = Mid(s, b + Len(OldString), Len(s))<br /> s = spre & NewString & ssuf<br /> c.Value = s<br /> End If<br />Next c<br /><br />End Sub<br /><br />Function xlU_Pause_for_Timeout(Optional ByVal TimeOutInSecs As Long) As Boolean<br />'v2.03b 2013-07-10 16:58<br />'reports False if Shift is held down<br />'...except it doesn't work!??<br /><br />Dim t As Long<br /><br />With Application<br /><br /> For t = 0 To TimeOutInSecs - 1<br /> .StatusBar = "HOLD SHIFT TO BYPASS | updating in " & TimeOutInSecs - t & "..."<br /> .Wait Now() + TimeSerial(0, 0, 1)<br /> If modKeyState.IsShiftKeyDown = True Then<br /> xlU_Pause_for_Timeout = False<br /> .StatusBar = "UPDATE CANCELLED BY USER"<br /> Exit Function<br /> End If<br /> Next t<br /><br /> .StatusBar = False<br /><br />End With<br /><br />xlU_Pause_for_Timeout = True<br /><br />End Function<br /><br />Sub xlU_Ranges_Set_To_Column_1_Data_Rows()<br />'v2.06 2013-07-26 16:40<br />'Adjusts length of all named ranges on query sheets to match length of data table in column 1<br /><br />'range names to ignore (can be changed here, or more added in code below):<br />Const ex1 As String = "_FilterDatabase"<br />Const ex2 As String = "v_"<br /><br />Application.Calculation = xlCalculationManual<br /><br />Dim r As Range, nm As Name, n As String, wn As String, rw() As Long, wmax As Byte, c As Long, qt As QueryTable<br />wmax = ActiveWorkbook.Sheets.Count<br />'one rw per sheet<br />ReDim rw(wmax) As Long<br /><br />For Each nm In ActiveWorkbook.Names<br /> n = nm.Name<br /> wn = Mid(nm, 2, Len(nm))<br /> wn = Left(wn, InStr(wn, "!") - 1)<br /> wn = Replace(wn, "'", "")<br /> For Each qt In ThisWorkbook.Sheets(wn).QueryTables<br /> 'count rows in column 1 for this sheet and adjust ranges to cover<br /> c = Sheets(wn).Columns(1).EntireColumn.Cells(Sheets(wn).Rows.Count).End(xlUp).Row<br /> rw(Sheets(wn).Index) = c<br /> <br /> If InStr(nm, "REF!") > 0 Then<br /> 'range reference error, delete<br /> nm.Delete<br /> <br /> ElseIf InStr(nm.Name, ex1) > 0 Then<br /> 'query reference, ignore it<br /> <br /> ElseIf InStr(nm.Name, ex2) > 0 Then<br /> 'validation table, ignore it<br /> <br /> ElseIf Range(nm).Rows.Count <> c Then<br /> 'range is wrong length<br /> Sheets(wn).Select<br /> 'find length of data set from Column 1<br /> Set r = Range(nm).EntireColumn.Rows(rw(Sheets(wn).Index))<br /> Set r = Range(r, r.EntireColumn.Cells(1))<br /> 're-add range name<br /> nm.Delete<br /> ActiveWorkbook.Names.Add n, r<br /> End If<br /> Next qt<br />Next nm<br /><br />End Sub<br /><br />Sub xlU_Ranges_Add_Named_After_Column_Headers(Optional ByRef xlU_Worksheet As Worksheet _<br /> , Optional IncludeHeaders As Boolean = True)<br />'v2.05 2013-07-25 19:29<br />'Adds range names according to column headers and length of data table in column 1<br /><br />Dim rHeader As Range, rColumn As Range, r As Long, rName As String<br />If xlU_Worksheet Is Nothing Then Set xlU_Worksheet = ActiveSheet<br />With xlU_Worksheet<br />'count rows in column 1<br />r = Application.CountA(.Columns(1).EntireColumn)<br />If .Columns(1).Cells(.Rows.Count).End(xlUp).Row <> r Then<br /> MsgBox "Column 1 must have continuous data otherwise counts fail", vbCritical, "Error in xlU_Add_Ranges_Named_After_Column_Headers"<br /> Exit Sub<br />End If<br />Const rOffset As Byte = 1<br />If IncludeHeaders = False Then r = r - rOffset 'excludes header<br /><br />For Each rHeader In .Rows(1).Cells<br /> If rHeader.Value = "" And rHeader.Offset(0, 1).Value = "" Then Exit Sub<br /> If IncludeHeaders = False Then<br /> Set rColumn = .Range(rHeader.Cells.Offset(1), rHeader.Cells.Offset(r))<br /> Else<br /> Set rColumn = .Range(rHeader.Cells(1), rHeader.Cells(r))<br /> End If<br /> rName = xlU_Clean_Special(.Name & "_" & rHeader.Value, True, , True)<br /> ThisWorkbook.Names.Add rName, rColumn<br />Next rHeader<br />End With<br /><br />End Sub<br /><br />Sub xlU_Numeric_To_Text(ByRef xlU_Range As Range)<br />'v2.05 2013-07-25 19:46<br />'NB: Excel may convert to numeric before this point, e.g. when entering 07 will convert to 7 and thus '7<br /><br />Dim s As String, r As Range<br />Const cApo As String = "'"<br />For Each r In xlU_Range.Cells<br /> If IsNumeric(r.Value) Then<br /> s = cApo & r.Text<br /> r.Value = s<br /> End If<br />Next r<br /><br />End Sub<br /><br />Function xlU_BreakLinks(ByRef wb As Workbook) As Boolean<br />'v2.07 2013-07-31 14:06<br />'reports False if no Links to break or any other error, otherwise True<br /><br />xlU_BreakLinks = True<br />On Error GoTo ErrorHandler<br />Dim lnk As Variant, i As Integer<br />With wb<br /> lnk = .LinkSources(xlLinkTypeExcelLinks)<br />On Error GoTo NothingToBreak<br /> For i = 1 To UBound(lnk)<br />On Error GoTo ErrorHandler<br /> .BreakLink lnk(i), xlLinkTypeExcelLinks<br /> Next i<br />End With<br />NothingToBreak:<br />Exit Function<br /><br />ErrorHandler:<br />xlU_BreakLinks = False<br />On Error GoTo 0<br />End Function<br /><br />Sub xlU_Export_Single_Sheets(ByVal OutputPath As String _<br /> , ByVal OutputXLSX As Boolean, ByVal OutputXLS As Boolean, ByVal OutputCSV As Boolean _<br /> , Optional ByVal xlU_Password As String)<br />'v2.08 2013-07-31 16:16<br />'saves a copy of each sheet as a separate lookup file (XLSX and/or XLS and/or CSV)<br />'filename for each file is [ThisWorkbook.Name & " " & Sheet.Name].[xlsx|xls|csv]<br /><br />Const v7 As Byte = 12<br />If Val(Application.Version) < v7 Then<br /> MsgBox "Only works in Excel 2007 or later", vbCritical, "xlU_Export_Single_Sheets"<br /> Exit Sub<br />End If<br /><br />xlU_Protect_All_Sheets True, xlU_Password<br /><br />Application.ScreenUpdating = False<br /><br />Const cDDD As String = "..."<br />Const cSep As String = " | "<br />Const cSpc As String = " "<br />Const cBsl As String = "\"<br />Const cFsl As String = "/"<br />Const cURL As String = "http:"<br />Dim wb As Workbook, fn As String, shn As String, rw As Integer, f As Byte, p As Byte<br /><br />'original filename<br />fn = Replace(Replace(ThisWorkbook.Name, ".xlsm", ""), " (master)", "") 'no extension, remove " (master)"<br /><br />'fix potential path errors<br />'convert OutputPath to UNC (URL doesn't work) and force connection<br />OutputPath = Replace(OutputPath, cFsl, cBsl)<br />OutputPath = Replace(OutputPath, cURL, "")<br />If Right(OutputPath, 1) <> cBsl Then OutputPath = OutputPath & cBsl<br />Shell "explorer " & OutputPath, vbHide<br /><br />Dim aSBorig, aSBbase As String, aSBdft As String<br />aSBorig = Application.StatusBar<br />aSBdft = fn<br />aSBbase = aSBdft & cSep & "Saving separate single-sheet files"<br />Application.StatusBar = aSBbase<br /><br />Dim s As Worksheet<br />For Each s In ThisWorkbook.Sheets<br /> With s<br /> Application.StatusBar = aSBbase & cSep & .Name & cDDD<br />On Error Resume Next<br /> .Unprotect xlU_Password<br />On Error GoTo 0<br /> shn = .Name<br /> .Copy 'to new wb<br /> Set wb = ActiveWorkbook<br />On Error Resume Next<br /> .Protect xlU_Password<br />On Error GoTo 0<br /> End With<br /> With wb<br /> xlU_BreakLinks wb<br /> With .Sheets(1)<br /> rw = Application.CountA(.Columns(1)) + 1<br /> .Rows(rw & ":" & .Rows.Count).Delete<br /> .Protect xlU_Password<br /> End With<br /> Application.DisplayAlerts = False<br /> If OutputXLSX = True Then .SaveAs FileName:=OutputPath & fn & cSpc & shn & ".xlsx", FileFormat:=51 'Logis Station Groups Logis Air Station Codes.xlsx<br /> If OutputXLS = True Then .SaveAs FileName:=OutputPath & fn & cSpc & shn & ".xls", FileFormat:=56 'Logis Station Groups Logis Air Station Codes.xls<br /> If OutputCSV = True Then .SaveAs FileName:=OutputPath & fn & cSpc & shn & ".csv", FileFormat:=6 'Logis Station Groups Logis Air Station Codes.csv<br /> .Close<br /> Application.DisplayAlerts = True<br /> End With<br /> Set wb = Nothing<br />Next s<br /><br />Application.ScreenUpdating = True<br />Application.StatusBar = aSBorig<br /><br />xlU_Protect_All_Sheets True, xlU_Password<br /><br />End Sub<br /><br />Sub xlU_Protect_All_Sheets(ByVal DoProtect As Boolean, Optional xlU_Password As String)<br />'v2.08 2013-07-31 15:51<br /><br />On Error Resume Next<br />Dim s As Worksheet<br />For Each s In ThisWorkbook.Sheets<br />With s<br /> If DoProtect = True Then .Protect xlU_Password Else .Unprotect xlU_Password<br />End With<br />Next s<br />On Error GoTo 0<br /><br />End Sub<br /><br />Function xlU_TransferValidationList(ByRef vSource As Range, ByRef vTarget As Range) As Boolean<br />'v2.09 2013-08-02 13:05<br />'returns True if transferred OK<br />'max 1 cell in vTarget and vSource<br />'could easily be adapted to copy validations across a whole row from a source row<br />'e.g.:<br />' With Target.EntireRow<br />' For i = 1 To .Cells.Count 'NB: this is very inefficient! Limit this to e.g. columns with headers<br />' xlU_TransferValidationList .Cells(i), Domains.Rows(2).Cells(i)<br />' Next i<br />' End With<br /><br />On Error GoTo ErrorHandler<br />Dim c As Byte<br />c = vSource.Cells.Count<br />If c > 1 Then GoTo ErrorHandler<br />With vTarget.Validation<br /> On Error Resume Next<br /> .Delete<br /> On Error GoTo ErrorHandler<br /> .Add Type:=vSource.Validation.Type, AlertStyle:=vSource.Validation.AlertStyle, Operator:= _<br /> vSource.Validation.Operator, Formula1:=vSource.Validation.Formula1<br /> .IgnoreBlank = vSource.Validation.IgnoreBlank<br /> .InCellDropdown = vSource.Validation.InCellDropdown<br /> .InputTitle = vSource.Validation.InputTitle<br /> .InputMessage = vSource.Validation.InputMessage<br /> .ErrorTitle = vSource.Validation.ErrorTitle<br /> .ErrorMessage = vSource.Validation.ErrorMessage<br /> .ShowInput = vSource.Validation.ShowInput<br /> .ShowError = vSource.Validation.ShowError<br />End With<br /> <br />xlU_TransferValidationList = True<br /> <br />ErrorHandler:<br />End Function<br /><br />Function xlU_Transfer_Ranges(ByRef srcws As Worksheet, tgtws As Worksheet)<br />'v2.17 2013-12-03 17:33<br />'takes all worksheet ranges from src ws and replicates on tgt ws<br /><br />On Error Resume Next<br />Dim rng As Range, rn As String, nm As Name<br />For Each nm In srcws.Names<br /> tgtws.Names.Add Replace(nm.Name, srcws.Name, tgtws.Name), Replace(nm.Value, srcws.Name, tgtws.Name)<br />Next nm<br /><br />End Function<br /><br />Function xlU_Convert_File(ByRef PathFile As String _<br /> , ByVal FileFormat As XlFileFormat, ByVal SourceIsXML As Boolean _<br /> , Optional ByVal DeleteOriginal As Boolean) As Boolean<br />'v2.10 2013-08-08 14:40<br />'opens any compatible format file (must be specified if source in XML format)<br />'saves as chosen output file format<br />'will output to CSV, XLS, XLSX, XLSM (add more types below if required)<br /><br />On Error GoTo ErrorHandler<br />Dim tempPathFile As String, newPathFile As String, x1 As Byte, x2 As Byte<br /><br />newPathFile = PathFile<br />x1 = InStr(newPathFile, ".")<br />x2 = x1<br />Do While x2 > 0<br /> x1 = x2<br /> x2 = InStr(x2 + 1, newPathFile, ".")<br />Loop<br />If x1 > 0 Then newPathFile = Left(newPathFile, x1 - 1) 'removes extension<br /><br />tempPathFile = newPathFile & ".temp"<br />If Dir(tempPathFile) <> "" Then Kill tempPathFile 'target already exists<br />FileCopy PathFile, tempPathFile 'copy to target<br /><br />If FileFormat = 6 Then<br /> newPathFile = newPathFile & xcsv<br />ElseIf FileFormat = 56 Then<br /> newPathFile = newPathFile & xxls<br />ElseIf FileFormat = 51 Then<br /> newPathFile = newPathFile & xxlx<br />ElseIf FileFormat = 52 Then<br /> newPathFile = newPathFile & xxlm<br />Else<br /> MsgBox "FileFormat " & FileFormat & " not allowed, but can add to macro code if required", vbCritical, "xlU_Convert_File"<br />End If<br /><br />Application.DisplayAlerts = False<br />If SourceIsXML Then<br /> Workbooks.OpenXML FileName:=tempPathFile, LoadOption:=xlXmlLoadImportToList<br />Else<br /> Workbooks.Open tempPathFile<br />End If<br />ActiveWorkbook.SaveAs newPathFile, FileFormat<br />ActiveWorkbook.Close False<br />If DeleteOriginal = True Then Kill PathFile<br />Kill tempPathFile 'doesn't delete temp file if there's an error<br />xlU_Convert_File = True<br />Exit Function<br /><br />ErrorHandler:<br />End Function<br /><br />Function xlU_UpdateLinks(Optional wb As Workbook) As Boolean<br />'v2.12 2013-08-27 11:36<br />'source: http://www.thecodecage.com/forumz/microsoft-excel-forum/212417-excel-visual-basic-applications-update-all-external-links.html<br /><br />On Error GoTo ErrorHandler<br />xlU_UpdateLinks = True<br /><br />If wb Is Nothing Then Set wb = ActiveWorkbook<br />Dim Links As Variant<br />Dim i As Integer<br />With wb<br /> Links = .LinkSources(xlExcelLinks)<br /> If Not IsEmpty(Links) Then<br /> For i = 1 To UBound(Links)<br /> .UpdateLink Links(i), xlLinkTypeExcelLinks<br /> Next i<br /> End If<br />End With<br /><br />Exit Function<br /><br />ErrorHandler:<br />xlU_UpdateLinks = False<br />End Function<br /><br />Function xlU_Ranges_Change_Scope(ByVal xluScopeChange As xluScopeChangeType _<br /> , ByVal xluWorksheet As Worksheet, ByVal xluWorkbook As Workbook _<br /> , Optional ByVal xluDeleteOriginal As Boolean = False) As Boolean<br />'v2.16 2013-12-03 09:59<br />'changes scope of Range Names from Worksheet to Workbook, or vice versa<br />'only creates Name in xluWorksheet if Name refers to xluWorksheet, but can easily run for each sheet in turn<br /><br />On Error Resume Next<br /><br />Dim nm As Name, newWBname As String<br />If xluScopeChange = xluWorksheetToWorkbook Then<br /> For Each nm In xluWorksheet.Names<br /> If InStr(nm.Value, "#REF!") = 0 Then<br /> newWBname = Mid(nm.Name, InStr(nm.Name, "!") + 1, Len(nm.Name)) 'v2.16<br /> xluWorkbook.Names.Add newWBname, nm.Value 'v2.16<br /> If xluDeleteOriginal Then nm.Delete<br /> End If<br /> Next nm<br /> <br />ElseIf xluScopeChange = xluWorkbookToWorksheet Then<br /> For Each nm In xluWorkbook.Names<br /> If InStr(nm.Value, xluWorksheet.Name) > 0 And InStr(nm.Value, "#REF!") = 0 Then<br /> xluWorksheet.Names.Add nm.Name, nm.Value<br /> If xluDeleteOriginal Then nm.Delete<br /> End If<br /> Next nm<br /><br />End If<br /><br />End Function<br /><br />Function xlU_SafeToQuitExcel(Optional ByVal QuitIfSafeOtherwiseCloseThisWorkbookWithoutSaving As Boolean) As Boolean<br />'v2.19 2014-01-16 13:01 - option to quit/close automatically<br />'v2.18 2013-12-10 17:04 - bugfix in numbers where PERSONAL.XLSB is not open<br />'v2.14 2013-10-30 12:41<br />'True if all open Workbooks (including this one but excluding PERSONAL.XLSB) are saved<br />'False if any workbooks need saving (not safe to quit)<br /><br /> Dim wb As Workbook, t As Integer<br /> t = 0<br /> For Each wb In Workbooks<br /> If UCase(wb.Name) <> "PERSONAL.XLSB" And wb.Saved <> True Then t = t + 1<br /> Next wb<br /> If t <= 1 Then xlU_SafeToQuitExcel = True<br /> <br /> If QuitIfSafeOtherwiseCloseThisWorkbookWithoutSaving Then<br /> 'NB: if necessary, workbook should be saved prior to running this function<br /> Application.DisplayAlerts = False<br /> If xlU_SafeToQuitExcel Then Application.Quit<br /> ThisWorkbook.Close False<br /> End If<br /><br />End Function<br /><br />Function xlU_WorkbookIsReadOnly(Optional wb As Workbook) As Boolean<br />'v2.15 2013-10-30 16:12<br />'Workbook.ReadOnly works for local files, but isn't reliable with SharePoint files<br /><br />If wb Is Nothing Then<br /> Set wb = ActiveWorkbook<br />Else<br /> wb.Activate<br />End If<br /><br />If InStr(1, Application.Caption, "Read-Only") > 1 _<br />Or InStr(1, ActiveWindow.Caption, "Read-Only") > 1 _<br />Then xlU_WorkbookIsReadOnly = True<br /><br />End Function<br /></span></span></span></blockquote>
baldmosher™http://www.blogger.com/profile/11281471751951639119noreply@blogger.com0Stretford M17 1QA, UK53.4609149 -2.318959400000039853.4609149 -2.3189594000000398 53.4609149 -2.3189594000000398tag:blogger.com,1999:blog-7264479838117802346.post-54099143052114732262013-08-05T09:15:00.000-07:002014-01-16T06:58:49.725-08:00VBA Modules: Excel: xlSharePoint v5.07<a href="http://baldywritten.blogspot.com/2013/08/vba-modules-modzip-v502aaa.html" target="_blank">Read this</a> for full information on these modules<br />
<br />
Now this is pretty advanced stuff. It's essential for working with Excel files on Sharepoint -- which is "quirky" at best and "really annoying" at worst. Why MS decided to make it so awkward to interface with their own corporate site hosting package, I have no idea, but hey, that's their prerogative.<br />
<br />
I do not recommend using this module without first getting a REALLY good understanding of how SharePoint works; the various site setup options make this a bit of an inexact science, but if your SP site setup is simple (i.e. no Versioning) and you have at least Contribute access to the relevant folders, it should work OK for you.<br />
<br />
Note that <u>this module is currently in beta</u> simply because I've not <u>tested</u> it for SP Document Libraries that have Versioning, which requires mandatory CheckOut/CheckIn of files. It should work OK though, so please do let me know if you get it working or if you have any issues.<br />
<br />
Also note that the macros will try to force UNC connection via Explorer, and will use them if possible. I make no guarantees whatsoever that this module will work with SharePoint via URLs. Although I have in the past had some success, URLs are just not as reliable, and they behave strangely (maybe a corporate network thing). UNC is a much better way of accessing SharePoint, so use those addresses if you can. You might need to bludgeon your local IT department to help you with that. Windows XP should let you use UNC via inbuilt Windows SharePoint Services (WSS), but Windows 7 seems to be much better at it. If you have Windows Server you might need to install WSS 3.0 to access via UNC. Even then, it might not work correctly!<br />
<br />
I've tried to link back to the various online sources in the code, but there are too many to mention here, and I've found that in most cases the vanilla code hasn't worked as expected, and I've needed to completely rebuild it to make it work reliably.<br />
<br />
<blockquote class="tr_bq">
<span style="font-size: x-small;"><span style="font-family: "Courier New",Courier,monospace;"><span style="font-size: xx-small;">'xlSharePoint<br />'v5.07 2014-01-16 14:56<br /><br />'===========================================================================<br />' HELP CONTACT<br />'===========================================================================<br />' Code is provided without warranty and can be stolen and amended as required.<br />' Tom Parish<br />' TJP@tomparish.me.uk<br />' http://baldywrittencod.blogspot.com<br />' DGF Help Contact: see BPMHelpContact module<br />'=========================================================================<br /><br />'*** BETA ***<br />'SP_Open_and_CheckIn untested with SharePoint Document Libraries that force CheckOut<br /><br />'always export to \\GBMNCWSA050\BPMpublic\VBA Modules\<br /><br />' ***********************************************<br />' ***** WARNING: v3+ incompatible with v2 *****<br />' ***********************************************<br /><br />' *****************************************************<br />' ***** WARNING: SETTINGS BELOW MUST BE AMENDED *****<br />' *****************************************************<br /><br />'===========================================================================<br />' xlSharePoint<br />'===========================================================================<br />' This module handles various SharePoint functions with either UNC<br />' or URL addresses, depending on user settings.<br />'<br />' Works for Office 2007/2010 and Windows 7<br />' (2003 and XP sort of works, but is buggy)<br /><br />'===========================================================================<br />' Additional modules required:<br />'===========================================================================<br />' modAppsOffice v4<br />' modCheckUsers v2<br />' modKeyState<br />' modZip v6<br />'<br />' Code included from other modules:<br />' [modSpecialFolders]<br />' [xlShellAndWait]<br /><br />'===========================================================================<br />' Additional References required:<br />'===========================================================================<br />' Microsoft Excel Object Library (if not running from Excel)<br /><br />'===========================================================================<br />' External applications required:<br />'===========================================================================<br />' Microsoft Outlook (for Outlook functions)<br />' Microsoft Access (for Access functions)<br />' Microsoft Excel (for Excel functions)<br /><br />'=========================================================================<br />' VERSION HISTORY<br />'=========================================================================<br />'v5.07 2014-01-16 14:56 - ShellAndWait now Private, resolves conflict with xlShellAndWait module<br />'v5.06 2014-01-13 17:45 - ThisWorkbook code updated to allow VBA weekly update automation<br />'v5.05 2014-01-10 14:27 - SP_Force_Connection - bugfix for zips (remove "" from ends)<br />'v5.04 2014-01-09 17:11 - SP_CloseExplorerWindow - bugfix<br />'v5.03 2014-01-08 10:24 - SP_Force_Connection - now accepts filenames at end of path<br />'v5.02 2013-12-18 10:28 - SP_Force_Connection - added option for default UNCpath<br />' v5.01 xlShellAndWait - late binding bugfix<br />' v5.00 SP_Force_Connection/SP_CloseExplorerWindow: major improvement<br />' to closing Explorer window opened during forced UNC connection<br />'*************************************************************************<br />' previous versions should be upgraded to v5.00<br />'*************************************************************************<br />' v4.10 SP_Force_Connection: result changed to Boolean<br />' v4.09 Workbook_Open routine added to ThisWorkbook module code at end<br />' v4.08 bugfix in ThisWorkbook module code at end<br />' v4.07b SP_Open_and_CheckIn bugfix: Workbooks(fn).CanCheckIn<br />' v4.06 spXLapp, stops reliance on XLapp in modAppsOffice<br />' v4.05a improved ThisWorkbook module code at end<br />' v4.05 SP_Upload_from_2007: safer Quit routine<br />' v4.04 improved ThisWorkbook module code at end<br />' v4.03 SP_Upload_from_2007: added option to Break Links<br />' v4.02 SP_Force_Connection: less brutal, checks Dir(UNCpath) first<br />' v4.01 added SP_Force_Connection, uses ShellAndWait<br />' added code from xlShellAndWait<br />' v4.00 added code from modSpecialFolders<br />' v3.03 SP_Upload_from_2007: shortened option variable names; added<br />' validity check; all output variables optional<br />' v3.02 SP_Upload_from_2007: added AlsoSaveCopyToSecondaryPath<br />' v3.01 SP_Upload_from_2007: added XLSX; process improvements<br />'*** SP_Open_and_CheckIn BETA ***<br />'*** untested with folders that force CheckOut / CheckIn when publishing ***<br />' v3.01b SP_Open_and_CheckIn runs in background<br />' v3.00b added SP_Open_and_CheckIn<br />' v3.00 SP_Upload_from_2007: allows Publish to SharePoint<br />' retired SPCheckUpload (superseded)<br />' retired fextn and textn (only used in CIRF)<br />' renamed SP_pth_sl and SP_fn_val (conflict with CIRF)<br />' renamed SP_Upload_XLS_and_XLSM to SP_Upload_from_2007<br />'*************************************************************************<br />' WARNING: previous versions not compatible with v3 and must be upgraded<br />'*************************************************************************<br />' v2.07 SP_Upload_XLS_and_XLSM: temp pth changed to \\UserDocs\BPM Tools\temp\<br />' SP_Upload_XLS_and_XLSM: allows Publish of XLS and XLSM<br />' v2.06 SP_Upload_XLS_and_XLSM: added CSV option<br />' removed SPpthS, not needed<br />' annotations (additional modules)<br />' v2.05 added SP_Check_Special (moved from xlUtils.xlU_Check_Special)<br />' v2.04 renamed file extension constants (more consistent)<br />' SP_Upload_from_2003: renamed from SP_Upload and error handlers improved<br />' v2.03 added SP_Upload_XLS_and_XLSM<br />' v2.02 changed Public constants & functions to Private (conflicts)<br />' v2.01 removed ftyp=52 as misleading coding; updated annotations<br />' v2.00 module name changed (was modSharePoint but needs Excel library)<br />' v1.16 bugfix: Application.Statusbar for non-Excel applications<br />' v1.15 code tidy up, annotations improved, no functional change<br />' v1.14 added cPrd "."<br />' v1.13 added xzip extension<br />' v1.12 added xxlx, xxlm, xxlb extensions<br />' v1.11 added SP_Upload<br />' v1.10 added fn_SPpth<br />' v1.09 added warning at top of module<br />' v1.08 added SPdom, SP_OfferToCheckInAllWorkbooks<br />' v1.07 renamed module and macros, iMacroName to SPMacroName<br />' v1.06 SPUseCheckOut improvements, but still quite buggy<br />' v1.05 bugfixes, cleanups<br />' v1.04 bugfixes, cleanups<br />' v1.03 bugfixes, cleanups<br />' v1.02 added SPUseCheckOut<br /><br />' *****************************************************<br />' ***** WARNING: SETTINGS BELOW MUST BE AMENDED *****<br />' *****************************************************<br /><br />Option Explicit<br />Option Compare Text 'for ShellAndWait<br /><br />'*** SYNTAX:<br />'*** Use fn_SPpth(SomeURL) in code to convert SPpth URL into UNC and force connection (if possible for this user)<br />'*** --> [SomeURL] should always be a PUBLIC SharePoint location to prevent user access errors<br />'*** --> ideally has Read permission for "NT Authority\Authenticated Users" (or equivalent generic public access group)<br />'*** Specify your 'parent' top level SharePoint SITE here as URL<br /> Public Const SPpth As String _<br /> = "http://ishare.dhl.com/sites/DGFUK/"<br /> 'Public Const SPpthUNC As String = fn_SPpth(SPpth)<br /><br />'*** Specify your 'parent' top level SharePoint DOMAIN here (must be same as above)<br /> Public Const SPdom As String = "ishare.dhl.com"<br /><br />Private spXLapp As Excel.Application 'v4.06 prevents reliance on & conflicts with modAppsOffice<br /><br />Private Const cURL As String = "http:" 'If Left(SPpth, 5) = cURL Then SPsetsl = cFsl Else cBsl<br />'Private Const cUNC As String = "\\" 'not necessary<br /><br />Private Const xzip As String = ".zip" 'zip file<br />'Excel <=2003<br />Private Const xxls As String = ".xls" 'FileFormat:=56, Office 2003 macro enabled workbook<br />Private Const xxlt As String = ".xlt" 'FileFormat:=??, Office 2003 macro enabled template<br />Private Const x2k3 As String = " (2003)" 'added to filename during zip upload, i.e. "Report Name (2003).zip"<br />'Excel >2003<br />Private Const xxlx As String = ".xlsx" 'FileFormat:=51, Office 2007/10 workbook<br />Private Const xxlm As String = ".xlsm" 'FileFormat:=52, Office 2007/10 macro enabled workbook<br />Private Const xxlb As String = ".xlsb" 'FileFormat:=??, Office 2007/10 binary workbook<br />Private Const xxtm As String = ".xltm" 'FileFormat:=??, Office 2007/10 macro enabled template<br />Private Const xcsv As String = ".csv" 'FileFormat:=6, CSV file<br /><br />'Office 2010: Val(Application.Version) = 14 Office 2007: Application.Version = "12.0" Office 2003: Application.Version = "11.0"<br />'Private Const v3 As Byte = 11<br />Private Const v7 As Byte = 12 '>=v7 proves 2007/2010<br />'Private Const v10 As Byte = 14<br /><br />Private Const cSpc As String = " "<br />Private Const cHyp As String = "-"<br />Private Const cFsl As String = "/"<br />Private Const cBsl As String = "\"<br />Private Const cAst As String = "*"<br />Private Const cPrd As String = "."<br />Private Const wsA As String = "admin"<br /><br />'==========================================================================<br />'==========================================================================<br />'==========================================================================<br />'==========================================================================<br /><br />'<br />' Code from modSpecialFolders module:<br />'<br /><br />'http://answers.microsoft.com/en-us/office/forum/office_2010-customize/how-2-refer-to-desktop/97eba910-54c9-409f-9454-6d7c8d54d009<br />Private Declare Function SHGetSpecialFolderLocation _<br /> Lib "shell32" (ByVal hwnd As Long, _<br /> ByVal nFolder As Long, ppidl As Long) As Long<br /><br />Private Declare Function SHGetPathFromIDList _<br /> Lib "shell32" Alias "SHGetPathFromIDListA" _<br /> (ByVal Pidl As Long, ByVal pszPath As String) As Long<br /><br />Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal pvoid As Long)<br /><br />'Desktop<br />Private Const CSIDL_INTERNET = &H1 'Internet Explorer (icon on desktop)<br />Private Const CSIDL_PROGRAMS = &H2 'Start Menu\Programs<br />Private Const CSIDL_CONTROLS = &H3 'My Computer\Control Panel<br />Private Const CSIDL_PRINTERS = &H4 'My Computer\Printers<br />Private Const CSIDL_PERSONAL = &H5 'My Documents<br />Private Const CSIDL_FAVORITES = &H6 '<user name>\Favorites<br />Private Const CSIDL_STARTUP = &H7 'Start Menu\Programs\Startup<br />Private Const CSIDL_RECENT = &H8 '<user name>\Recent<br />Private Const CSIDL_SENDTO = &H9 '<user name>\SendTo<br />Private Const CSIDL_BITBUCKET = &HA '<desktop>\Recycle Bin<br />Private Const CSIDL_STARTMENU = &HB '<user name>\Start Menu<br />Private Const CSIDL_DESKTOPDIRECTORY = &H10 '<user name>\Desktop<br />Private Const CSIDL_DRIVES = &H11 'My Computer<br />Private Const CSIDL_NETWORK = &H12 'Network Neighborhood<br />Private Const CSIDL_NETHOOD = &H13 '<user name>\nethood<br />Private Const CSIDL_FONTS = &H14 'Windows\fonts<br />Private Const CSIDL_TEMPLATES = &H15<br />Private Const CSIDL_COMMON_STARTMENU = &H16 'All Users\Start Menu<br />Private Const CSIDL_COMMON_PROGRAMS = &H17 'All Users\Programs<br />Private Const CSIDL_COMMON_STARTUP = &H18 'All Users\Startup<br />Private Const CSIDL_COMMON_DESKTOPDIRECTORY = &H19 'All Users\Desktop<br />Private Const CSIDL_APPDATA = &H1A '<user name>\Application Data<br />Private Const CSIDL_PRINTHOOD = &H1B '<user name>\PrintHood<br />Private Const CSIDL_LOCAL_APPDATA = &H1C '<user name>\Local Settings\Application Data (non roaming)<br />Private Const CSIDL_ALTSTARTUP = &H1D 'non localized startup<br />Private Const CSIDL_COMMON_ALTSTARTUP = &H1E 'non localized common startup<br />Private Const CSIDL_COMMON_FAVORITES = &H1F<br />Private Const CSIDL_INTERNET_CACHE = &H20<br />Private Const CSIDL_COOKIES = &H21<br />Private Const CSIDL_HISTORY = &H22<br />Private Const CSIDL_COMMON_APPDATA = &H23 'All Users\Application Data<br />Private Const CSIDL_WINDOWS = &H24 'Windows Directory<br />Private Const CSIDL_SYSTEM = &H25 'System Directory<br />Private Const CSIDL_PROGRAM_FILES = &H26 'C:\Program Files<br />Private Const CSIDL_MYPICTURES = &H27 'C:\Program Files\My Pictures<br />Private Const CSIDL_PROFILE = &H28 'USERPROFILE<br />Private Const CSIDL_SYSTEMX86 = &H29 'x86 system directory on RISC<br />Private Const CSIDL_PROGRAM_FILESX86 = &H2A 'x86 C:\Program Files on RISC<br />Private Const CSIDL_PROGRAM_FILES_COMMON = &H2B 'C:\Program Files\Common<br />Private Const CSIDL_PROGRAM_FILES_COMMONX86 = &H2C 'x86 Program Files\Common on RISC<br />Private Const CSIDL_COMMON_TEMPLATES = &H2D 'All Users\Templates<br />Private Const CSIDL_COMMON_DOCUMENTS = &H2E 'All Users\Documents<br />Private Const CSIDL_COMMON_ADMINTOOLS = &H2F 'All Users\Start Menu\Programs\Administrative Tools<br />Private Const CSIDL_ADMINTOOLS = &H30 '<user name>\Start Menu\Programs\Administrative Tools<br />Private Const CSIDL_CONNECTIONS = &H31 'Network and Dial-up Connections<br />Private Const MAX_PATH = 260<br />Private Const NOERROR = 0<br /><br />'==========================================================================<br />'==========================================================================<br />'==========================================================================<br />'==========================================================================<br /><br />'<br />' Code from xlShellAndWait module:<br />'<br /><br />'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''<br />'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''<br />' modShellAndWait<br />' By Chip Pearson, chip@cpearson.com, www.cpearson.com<br />' This page on the web site: www.cpearson.com/Excel/ShellAndWait.aspx<br />' 9-September-2008<br />'<br />' This module contains code for the ShellAndWait function that will Shell to a process<br />' and wait for that process to end before returning to the caller.<br />'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''<br />'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''<br />Private Declare Function WaitForSingleObject Lib "kernel32" ( _<br /> ByVal hHandle As Long, _<br /> ByVal dwMilliSeconds As Long) As Long<br /><br />Private Declare Function OpenProcess Lib "kernel32.dll" ( _<br /> ByVal dwDesiredAccess As Long, _<br /> ByVal bInheritHandle As Long, _<br /> ByVal dwProcessId As Long) As Long<br /><br />Private Declare Function CloseHandle Lib "kernel32" ( _<br /> ByVal hObject As Long) As Long<br /><br />Private Const SYNCHRONIZE = &H100000<br /><br />Private Enum ShellAndWaitResult<br /> Success = 0<br /> Failure = 1<br /> TimeOut = 2<br /> InvalidParameter = 3<br /> SysWaitAbandoned = 4<br /> UserWaitAbandoned = 5<br /> UserBreak = 6<br />End Enum<br /><br />Private Enum ActionOnBreak<br /> IgnoreBreak = 0<br /> AbandonWait = 1<br /> PromptUser = 2<br />End Enum<br /><br />Private Const STATUS_ABANDONED_WAIT_0 As Long = &H80<br />Private Const STATUS_WAIT_0 As Long = &H0<br />Private Const WAIT_ABANDONED As Long = (STATUS_ABANDONED_WAIT_0 + 0)<br />Private Const WAIT_OBJECT_0 As Long = (STATUS_WAIT_0 + 0)<br />Private Const WAIT_TIMEOUT As Long = 258&<br />Private Const WAIT_FAILED As Long = &HFFFFFFFF<br />Private Const WAIT_INFINITE = -1&<br /><br />'==========================================================================<br />'==========================================================================<br />'==========================================================================<br />'==========================================================================<br /><br />Private Function SpecFolder(ByVal lngFolder As Long) As String<br />Dim lngPidlFound As Long<br />Dim lngFolderFound As Long<br />Dim lngPidl As Long<br />Dim strPath As String<br /><br />strPath = Space(MAX_PATH)<br />lngPidlFound = SHGetSpecialFolderLocation(0, lngFolder, lngPidl)<br />If lngPidlFound = NOERROR Then<br /> lngFolderFound = SHGetPathFromIDList(lngPidl, strPath)<br /> If lngFolderFound Then<br /> SpecFolder = Left$(strPath, _<br /> InStr(1, strPath, vbNullChar) - 1)<br /> End If<br />End If<br />CoTaskMemFree lngPidl<br />End Function<br /><br />'==========================================================================<br />'==========================================================================<br />'==========================================================================<br />'==========================================================================<br /><br />Private Function ShellAndWait(ShellCommand As String, _<br /> TimeOutMs As Long, _<br /> ShellWindowState As VbAppWinStyle, _<br /> BreakKey As ActionOnBreak) As ShellAndWaitResult<br />'v1.01 2013-12-17 15:58 - late binding for non-Excel Application use<br />'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''<br />' ShellAndWait<br />'<br />' This function calls Shell and passes to it the command text in ShellCommand. The function<br />' then waits for TimeOutMs (in milliseconds) to expire.<br />'<br />' Parameters:<br />' ShellCommand<br />' is the command text to pass to the Shell function.<br />'<br />' TimeOutMs<br />' is the number of milliseconds to wait for the shell'd program to wait. If the<br />' shell'd program terminates before TimeOutMs has expired, the function returns<br />' ShellAndWaitResult.Success = 0. If TimeOutMs expires before the shell'd program<br />' terminates, the return value is ShellAndWaitResult.TimeOut = 2.<br />'<br />' ShellWindowState<br />' is an item in VbAppWinStyle specifying the window state for the shell'd program.<br />'<br />' BreakKey<br />' is an item in ActionOnBreak indicating how to handle the application's cancel key<br />' (Ctrl Break). If BreakKey is ActionOnBreak.AbandonWait and the user cancels, the<br />' wait is abandoned and the result is ShellAndWaitResult.UserWaitAbandoned = 5.<br />' If BreakKey is ActionOnBreak.IgnoreBreak, the cancel key is ignored. If<br />' BreakKey is ActionOnBreak.PromptUser, the user is given a ?Continue? message. If the<br />' user selects "do not continue", the function returns ShellAndWaitResult.UserBreak = 6.<br />' If the user selects "continue", the wait is continued.<br />'<br />' Return values:<br />' ShellAndWaitResult.Success = 0<br />' indicates the the process completed successfully.<br />' ShellAndWaitResult.Failure = 1<br />' indicates that the Wait operation failed due to a Windows error.<br />' ShellAndWaitResult.TimeOut = 2<br />' indicates that the TimeOutMs interval timed out the Wait.<br />' ShellAndWaitResult.InvalidParameter = 3<br />' indicates that an invalid value was passed to the procedure.<br />' ShellAndWaitResult.SysWaitAbandoned = 4<br />' indicates that the system abandoned the wait.<br />' ShellAndWaitResult.UserWaitAbandoned = 5<br />' indicates that the user abandoned the wait via the cancel key (Ctrl+Break).<br />' This happens only if BreakKey is set to ActionOnBreak.AbandonWait.<br />' ShellAndWaitResult.UserBreak = 6<br />' indicates that the user broke out of the wait after being prompted with<br />' a ?Continue message. This happens only if BreakKey is set to<br />' ActionOnBreak.PromptUser.<br /><br />'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''<br /><br />Dim TaskID As Long<br />Dim ProcHandle As Long<br />Dim WaitRes As Long<br />Dim Ms As Long<br />Dim MsgRes As VbMsgBoxResult<br />Dim SaveCancelKey As XlEnableCancelKey 'NB: only works in Excel<br />Dim ElapsedTime As Long<br />Dim Quit As Boolean<br />Const ERR_BREAK_KEY = 18<br />Const DEFAULT_POLL_INTERVAL = 500<br />Dim XLapp As Object 'v1.01<br />If InStr(Application.Name, "Excel") > 0 Then Set XLapp = Application Else Set XLapp = CreateObject("Excel.Application")<br /><br />If Trim(ShellCommand) = vbNullString Then<br /> ShellAndWait = ShellAndWaitResult.InvalidParameter<br /> Exit Function<br />End If<br /><br />If TimeOutMs < 0 Then<br /> ShellAndWait = ShellAndWaitResult.InvalidParameter<br /> Exit Function<br />ElseIf TimeOutMs = 0 Then<br /> Ms = WAIT_INFINITE<br />Else<br /> Ms = TimeOutMs<br />End If<br /><br />Select Case BreakKey<br /> Case AbandonWait, IgnoreBreak, PromptUser<br /> ' valid<br /> Case Else<br /> ShellAndWait = ShellAndWaitResult.InvalidParameter<br /> Exit Function<br />End Select<br /><br />Select Case ShellWindowState<br /> Case vbHide, vbMaximizedFocus, vbMinimizedFocus, vbMinimizedNoFocus, vbNormalFocus, vbNormalNoFocus<br /> ' valid<br /> Case Else<br /> ShellAndWait = ShellAndWaitResult.InvalidParameter<br /> Exit Function<br />End Select<br /><br />On Error Resume Next<br />Err.Clear<br />TaskID = Shell(ShellCommand, ShellWindowState)<br />If (Err.Number <> 0) Or (TaskID = 0) Then<br /> ShellAndWait = ShellAndWaitResult.Failure<br /> Exit Function<br />End If<br /><br />ProcHandle = OpenProcess(SYNCHRONIZE, False, TaskID)<br />If ProcHandle = 0 Then<br /> ShellAndWait = ShellAndWaitResult.Failure<br /> Exit Function<br />End If<br /><br /><br />On Error GoTo ErrH:<br />SaveCancelKey = XLapp.EnableCancelKey<br />XLapp.EnableCancelKey = xlErrorHandler<br />WaitRes = WaitForSingleObject(ProcHandle, DEFAULT_POLL_INTERVAL)<br />Do Until WaitRes = WAIT_OBJECT_0<br /> DoEvents<br /> Select Case WaitRes<br /> Case WAIT_ABANDONED<br /> ' Windows abandoned the wait<br /> ShellAndWait = ShellAndWaitResult.SysWaitAbandoned<br /> Exit Do<br /> Case WAIT_OBJECT_0<br /> ' Successful completion<br /> ShellAndWait = ShellAndWaitResult.Success<br /> Exit Do<br /> Case WAIT_FAILED<br /> ' attach failed<br /> ShellAndWait = ShellAndWaitResult.Success<br /> Exit Do<br /> Case WAIT_TIMEOUT<br /> ' Wait timed out. Here, this time out is on DEFAULT_POLL_INTERVAL.<br /> ' See if ElapsedTime is greater than the user specified wait<br /> ' time out. If we have exceed that, get out with a TimeOut status.<br /> ' Otherwise, reissue as wait and continue.<br /> ElapsedTime = ElapsedTime + DEFAULT_POLL_INTERVAL<br /> If Ms > 0 Then<br /> ' user specified timeout<br /> If ElapsedTime > Ms Then<br /> ShellAndWait = ShellAndWaitResult.TimeOut<br /> Exit Do<br /> Else<br /> ' user defined timeout has not expired.<br /> End If<br /> Else<br /> ' infinite wait -- do nothing<br /> End If<br /> ' reissue the Wait on ProcHandle<br /> WaitRes = WaitForSingleObject(ProcHandle, DEFAULT_POLL_INTERVAL)<br /> <br /> Case Else<br /> ' unknown result, assume failure<br /> ShellAndWait = ShellAndWaitResult.Failure<br /> Quit = True<br /> End Select<br />Loop<br /><br />CloseHandle ProcHandle<br />XLapp.EnableCancelKey = SaveCancelKey<br />Exit Function<br /><br />ErrH:<br />Debug.Print "ErrH: Cancel: " & XLapp.EnableCancelKey<br />If Err.Number = ERR_BREAK_KEY Then<br /> If BreakKey = ActionOnBreak.AbandonWait Then<br /> CloseHandle ProcHandle<br /> ShellAndWait = ShellAndWaitResult.UserWaitAbandoned<br /> XLapp.EnableCancelKey = SaveCancelKey<br /> Set XLapp = Nothing<br /> Exit Function<br /> ElseIf BreakKey = ActionOnBreak.IgnoreBreak Then<br /> Err.Clear<br /> Resume<br /> ElseIf BreakKey = ActionOnBreak.PromptUser Then<br /> MsgRes = MsgBox("User Process Break." & vbCrLf & _<br /> "Continue to wait?", vbYesNo)<br /> If MsgRes = vbNo Then<br /> CloseHandle ProcHandle<br /> ShellAndWait = ShellAndWaitResult.UserBreak<br /> XLapp.EnableCancelKey = SaveCancelKey<br /> Else<br /> Err.Clear<br /> Resume Next<br /> End If<br /> Else<br /> 'Debug.Print "Unknown value of 'BreakKey': " & CStr(BreakKey)<br /> CloseHandle ProcHandle<br /> XLapp.EnableCancelKey = SaveCancelKey<br /> ShellAndWait = ShellAndWaitResult.Failure<br /> End If<br />Else<br /> ' some other error. assume failure<br /> CloseHandle ProcHandle<br /> ShellAndWait = ShellAndWaitResult.Failure<br />End If<br /><br />XLapp.EnableCancelKey = SaveCancelKey<br />Set XLapp = Nothing<br /><br />End Function<br /><br /><br />'==========================================================================<br />'==========================================================================<br />'==========================================================================<br />'==========================================================================<br /><br />Function SP_Upload_from_2007(ByRef WBToUpload As Workbook, ByVal UploadPath As String _<br /> , ByVal OutputFilename As String _<br /> , Optional ByVal spPublishXLSM As Boolean = False _<br /> , Optional ByVal spPublishXLSX As Boolean = False _<br /> , Optional ByVal spPublishXLS As Boolean = False _<br /> , Optional ByVal spUploadZipXLSM As Boolean = False _<br /> , Optional ByVal spUploadZipXLSX As Boolean = False _<br /> , Optional ByVal spUploadZipXLS As Boolean = False _<br /> , Optional ByVal spUploadWorksheetAsCSV As Worksheet = Nothing _<br /> , Optional ByVal AllowEvents As Boolean = False, Optional ByVal QuitWhenDone As Boolean = False _<br /> , Optional ByVal AlsoCopyXLSToSharedPath As String = "" _<br /> , Optional ByVal AlsoSaveCopyToSecondaryPath As String = "" _<br /> , Optional ByVal AlsoBreakLinks As Boolean = True) _<br />As String<br />'v4.06 2013-09-23 10:28<br />'[uploads copies of XLSM file as XLSM, XLSX, XLS, unzipped]<br />'[uploads as XLSM, XLSX, XLS, zipped]<br />'[uploads as raw CSV, unzipped]<br />'[also copies XLS to specified path]<br />'[also saves copy to specified path]<br />'--> returns text error message if unsuccessful (good for message boxes)<br /><br />'!! may not always publish versions correctly, need to wait until Upload Center<br />'!! has finished uploading before CheckIn/Out works OK?<br /><br /><br />'=================================================================================<br />' SEE END OF THIS MODULE FOR TYPICAL CODE FOR THISWORKBOOK MODULE<br />'=================================================================================<br />' xlSharePoint.SP_Upload_from_2007 WBToUpload:=ThisWorkbook _<br />' , UploadPath:=ipth _<br />' , OutputFilename:=ofn _<br />' , spPublishXLSM:=True _<br />' , spPublishXLSX:=True _<br />' , spPublishXLS:=True _<br />' , spUploadZipXLSM:=True _<br />' , spUploadZipXLSX:=True _<br />' , spUploadZipXLS:=True _<br />' , spUploadWorksheetAsCSV:=Nothing _<br />' , AllowEvents:=False, QuitWhenDone:=False _<br />' , AlsoCopyXLSToSharedPath:=xpth _<br />' , AlsoSaveCopyToSecondaryPath:=spth _<br />' , AlsoBreakLinks:=True<br />'=================================================================================<br /><br />'validity check, must specify at least one output option<br />If spPublishXLSM = False _<br /> And spPublishXLSX = False _<br /> And spPublishXLS = False _<br /> And spUploadZipXLSM = False _<br /> And spUploadZipXLSX = False _<br /> And spUploadZipXLS = False _<br /> And spUploadWorksheetAsCSV Is Nothing _<br />Then GoTo ErrorHandlerNothingToDo<br /><br />'convert UploadPath to UNC (URL doesn't work) and force connection<br />UploadPath = Replace(UploadPath, cFsl, cBsl)<br />UploadPath = Replace(UploadPath, cURL, "")<br />If Right(UploadPath, 1) <> cBsl Then UploadPath = UploadPath & cBsl<br />SP_Force_Connection UploadPath 'NB: this will close all open Explorer windows<br /><br />If Val(Application.Version) < v7 Then<br /> MsgBox "Error: only for use with Excel 2007/2010. Use SP_Upload_from_2003", vbCritical, "SP_Upload_from_2007" 'v4.05<br /> Exit Function<br />End If<br /><br />Dim blnAEE As Boolean<br />With Application<br /> blnAEE = .EnableEvents<br /> If QuitWhenDone = True Then<br /> .StatusBar = "WARNING: HOLD SHIFT to prevent Excel application quitting when done"<br /> .Wait Now() + TimeSerial(0, 0, 2)<br /> If IsShiftKeyDown = True Then<br /> QuitWhenDone = False<br /> .StatusBar = "Will NOT quit when done"<br /> Else<br /> .StatusBar = "WARNING: Excel will Quit when done. Hold SHIFT to attempt to cancel Quit"<br /> End If<br /> End If<br /> .DisplayAlerts = False<br /> .EnableEvents = AllowEvents<br />End With<br /><br />Dim pth As String, fn As String, wbTemp As Workbook, p As Byte<br /><br />With WBToUpload<br /> <br /> If QuitWhenDone = True Then If InStr(Application.Caption, "Read-Only") = 0 Then .Save 'this file in situ - will quit when done<br /> <br />'!! multiple "." in file name will cause unexpected behaviour here, maybe errors<br /> p = InStr(OutputFilename, ".")<br /> If p = 0 Then p = Len(OutputFilename) + 1<br /> fn = Left(OutputFilename, p - 1) 'fn without file extension<br /> If fn & xxlm = ThisWorkbook.Name Then<br /> 'safety net - workaround is to call master file "(master)"<br /> MsgBox "OutputFilename (" & OutputFilename & xxlm & ") must differ from ThisWorkbook.Name (" & ThisWorkbook.Name & ")" & vbLf & vbLf & "Simple workaround is to include '(master)' in master file name", vbCritical, ""<br /> End<br /> End If<br /><br />'save XLSM [and XLSX] [and XLS] files to temp folder (will be deleted later)<br />On Error GoTo ErrorHandlerTempFailed<br />'Shift+F8 over this line when reviewing<br /> pth = SpecFolder(CSIDL_PERSONAL) & "\BPM Tools\" 'v3.00<br /> If Dir(pth, vbDirectory) <> "." Then MkDir pth<br /> pth = pth & "temp\"<br /> If Dir(pth, vbDirectory) <> "." Then MkDir pth<br />Application.DisplayAlerts = False<br /> .SaveCopyAs pth & fn & xxlm 'save XLSM copy to temp folder<br /> If spPublishXLS = True Or spPublishXLSX = True Or spUploadZipXLS = True Or spUploadZipXLSX = True _<br /> Or AlsoBreakLinks = True Then<br /> Set spXLapp = modAppsOffice.XLlaunch<br />spXLapp.EnableEvents = AllowEvents<br />spXLapp.DisplayAlerts = False<br />On Error Resume Next<br /> Set wbTemp = spXLapp.Workbooks.Open(pth & fn & xxlm)<br /> If wbTemp Is Nothing Then<br /> spXLapp.Workbooks.Open pth & fn & xxlm<br />On Error GoTo ErrorHandlerTempFailed<br /> Set wbTemp = spXLapp.Workbooks(fn & xxlm)<br /> End If<br /> With wbTemp<br /> 'Break Links in XLSM first (converts formulas to values)<br /> If AlsoBreakLinks = True Then<br /> 'code copied from xlUtils (v2.07)<br /> Dim lnk As Variant, i As Integer<br /> lnk = .LinkSources(xlLinkTypeExcelLinks)<br />On Error GoTo NothingToBreak<br /> For i = 1 To UBound(lnk)<br /> .BreakLink lnk(i), xlLinkTypeExcelLinks<br /> Next i<br />spXLapp.EnableEvents = False 'prevents any macros running during this step<br /> .Save<br />spXLapp.EnableEvents = AllowEvents<br />NothingToBreak:<br />On Error GoTo ErrorHandlerTempFailed<br /> End If<br /> 'save XLSX copy to temp (keeps macros temporarily until closed)<br /> If spPublishXLSX = True Or spUploadZipXLSX = True Then .SaveAs pth & fn & xxlx, FileFormat:=51<br /> 'save XLS copy to temp (with macros)<br /> If spPublishXLS = True Or spUploadZipXLS = True Then .SaveAs pth & fn & x2k3 & xxls, FileFormat:=56<br /> .Close False<br /> End With<br /> Set wbTemp = Nothing<br /> spXLapp.Quit<br /> Set spXLapp = Nothing<br /> End If<br />On Error GoTo 0<br /><br /><br />'copy XLS to shared path 'v3.01<br />On Error GoTo ErrorHandlerXLSSharedPathCopyFailed<br />If AlsoCopyXLSToSharedPath <> "" Then<br /> If Right(AlsoCopyXLSToSharedPath, 1) <> cBsl Then AlsoCopyXLSToSharedPath = AlsoCopyXLSToSharedPath & cBsl<br /> FileCopy pth & fn & x2k3 & xxls, AlsoCopyXLSToSharedPath & fn & xxls 'NB: copied without " (2003)" in filename<br />End If<br />On Error GoTo 0<br /><br /><br />'upload (and CheckIn) XLSM to SharePoint<br />On Error GoTo ErrorHandlerXLSMFailed<br /> If spPublishXLSM = True Then<br /> FileCopy pth & fn & xxlm, UploadPath & fn & xxlm<br /> SP_Open_and_CheckIn UploadPath & fn & xxlm<br /> End If<br />On Error GoTo 0<br /> <br />'upload (and CheckIn) XLSX to SharePoint<br />On Error GoTo ErrorHandlerXLSXFailed<br /> If spPublishXLSX = True Then<br /> FileCopy pth & fn & xxlx, UploadPath & fn & xxlx<br /> SP_Open_and_CheckIn UploadPath & fn & xxlx<br /> End If<br />On Error GoTo 0<br /> <br />'upload (and CheckIn) XLS to SharePoint<br />On Error GoTo ErrorHandlerXLSFailed<br /> If spPublishXLS = True Then<br /> FileCopy pth & fn & x2k3 & xxls, UploadPath & fn & x2k3 & xxls<br /> SP_Open_and_CheckIn UploadPath & fn & x2k3 & xxls<br /> End If<br />On Error GoTo 0<br /> <br /><br />'save zip[s] to SharePoint<br /> If spUploadZipXLSM = True Then If Zip7Sub(pth & fn & xxlm, UploadPath & fn & xzip, True, True) <> 0 Then GoTo ErrorHandlerZipXLSMFailed<br /> If spUploadZipXLSX = True Then If Zip7Sub(pth & fn & xxlx, UploadPath & fn & xzip, True, True) <> 0 Then GoTo ErrorHandlerZipXLSXFailed<br /> If spUploadZipXLS = True Then If Zip7Sub(pth & fn & x2k3 & xxls, UploadPath & fn & x2k3 & xzip, True, True) <> 0 Then GoTo ErrorHandlerZipXLSFailed<br /> <br /><br />'remove temp files & folder<br />'NB: only removes temp folder, leaves \\UserDocs\BPM Tools\ folder in place<br /> If Dir(pth & fn & xxlm) <> "" Then Kill pth & fn & xxlm<br /> If Dir(pth & fn & xxlx) <> "" Then Kill pth & fn & xxlx<br /> If Dir(pth & fn & x2k3 & xxls) <> "" Then Kill pth & fn & x2k3 & xxls<br /> If Dir(pth) = "" Then RmDir pth 'only if pth empty<br /> <br /> <br />'upload (and CheckIn) CSV to SharePoint (works for single sheet only)<br />On Error GoTo ErrorHandlerCSVFailed<br /> If Not spUploadWorksheetAsCSV Is Nothing Then<br />Application.DisplayAlerts = False<br /> spUploadWorksheetAsCSV.Copy<br /> Set wbTemp = ActiveWorkbook<br /> With wbTemp<br /> .SaveAs UploadPath & fn & xcsv, FileFormat:=6<br /> .Close False<br /> End With<br /> Set wbTemp = Nothing<br /> SP_Open_and_CheckIn UploadPath & fn & xcsv<br /> End If<br />On Error GoTo 0<br /><br /><br />'upload (and CheckIn?) copy to secondary location<br />On Error GoTo ErrorHandlerSaveCopyAsFailed<br /> If AlsoSaveCopyToSecondaryPath <> "" Then<br /> .SaveCopyAs AlsoSaveCopyToSecondaryPath & fn & xxlm<br /> 'force check in if location is SharePoint<br /> If InStr(AlsoSaveCopyToSecondaryPath, SPdom) > 0 Then SP_Open_and_CheckIn AlsoSaveCopyToSecondaryPath & fn & xxlm<br /> End If<br />On Error GoTo 0<br /> <br /><br /><br />End With 'WBToUpload<br /><br /><br />'clear error message if you got this far - no news is good news<br />SP_Upload_from_2007 = ""<br /><br />With Application<br /> .DisplayAlerts = True<br /> .StatusBar = False<br />If QuitWhenDone = True And IsShiftKeyDown = False Then<br /> Dim wb As Workbook, w As Byte 'v4.05<br /> For Each wb In Workbooks<br /> If UCase(wb.Name) <> "PERSONAL.XLSB" Then w = w + 1<br /> Next wb<br /> If w = 1 Then Application.Quit Else ThisWorkbook.Close False<br />End If<br /> .EnableEvents = blnAEE<br />End With<br />Exit Function<br /><br /><br />ErrorHandler:<br /> SP_Upload_from_2007 = "SP_Upload_from_2007: failed" '!! very blunt<br /> GoTo CleanUp<br /><br />ErrorHandlerNothingToDo:<br /> SP_Upload_from_2007 = "SP_Upload_from_2007: nothing to do! Must specify at least one output option"<br /> GoTo CleanUp<br /><br />ErrorHandlerTempFailed:<br /> SP_Upload_from_2007 = "SP_Upload_from_2007: couldn't save to temp folder"<br /> GoTo CleanUp<br /><br />ErrorHandlerSaveCopyAsFailed:<br /> SP_Upload_from_2007 = "SP_Upload_from_2007: SaveCopyAs failed"<br /> GoTo CleanUp<br /><br />ErrorHandlerCSVFailed:<br /> SP_Upload_from_2007 = "SP_Upload_from_2007: CSV failed"<br /> GoTo CleanUp<br /><br />ErrorHandlerXLSFailed:<br /> SP_Upload_from_2007 = "SP_Upload_from_2007: XLS failed"<br /> GoTo CleanUp<br /><br />ErrorHandlerXLSXFailed:<br /> SP_Upload_from_2007 = "SP_Upload_from_2007: XLSX failed"<br /> GoTo CleanUp<br /><br />ErrorHandlerXLSMFailed:<br /> SP_Upload_from_2007 = "SP_Upload_from_2007: XLSM failed"<br /> GoTo CleanUp<br /><br />ErrorHandlerZipXLSFailed:<br /> SP_Upload_from_2007 = "SP_Upload_from_2007: zipped XLS failed"<br /> GoTo CleanUp<br /><br />ErrorHandlerZipXLSXFailed:<br /> SP_Upload_from_2007 = "SP_Upload_from_2007: zipped XLSX failed"<br /> GoTo CleanUp<br /><br />ErrorHandlerZipXLSMFailed:<br /> SP_Upload_from_2007 = "SP_Upload_from_2007: zipped XLSM failed"<br /> GoTo CleanUp<br /><br />ErrorHandlerXLSSharedPathCopyFailed:<br /> SP_Upload_from_2007 = "SP_Upload_from_2007: XLS copy to shared drive path failed"<br /> GoTo CleanUp<br /><br />CleanUp:<br />If Not wbTemp Is Nothing Then wbTemp.Close False<br />If Not spXLapp Is Nothing Then spXLapp.Quit<br />End Function<br /><br />Function SP_Upload_from_2003(ByVal spulPath As String, ByVal spulFileName As String _<br /> , Optional spulSheetName As String) As Boolean<br />'v2.04 2013-07-25 08:59<br />'WARNING: if SharePoint is set to require CheckOut, this will NOT publish the file<br />'only works with UNC (can be converted to use URL)<br />'spulSheetName<>"" will copy that sheet to new WB and upload<br />'spulSheetName="" will hide "admin" sheet and upload entire workbook<br /><br />With Application<br /> If Val(.Version) >= v7 Then<br /> MsgBox "Error: only for use with Excel 2003. Use SP_Upload_XLS_and_XLSM", vbCritical, "SP_Upload_XLS_and_XLSM"<br /> Exit Function<br /> End If<br /> .DisplayAlerts = False<br />End With<br /><br />Dim wb As Workbook, i As Integer, ipthfn As String, lnk As Variant<br />ipthfn = cBsl & Replace(spulPath & cBsl, cBsl & cBsl, cBsl) & spulFileName<br /><br />With ThisWorkbook<br />On Error Resume Next<br /> .Sheets(spulSheetName).Copy 'creates new WB only if spulSheetName specified<br />On Error GoTo 0<br />End With<br /><br />Set wb = ActiveWorkbook 'either ThisWorkbook or single-sheet file<br />With wb<br /> If wb.Name = ThisWorkbook.Name And spulSheetName <> "" Then<br /> MsgBox spulSheetName & " did not copy to new WB.", vbCritical, "error in SP_UPload"<br /> End<br /> ElseIf spulSheetName <> "" Then<br /> 'break links in new one-sheet file<br />On Error Resume Next<br /> Set lnk = wb.LinkSources(xlLinkTypeExcelLinks)<br /> For i = 1 To UBound(lnk)<br /> wb.BreakLink lnk(i), xlLinkTypeExcelLinks<br /> Next i<br /> 'save WB to SharePoint<br />On Error GoTo SaveFailed<br /> .SaveCopyAs ipthfn 'will overwrite existing<br />On Error GoTo 0<br /> 'now close extra WB, not required<br /> .Close False<br /> 'save copy of Master to SharePoint (i.e. alongside single sheet report)<br /> With ThisWorkbook<br />On Error Resume Next<br /> .Sheets(wsA).Visible = False<br />On Error GoTo SaveFailed<br /> 'overwrite existing, this works for xxls and xxlm (xxlm = xxls & "m")<br /> '!! doesn't work for .xlb<br /> .SaveCopyAs Replace(ipthfn, xxls, " (master)" & xxls)<br />On Error Resume Next<br /> .Sheets(wsA).Visible = True<br />On Error GoTo 0<br /> End With<br /> Else<br /> 'save copy of Master to SharePoint as WB<br /> With ThisWorkbook 'WB is ThisWorkbook<br />On Error Resume Next<br /> .Sheets(wsA).Visible = False<br />On Error GoTo SaveFailed<br /> .SaveCopyAs ipthfn 'will overwrite existing<br />On Error Resume Next<br /> .Sheets(wsA).Visible = True<br />On Error GoTo 0<br /> End With<br /> End If<br />End With<br /><br />SP_Upload_from_2003 = True<br />Exit Function<br /><br />SaveFailed:<br />SP_Upload_from_2003 = False<br />If InStr(Application.Name, "Excel") > 0 Then Application.StatusBar = "ERROR in SP_Upload_from_2003: save failed"<br />End 'leaves this workbook AND unsaved report open in Excel (theoretically)<br />End Function<br /><br />Function SP_Open_and_CheckIn(ByVal PathAndFileName As String, Optional ByVal AllowEvents As Boolean = False) As Byte<br />'**** BETA VERSION ****<br />'v4.07b 2013-09-26 16:00<br />'forces CheckIn<br />'!! untested with folders that force CheckOut<br /><br />'ErrorCodes as Byte:<br />' 0 = no need to CheckIn / successfully CheckedIn<br />' 1 = couldn't Open<br />' 2 = couldn't CheckOut<br />' 3 = couldn't CheckIn<br />' 8 = pathfile doesn't exist / pathfile access error<br /><br />PathAndFileName = Replace(PathAndFileName, "/", "\")<br />PathAndFileName = Replace(PathAndFileName, "http:", "")<br /><br />'try to CheckOut file and then CheckInWithVersion<br />Application.DisplayAlerts = False<br /> Set spXLapp = modAppsOffice.XLlaunch '(True, False)<br /> With spXLapp<br /> '.DisplayAlerts = False 'bypasses any warnings, not advisable for testing<br /> .EnableEvents = AllowEvents<br /> <br /> If Dir(PathAndFileName) = "" Then<br /> SP_Open_and_CheckIn = 8 'file not found<br /> Else<br /> <br /> If .Workbooks.CanCheckOut(PathAndFileName) = True Then GoTo FinishOff 'SP_Open_and_CheckIn = 0<br /> <br /> '[CheckOut then] CheckInWithVersion<br /> '!! untested, try to just CheckInWithVersion first<br /> If .Workbooks(PathAndFileName).CanCheckIn = True Then .Workbooks(PathAndFileName).CheckInWithVersion False, "Published " & Now(), True<br /> <br /> On Error GoTo OpenFailed<br /> .Workbooks.Open FileName:=PathAndFileName<br /> On Error GoTo 0<br /> <br /> On Error GoTo CheckOutFailed<br /> .Workbooks.CheckOut PathAndFileName<br /> On Error GoTo 0<br /> <br /> On Error GoTo CheckInFailed<br /> .Workbooks(PathAndFileName).CheckInWithVersion False, "Published " & Now(), True<br /> On Error GoTo 0<br /> <br /> End If<br /> End With<br />'implied success!<br />GoTo FinishOff<br /><br />OpenFailed:<br /> SP_Open_and_CheckIn = 1<br /> GoTo FinishOff<br /><br />CheckOutFailed:<br /> SP_Open_and_CheckIn = 2<br /> GoTo FinishOff<br /><br />CheckInFailed:<br /> SP_Open_and_CheckIn = 3<br /> GoTo FinishOff<br /><br />FinishOff:<br /> spXLapp.Quit<br /> Set spXLapp = Nothing<br /><br />End Function<br />Function SPsetsl() As String<br />'v1.05 2013-03-04 16:04<br /><br />If Left(fn_SPpth, 5) = cURL Then SPsetsl = cFsl Else SPsetsl = cBsl<br /><br />End Function<br /><br />Function SP_Check_Special(ByVal str As String) As Boolean<br />'v2.05 2013-07-25 18:57<br />'checks string for invalid special characters (True=valid or False=invalid)<br />'~ " # % & * < > ? { | } .. \ or : and /<br /><br />SP_Check_Special = True 'unless it fails<br /><br />Const p As String = "."<br />If Right(str, 1) = p Then SP_Check_Special = False<br /><br />Const bmax As Byte = 14<br />Dim sc() As String<br />ReDim sc(bmax) As String<br />sc(0) = "~"<br />sc(1) = Chr(34) ' Chr(34) = "<br />sc(2) = "#"<br />sc(3) = "%"<br />sc(4) = "&"<br />sc(5) = "*"<br />sc(6) = ".."<br />sc(7) = "<"<br />sc(8) = ">"<br />sc(9) = "?"<br />sc(10) = "{"<br />sc(11) = "|"<br />sc(12) = "}"<br />If SPsetsl = cFsl Then<br /> sc(bmax - 1) = ""<br /> sc(bmax) = cBsl<br />Else:<br /> sc(bmax - 1) = ":"<br /> sc(bmax) = cFsl<br />End If<br />'sc(15) = cbsl 'disabled to allow checking of pth names<br />Dim b As Byte<br />For b = 0 To bmax<br /> If sc(b) <> "" And InStr(str, sc(b)) > 0 Then SP_Check_Special = False<br />Next b<br /><br />End Function<br /><br />Function fn_SPpth(Optional ByVal TestURLPath As String) As String<br />'v1.15 2013-05-22 11:18<br />'determines SPpth (set top of module) as either UNC or URL for this user<br />'URL uploads won't work if UNC is working<br />'use this function instead of SPpth in code<br />'test with Left,1 = cBsl<br />'also forces SharePoint connection (refresh user and password)<br /><br />If TestURLPath = "" Then TestURLPath = SPpth<br /><br />'Const cPrd As String = "."<br />Dim v As String<br /><br />'test for UNC first, more reliable<br /> fn_SPpth = Replace(Replace(TestURLPath, cURL, ""), cFsl, cBsl)<br />On Error Resume Next<br /> v = Dir(fn_SPpth, vbDirectory)<br />On Error GoTo 0<br /> If v = cPrd Then<br /> 'UNC works, use UNC for SPpth (already set)<br /> 'fn_SPpth = Replace(Replace(SPpth, cURL, ""), cFsl, cBsl)<br /> Else<br /> 'UNC doesn't work, must use URL for SPpth (change it back)<br /> fn_SPpth = TestURLPath<br /> End If<br /><br />End Function<br /><br />Function SPDelFile(ByVal pthfn_to_delete As String) As Boolean<br />'v2.00 2013-07-10 13:01<br />'deletes file<br />'UNC reports True if deleted, False if not<br />'URL always reports True even if delete failed<br /><br />Dim isUNC As Boolean<br /><br />Bludgeon:<br />'try to force deletion by all available methods<br />On Error Resume Next<br />Select Case xlSharePoint.SPsetsl 'v2.00<br /> Case cBsl 'UNC - just delete it<br /> isUNC = True<br /> Kill Replace(Replace(pthfn_to_delete, cURL, ""), cFsl, cBsl)<br /> Case cFsl 'URL - force deletion via URL and UNC<br /> isUNC = False<br /> Kill pthfn_to_delete<br /> Kill Replace(Replace(pthfn_to_delete, cURL, ""), cFsl, cBsl)<br />End Select<br />On Error GoTo 0<br /><br />'check UNC address for deletion<br />If isUNC = True Then<br />'UNC - check file exists<br /> If Dir(pthfn_to_delete) = "" Then<br /> 'success!<br /> SPDelFile = True<br /> Else<br /> 'failure!<br /> SPDelFile = False<br /> End If<br />Else<br />'if URL - always assume successful delete and pray it worked<br /> SPDelFile = True<br />End If<br /><br />End Function<br /><br />Function SP_pth_sl(ByVal PathToAddSlash As String, Optional DoURL As Boolean) As String<br />'v3.00b 2013-07-29 22:40<br />'adds a slash to end of path as required<br />'DoURL tries to force URL but will be overridden if URL is 'detected'<br /><br />'commented v1.15, consts are set public<br />'Const cFsl As String = "/" 'URL<br />'Const cBsl As String = "\" 'UNC<br />'Const cURL As String = "http://"<br /><br />'!! can only specify URL if DoURL=True<br />If DoURL = True And Left(PathToAddSlash, Len(cURL)) <> cURL Then _<br /> MsgBox "a URL must be specified if DoURL=True", vbCritical, "error in zSP_pth_sl"<br /><br />'if Path includes http then force DoURL (NB: fn_SPpth will determine UNC or URL)<br />If DoURL = False And Left(PathToAddSlash, Len(cURL)) = cURL Then _<br /> DoURL = True<br /><br />If DoURL = True And Right(PathToAddSlash, 1) <> cFsl Then<br /> SP_pth_sl = PathToAddSlash & cFsl<br /> Exit Function<br />ElseIf Right(PathToAddSlash, 1) <> cBsl Then<br /> SP_pth_sl = PathToAddSlash & cBsl<br /> Exit Function<br />Else<br /> SP_pth_sl = PathToAddSlash<br />End If<br /><br />End Function<br /><br />Function SP_fn_val(sFileName As String, Optional sReplaceInvalidWith As String = "_") As String<br />'v3.00b 2013-07-29 22:40<br />'Purpose : Removes invalid characters from a filename<br />'Inputs : sFileName The file name to clean the invalid characters from.<br />' [sReplaceInvalidWith] The text to replace any invalid characters with.<br />'Outputs : Returns a valid filename.<br />'Author : Andrew Baker<br />'Date : 25/03/2001<br />'Notes : http://www.vbusers.com/code/codeget.asp?ThreadID=578&PostID=1<br /><br />Const csInvalidChars As String = ":\/?*<>|"""<br />Dim lThisChar As Long<br />SP_fn_val = sFileName<br />'Loop over each invalid character, removing any instances found<br />For lThisChar = 1 To Len(csInvalidChars)<br /> SP_fn_val = Replace$(SP_fn_val, Mid(csInvalidChars, lThisChar, 1), sReplaceInvalidWith)<br />Next<br /><br />End Function<br /><br />Function v_MM() As String<br />'v1.00 2012-11-29 14:37<br />'converts to 2 digit month<br /><br />v_MM = Month(Now())<br />If Len(v_MM) = 1 Then v_MM = "0" & v_MM<br /><br />End Function<br /><br />Function v_DD() As String<br />'v1.00 2012-11-29 14:37<br />'converts to 2 digit date<br /><br />v_DD = Day(Now())<br />If Len(v_DD) = 1 Then v_DD = "0" & v_DD<br /><br />End Function<br /><br />Function SPUseCheckOut(docCheckOut As String, Optional TestFirst As Boolean _<br /> , Optional ForceUNC As Boolean) As Workbook<br />'v2.00 2013-07-10 13:01<br />'Source:<br />'http://social.msdn.microsoft.com/Forums/hu-HU/isvvba/thread/25609303-dc29-4cf4-a526-977bf6129e78<br /><br />'Sub test_SPUseCheckOut()<br />'Dim wb As Workbook<br />'Workbooks.Open src<br />'Set wb = ActiveWorkbook<br />'Dim docCheckOut As String<br />'docCheckOut = wb.FullName<br />'Call xlSharePoint.SPUseCheckOut(docCheckOut)<br />' **********************<br />' * now work with file *<br />' * when finished: *<br />' **********************<br />'wb.CheckInWithVersion True 'also closes wb<br />'End Sub<br /><br />Dim wb As Workbook<br />Dim UPathName As String, UCheckOut As String<br />For Each wb In Workbooks<br /> If ForceUNC = True Then<br /> 'represent both paths as UNC address<br /> UPathName = UCase(Replace(Replace(wb.Name, cURL, ""), cFsl, cBsl))<br /> UCheckOut = UCase(Replace(Replace(wb.Name, cURL, ""), cFsl, cBsl))<br /> Else<br /> 'represent both paths as URL address<br /> UPathName = UCase(Replace(Replace(wb.Name, cBsl & cBsl, cURL & cFsl & cFsl), cBsl, cFsl))<br /> UCheckOut = UCase(Replace(Replace(wb.Name, cBsl & cBsl, cURL & cFsl & cFsl), cBsl, cFsl))<br /> End If<br /> If UPathName = UCheckOut Then<br /> 'already open<br /> 'determine if workbook can be checked in<br /> 'only works if already Checked Out to you<br /> If wb.CanCheckIn = True Then wb.CheckInWithVersion True 'close & save then reopen later<br /> Exit For<br /> End If<br />Next wb<br /><br />If TestFirst = True Then<br />' Determine if workbook can be checked out first<br /> If Workbooks.CanCheckOut(docCheckOut) = True Then<br /> Workbooks.CheckOut docCheckOut<br /> Set SPUseCheckOut = Workbooks(docCheckOut)<br /> Else<br /> 'MsgBox "Unable to check out " & docCheckOut & " at this time."<br /> End If<br />Else<br />' just try to check it out anyway<br /> Application.Wait Now() + TimeSerial(0, 0, 2) 'prevents time delay errors after uploading / CheckIn<br /> Workbooks.CheckOut docCheckOut<br /> Set SPUseCheckOut = Workbooks(docCheckOut)<br />End If<br /><br />End Function<br /><br />Sub SP_OfferToCheckInAllWorkbooks()<br />'v5.02 2013-12-18 10:24 - added underscore to macro name<br />'v1.15 2013-05-22 11:23<br />'check if ThisWorkbook opened from SharePoint then offer to close all<br /><br />Dim pp As String, tt As String<br /><br />'check if ThisWorkbook opened from SharePoint<br /><br />tt = ThisWorkbook.FullName<br />If InStr(tt, SPdom) > 0 Then<br /><br />'offer to close all<br /> <br /> tt = ThisWorkbook.Name<br /> pp = "Yes to close, save and CheckIn THIS workbook only," & vbLf _<br /> & "No to close, save and CheckIn ALL open workbooks (use with caution)"<br /> If MsgBox(pp, vbExclamation Or vbYesNo, tt) = vbNo Then<br /> Dim wb As Workbook<br /> For Each wb In Workbooks<br /> On Error Resume Next<br /> If wb.Name <> tt Then<br /> wb.CheckIn<br /> wb.Close True<br /> End If<br /> On Error GoTo 0<br /> Next wb<br /> End If<br />End If<br /><br />End Sub<br /><br />Function SP_Force_Connection(Optional ByVal UNCPathAndOrFilename As String = "defaultUNCpath") As Boolean<br />'v5.05 2014-01-10 14:27 - bugfix for zips (remove "" from ends)<br />'v5.03 2014-01-08 10:24 - now accepts filenames at end of path<br />'v5.02 2013-12-18 10:28 - added option for default UNCpath<br />'v5.00 2013-12-02 16:17<br />'!! NB: not totally suitable for end user processes, may close ALL instances of Explorer (file browser)<br />' 1. launches UNC in Explorer window<br />' 2. tries to close Explorer window<br />' 3. if 2 unsuccessful, kills all open instances of Explorer then relaunches Taskbar (!! messy)<br /><br />If UNCPathAndOrFilename = "defaultUNCpath" Then UNCPathAndOrFilename = fn_SPpth(SPpth)<br /><br />'v5.03 remove file name from UNCpath and extract last folder name for Windows Explorer title bar<br />Dim p As String, f As String, b As Integer, s() As Integer, c As Byte<br />p = Replace(UNCPathAndOrFilename, Chr(34), "")<br />b = InStr(p, "\")<br />While b > 0<br /> c = c + 1 'count slashes<br /> ReDim Preserve s(1 To c) As Integer 'add another slash character count<br /> s(c) = b<br /> b = InStr(s(c) + 1, p, "\")<br />Wend<br />If c > 0 Then<br /> p = Left(p, s(c)) 'full 'root' path without last filename (or folder name) so "C:\Folder\Filename.txt" > "C:\Folder\"<br /> If c = 1 Then f = p Else f = Mid(p, s(c - 1) + 1, s(c) - 1 - s(c - 1)) 'folder name (in Explorer title bar) so "C:\Folder\Filename.txt" > "Folder" NB: "C:\" > "C:\"<br />End If<br /><br />SP_Force_Connection = True<br /><br />'easy option first, see if UNC already connected<br />On Error Resume Next<br />Dim testfn As String<br />testfn = Dir(p, vbDirectory)<br />If testfn = "." Then Exit Function<br />On Error GoTo 0<br /><br />'open UNC in Explorer, try to close specific Explorer window<br />ShellAndWait "explorer " & p, 10000, vbHide, AbandonWait<br />If SP_CloseExplorerWindow(f) = False Then 'v5.00<br />'use brute force, close all Explorer windows, reopen Taskbar<br /> ShellAndWait "TaskKill /F /IM ""explorer.exe""", 1000, vbHide, AbandonWait<br /> Shell "C:\Windows\explorer.exe"<br />End If<br /><br />'test UNC connection<br />On Error Resume Next<br />testfn = Dir(p, vbDirectory)<br />If testfn <> "." Then SP_Force_Connection = False<br />On Error GoTo 0<br /><br />End Function<br /><br />Function SP_CloseExplorerWindow(ByVal sCurrentFolderName As String) As Boolean<br />'v5.05 2014-01-10 14:27 - bugfix<br />'v5.04 2014-01-09 17:11 - bugfix<br />'v5.00 2013-12-02 16:12<br />'Function returns "True" if successful, otherwise "False"<br />'Amended from Source:<br />' http://gallery.technet.microsoft.com/scriptcenter/3879dd1b-09a1-4a9f-95ca-529351a7e2ac<br /><br />If sCurrentFolderName = "" Then Exit Function<br /><br />Dim bTest, wndw<br />bTest = False<br />With CreateObject("shell.application")<br /> For Each wndw In .Windows<br /> If wndw.Document.Folder = sCurrentFolderName Then<br /> On Error Resume Next<br /> wndw.Quit<br /> bTest = Err.Number = 0<br /> On Error GoTo 0<br /> End If<br /> Next<br />End With ' shell.application<br />SP_CloseExplorerWindow = CStr(bTest)<br /><br />End Function<br /><br /><br /><br /><br />'=================================================================================<br />' TYPICAL CODE FOR THISWORKBOOK MODULE:<br />'=================================================================================<br /><br />'Option Explicit<br />'<br />'Private Const MasterUserID As String = "bpmgb" 'admin user ID, all other userIDs won't process<br />''Private Const MasterUserIDList As String = "Sales Admin" 'admin user list<br />'Private Const MasterIdent As String = " (master)" 'identifier that this is the master file, not a published file<br />'Private Const ipth As String = "\\ishare.dhl.com\sites\DGFUK\GBOFR\OFR Management\" 'SharePoint location<br />'Private Const xpth As String = "" 'XLS to shared drive, set "" if not required<br />'Private Const spth As String = "\\ishare.dhl.com\sites\DGFUK\Sales\TLM\Logis Reports\" 'SaveCopyAs to secondary location, set "" if not required<br />'Private Const ofn As String = "(Logis Ocean) LCL Customers by Trade Lane" 'output filename must not include MasterIdent<br />'Private Const cVBAfilename As String = "VBA UPDATE WEEKLY REPORTS.XLSM" 'this wb open means automatic updates in process<br />'Private bStopLoop As Boolean<br />'Public bAutoVBA As Boolean<br />'<br />'Private Sub Workbook_BeforeClose(Cancel As Boolean)<br />'<br />'If bStopLoop = True Then Exit Sub<br />'If InStr(ThisWorkbook.Name, MasterIdent) = 0 Then Exit Sub<br />'<br />''choose one<br />'If CU_userID(MasterUserID) = False Then Exit Sub<br />''If CU_Controlled(MasterUserIDList) = False Then Exit Sub<br />'<br />'bStopLoop = True<br />'<br />'bAutoVBA = chkAutoVBA<br />'<br />'Dim tt As String, pp As String, mbxr As VbMsgBoxResult<br />'tt = "doPublish"<br />'pp = "Save and publish files to SharePoint?"<br />'If bAutoVBA Then mbxr = vbYes Else mbxr = MsgBox(pp, vbYesNo Or vbQuestion, tt)<br />'If mbxr = vbYes Then<br />' Application.StatusBar = "Publishing files to SharePoint..."<br />' tt = "doPublish failed"<br />' pp = doPublish(True) 'this will save then quit when done<br />' If bAutoVBA = False And pp <> "" Then MsgBox pp, vbCritical, tt<br />' Application.StatusBar = False<br />'Else<br />' pp = "Just save?"<br />' If bAutoVBA Then mbxr = vbYes Else mbxr = MsgBox(pp, vbYesNo, "")<br />' If mbxr = vbYes Then ThisWorkbook.Save<br />' Dim wb As Workbook, w As Byte<br />' For Each wb In Workbooks<br />' If UCase(wb.Name) <> "PERSONAL.XLSB" Then w = w + 1<br />' Next wb<br />' If w = 1 Then Application.Quit Else ThisWorkbook.Close False<br />'End If<br />'<br />'End Sub<br />'<br />'Private Function chkAutoVBA() As Boolean<br />'<br />'Dim wb As Workbook<br />'If InStr(Application.Caption, "Read-Only") > 0 Then<br />' chkAutoVBA = True<br />'Else<br />' For Each wb In Workbooks<br />' If UCase(wb.Name) = UCase(cVBAfilename) Then<br />' chkAutoVBA = True<br />' Exit Function<br />' End If<br />' Next wb<br />'End If<br />'<br />'End Function<br />'<br />'Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)<br />'<br />'If bStopLoop = True Then Exit Sub<br />'If InStr(ThisWorkbook.Name, MasterIdent) = 0 Then Exit Sub<br />'<br />''choose one<br />'If CU_userID(MasterUserID) = False Then Exit Sub<br />''If CU_Controlled(MasterUserIDList) = False Then Exit Sub<br />'<br />'bAutoVBA = chkAutoVBA<br />'<br />'bStopLoop = True<br />'<br />'Dim tt As String, pp As String, mbxr As VbMsgBoxResult<br />'tt = "doPublish"<br />'pp = "Save and publish files to SharePoint?"<br />'If bAutoVBA Then mbxr = vbYes Else mbxr = MsgBox(pp, vbYesNo Or vbQuestion, tt)<br />'If mbxr = vbYes Then<br />'Application.StatusBar = "Publishing files to SharePoint..."<br />' tt = "doPublish failed"<br />' pp = doPublish(False)<br />' If pp <> "" And bAutoVBA = False Then MsgBox pp, vbCritical, tt<br />'Application.StatusBar = False<br />'End If<br />'<br />'bStopLoop = False<br />'<br />'End Sub<br />'<br />'Function doPublish(ByVal QuitWhenDone As Boolean) As String<br />'<br />''choose one<br />'If CU_userID(MasterUserID) = False Then Exit Function<br />''If CU_Controlled(MasterUserIDList) = False Then Exit Function<br />'<br />''If ThisWorkbook.Sheets.Count > 1 Then xlUtils.xlU_Export_Single_Sheets xpth, False, True, True<br />'<br />''NB: outputs are optional, but must specify at least one<br />'doPublish = xlSharePoint.SP_Upload_from_2007(WBToUpload:=ThisWorkbook _<br />' , UploadPath:=ipth _<br />' , OutputFilename:=ofn _<br />' , spUploadZipXLSM:=True _<br />' , AllowEvents:=False, QuitWhenDone:=QuitWhenDone _<br />' , AlsoCopyXLSToSharedPath:=xpth _<br />' , AlsoSaveCopyToSecondaryPath:=spth _<br />' , AlsoBreakLinks:=True)<br />'<br />'End Function<br />'<br />'Private Sub Workbook_Open()<br />'<br />'If CU_userID(MasterUserID) = False Then Exit Sub<br />'<br />'bAutoVBA = chkAutoVBA<br />'<br />''run invisible to fully automate<br />'If Application.Visible = False Then<br />' Application.Visible = True<br />' ThisWorkbook.RefreshAll<br />' bStopLoop = True<br />' ThisWorkbook.Save<br />' doPublish True<br />'End If<br />'<br />'End Sub<br /><br /></span></span></span></blockquote>
baldmosher™http://www.blogger.com/profile/11281471751951639119noreply@blogger.com0Stretford M17 1QA, UK53.4609149 -2.318959400000039853.4609149 -2.3189594000000398 53.4609149 -2.3189594000000398tag:blogger.com,1999:blog-7264479838117802346.post-27387504655726035232013-08-05T09:03:00.000-07:002013-08-09T04:43:45.970-07:00VBA Modules: Excel: xlPivots v1.00<a href="http://baldywritten.blogspot.com/2013/08/vba-modules-modzip-v502aaa.html" target="_blank">Read this</a> for full information on these modules<br />
Does what it says on the tin.... dead simple stuff but pretty useful when you're in a hurry and have a workbook with 20 pivot tables.<br />
<br />
<blockquote class="tr_bq">
<span style="font-size: x-small;"><span style="font-family: "Courier New",Courier,monospace;">'xlPivots<br />'v1.00 201x-xx-xx hh:mm<br /><br />'===========================================================================<br />' HELP CONTACT<br />'===========================================================================<br />' Code is provided without warranty and can be stolen and amended as required.<br />' Tom Parish<br />' TJP@tomparish.me.uk<br />' http://baldywrittencod.blogspot.com<br />' DGF Help Contact: see BPMHelpContact module<br />'=========================================================================<br /><br />'===========================================================================<br />' xlPivots<br />'===========================================================================<br />' This module quickly enables/disables drilling/savedata in all pivots<br /><br />'Version History:<br />' v1.00<br /><br />Option Explicit<br /><br />Sub xlPiv_disable_drills()<br />'v1.00 201x-xx-xx hh:mm<br /><br />Dim sh As Worksheet, pt As PivotTable<br />For Each sh In ThisWorkbook.Worksheets<br /> For Each pt In sh.PivotTables<br /> With pt<br /> .EnableDrilldown = False<br /> End With<br /> Next pt<br />Next sh<br /><br />End Sub<br /><br />Sub xlPiv_enable_drills()<br />'v1.00 201x-xx-xx hh:mm<br /><br />Dim sh As Worksheet, pt As PivotTable<br />For Each sh In ThisWorkbook.Worksheets<br /> For Each pt In sh.PivotTables<br /> With pt<br /> .EnableDrilldown = True<br /> End With<br /> Next pt<br />Next sh<br /><br />End Sub<br /><br />Sub xlPiv_disable_save_data()<br />'v1.00 201x-xx-xx hh:mm<br /><br />Dim sh As Worksheet, pt As PivotTable<br />For Each sh In ThisWorkbook.Worksheets<br /> For Each pt In sh.PivotTables<br /> With pt<br /> .SaveData = False<br /> End With<br /> Next pt<br />Next sh<br /><br />End Sub<br /><br />Sub xlPiv_enable_save_data()<br />'v1.00 201x-xx-xx hh:mm<br /><br />Dim sh As Worksheet, pt As PivotTable<br />For Each sh In ThisWorkbook.Worksheets<br /> For Each pt In sh.PivotTables<br /> With pt<br /> .SaveData = True<br /> End With<br /> Next pt<br />Next sh<br /><br />End Sub</span></span></blockquote>
baldmosher™http://www.blogger.com/profile/11281471751951639119noreply@blogger.com0Stretford M17 1QA, UK53.4609149 -2.318959400000039853.4609149 -2.3189594000000398 53.4609149 -2.3189594000000398tag:blogger.com,1999:blog-7264479838117802346.post-33550769099985947982013-08-05T09:00:00.000-07:002013-11-26T09:17:44.961-08:00VBA Modules: Excel: xlErrorLog v1.03a<a href="http://baldywritten.blogspot.com/2013/08/vba-modules-modzip-v502aaa.html" target="_blank">Read this</a> for full information on these modules<br />
<br />
This nifty little Excel module stores errors in a log when running a long, complex macro, and then "dumps" them to an Excel worksheet when it's fnished. There are a number of ways to do this, so this might not exactly fit your needs, and you may well already have a better solution, but this has worked for me a couple of times.<br />
<br />
Note that "emsg" is a fairly blunt way of controlling the log macro, it's fully annotated though so it should make sense how it works.<br />
<br />
<blockquote class="tr_bq">
<span style="font-family: "Courier New",Courier,monospace; font-size: xx-small;">'xlErrorLog<br />'v1.03a 2013-08-09 12:26<br /><br />'===========================================================================<br />' HELP CONTACT<br />'===========================================================================<br />' Code is provided without warranty and can be stolen and amended as required.<br />' Tom Parish<br />' TJP@tomparish.me.uk<br />' http://baldywrittencod.blogspot.com<br />' DGF Help Contact: see BPMHelpContact module<br />'=========================================================================<br /><br />'===========================================================================<br />' xlErrorLog<br />'===========================================================================<br />'<br />' errorlog("New")<br />' Creates "Error Log" sheet in WB if not there already<br />' --> Error Log sheet contains 2 columns:<br />' Date & Time<br />' Description<br />'<br />' errorlog("Description")<br />' Records error with timestamp as elog([0=t|1=d], e)<br />'<br />' errorlog("Dump")<br />' Dumps errors into log sheet when finished<br /><br />'===========================================================================<br />' Additional modules required:<br />'===========================================================================<br />' xlUtils v2.00<br /><br />'=====================================================================<br />' VERSION HISTORY<br />'=====================================================================<br />' v1.03 module renamed; xlUtils bugfix; annotations improved<br />' v1.02 rSort bugfix; annotations improved<br />' v1.01 added option to replace duplicates<br />' v1.00 created<br /><br />Option Explicit<br /><br />Public elog() As String<br /><br />Sub errorlog(ByVal emsg As String _<br /> , Optional ByVal ReplaceDuplicates As Boolean = True)<br />'v1.03 2013-05-23 11:37<br />'"New" creates new errorlog<br />'"Dump" dumps errorlog<br />'"Any other message" is added to errorlog as new error<br />'ReplaceDuplicates = False will always add errors to list<br />'[ReplaceDuplicates = True] updates timestamps for existing errors<br />'--> Previous run record is left in place, i.e. fixed errors remain in<br />' original position in the list when rerun. If errors reoccur, the<br />' timestamp is updated, and moved to below the latest heading.<br /><br />Const emsgNew As String = "New"<br />Const emsgDump As String = "Dump"<br /><br />If emsg = emsgNew Then GoTo LogNew<br />If emsg = emsgDump Then GoTo LogDump<br /><br />Dim e As Long, etitle As String, bRD As Boolean, pp As String, tt As String<br />Dim rSort As Range<br /><br />On Error GoTo LogNew 'errors when elog() not elog(n,n)<br />For e = 0 To 0<br /> etitle = elog(0, 0)<br />Next e<br />On Error GoTo 0<br />GoTo LogExists<br /><br /><br /><br />LogNew:<br />'==============================<br />' CREATE ERROR LOG IN MEMORY<br />'==============================<br />On Error GoTo 0<br />If e < 1 Then 'error log not started<br /> ReDim elog(1, 0) As String<br /> elog(0, 0) = Now()<br /> elog(1, 0) = ""<br /> Exit Sub<br />End If<br /><br /><br /><br />LogExists:<br />'==============================<br />' ADD TO ERROR LOG IN MEMORY<br />'==============================<br />e = 0<br />On Error GoTo AddError<br /> Do Until elog(0, e) = "" 'elog(0, 0) is always date & time report is run<br /> If elog(1, e) = emsg Then<br /> Exit Sub 'stops duplicate errors, also stops repeating errors found in previous errorlogs<br /> End If<br /> e = e + 1 'increments to find next available e<br /> Loop<br />AddError:<br />On Error GoTo 0<br />ReDim Preserve elog(1, e) As String<br />etitle = elog(1, 0)<br />If Left(etitle, 15) = "NO ERRORS FOUND" Then<br /> etitle = Mid(etitle, 4, Len(etitle)) & ":"<br />End If<br />elog(1, 0) = etitle<br />elog(0, e) = Now()<br />elog(1, e) = emsg<br />Exit Sub<br /><br /><br /><br />LogDump:<br />'=============================<br />' DUMP ERROR LOG ONTO SHEET<br />'=============================<br />Dim wsE As Worksheet<br />Const wsEn As String = "Error Log"<br />With ThisWorkbook<br />If xlUtils.xlU_SheetExists(wsEn, ThisWorkbook) = True Then<br /> For Each wsE In .Worksheets<br /> If wsE.Name = wsEn Then Exit For<br /> Next wsE<br />Else<br /> Set wsE = .Sheets.Add(After:=.Sheets(.Sheets.Count))<br /> With wsE<br /> .Name = wsEn<br /> With .Range("A1:B2")<br /> .Interior.ColorIndex = 36<br /> .Font.Bold = True<br /> End With<br /> .Cells(1, 1) = "ERROR LOG"<br /> .Cells(2, 1) = "Date & Time"<br /> .Cells(2, 2) = "Error"<br /> End With<br />End If<br />End With<br /><br />Dim f As Long, n As Long, d As Long<br /><br />'count existing number of rows in error log<br /> f = Application.CountA(wsE.Columns(1))<br /><br />'!ERROR!<br />'dump all errors to log ONLY if errors exist<br />'(0,0) is always Now()<br />'if 1st error exists, always at (0,1) and (1,1)<br />'if 2nd error exists, always at (0,2) and (1,2)<br />'!! runtime error 9 = trying to dump before elog(0,0) started<br /> If Left(elog(1, 0), 15) = "NO ERRORS FOUND" Then<br /> MsgBox elog(0, 0) & vbLf & "Completed: no errors found"<br /> Else<br /> 'elog(1,0) = "ERRORS FOUND WHEN...."<br />On Error GoTo DoneDump<br /> Do Until elog(0, e) = ""<br /> d = 0 'd > 0 if duplicate error found<br />On Error Resume Next<br /> d = Application.Match(elog(1, e), wsE.Columns(2), 0)<br />On Error GoTo DoneDump<br /> If e > 0 And d > 0 And ReplaceDuplicates = True Then<br /> 'duplicate error, just update timestamp (sorted later)<br /> wsE.Cells(d, 1).Value = elog(0, e)<br /> Else<br /> 'new error, or new list of errors, add to end of list<br /> With wsE.Cells(1, 1).End(xlDown).Offset(1, 0)<br /> With .Offset(n, 0)<br /> .Value = elog(0, e)<br /> If e = 0 Then .Bold = True Else .Bold = False 'only for first message<br /> End With<br /> With .Offset(n, 1)<br /> .Value = elog(1, e)<br /> If e = 0 Then .Bold = True Else .Bold = False 'only for first message<br /> End With<br /> End With<br /> n = n + 1 'next new error<br /> End If<br /> e = e + 1 'next error<br /> Loop<br /> End If<br />DoneDump:<br />On Error GoTo 0<br /> tt = "errorlog"<br /> 'If Not f = Application.CountA(wsE.Columns(1)) Then<br /> If n > 0 Then 'new errors exist<br /> If ReplaceDuplicates = True Then<br /> 'existing replaced, must be new errors added<br /> pp = elog(0, 0) & vbLf & "New errors - check log"<br /> MsgBox pp, vbExclamation, tt<br /> Else 'all errors added to end of list<br /> pp = elog(0, 0) & vbLf & "Errors - check log"<br /> MsgBox pp, vbExclamation, tt<br /> End If<br /> Else 'no new errors, but may be some existing errors recurring<br /> pp = elog(0, 0) & vbLf & "Completed: no new errors found"<br /> MsgBox pp, vbInformation, tt<br /> End If<br />'sort by date & time to move updated errors to the end<br /> With wsE<br /> .Activate<br /> Set rSort = .Cells(2, 1)<br /> Set rSort = .Range(rSort.End(xlToRight), rSort.End(xlDown))<br /> rSort.Sort Key1:=.Columns(1), Order1:=xlAscending, Header:=xlYes<br /> End With<br />'empty elog<br />ReDim elog(0 To 0) As String<br /><br />End Sub</span></blockquote>
baldmosher™http://www.blogger.com/profile/11281471751951639119noreply@blogger.com0Stretford M17 1QA, UK53.4609149 -2.318959400000039853.4609149 -2.3189594000000398 53.4609149 -2.3189594000000398tag:blogger.com,1999:blog-7264479838117802346.post-39408348795636817462013-08-05T08:56:00.000-07:002013-08-09T04:45:28.252-07:00VBA Modules: Excel: xlClipboard v1.01<a href="http://baldywritten.blogspot.com/2013/08/vba-modules-modzip-v502aaa.html" target="_blank">Read this</a> for full information on these modules<br />
<br />
It's not often that I need simple code like this now, but this is where it all started for me, saving keyboard shortcuts for Excel's Paste As [Values|Formats|Formulas]. (A bit pointless, as it turned out, because Alt, E, S, [V|T|F] is pretty easy to remember and type out!)<br />
<br />
I adapted this module MUCH later with a great little piece of code to clear the clipboard from the <a href="http://officeone.mvps.org/vba/clear_clipboard.html" target="_blank">Office MVPs website</a> and another from <a href="http://excelexperts.com/copy-values-vba" target="_blank">ExcelExperts.com</a> that "copies and pastes values" without using the clipboard. I have to say that I never got that "vanilla" code working reliably for my needs, but the code's still pretty useful as a start point for my own ideas, so have a play with it, it might work out for you.<br />
<br />
I've later improved on those ideas myself as I got better at VBA by creating specific functions to transfer different cell attributes (e.g. cell Validation rules). Refer to my <b>xlUtils </b>module for those more advanced functions.<br />
<br />
<blockquote class="tr_bq">
<span style="font-family: "Courier New",Courier,monospace;"><span style="font-size: x-small;">'xlClipboard<br />'v1.01a 2013-08-09 12:24<br /><br />'===========================================================================<br />' HELP CONTACT<br />'===========================================================================<br />' Code is provided without warranty and can be stolen and amended as required.<br />' Tom Parish<br />' TJP@tomparish.me.uk<br />' http://baldywrittencod.blogspot.com<br />' DGF Help Contact: see BPMHelpContact module<br />'=========================================================================<br /><br />'===========================================================================<br />' xlClipboard<br />'===========================================================================<br />' Excel-specific and general Office Clipboard functions<br /><br />'===========================================================================<br />' Additional modules required:<br />'===========================================================================<br />' None<br /><br />'===========================================================================<br />' Additional References required:<br />'===========================================================================<br />' Microsoft Excel Object Library (if not running from Excel)<br /><br />'=========================================================================<br />' VERSION HISTORY<br />'=========================================================================<br />'<br /><br />Option Explicit<br /><br />Declare Function CloseClipboard Lib "user32" () As Long<br />Declare Function EmptyClipboard Lib "user32" () As Long<br />Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long<br />Enum PasteAs<br />copyByValue = 1<br />copyByFormula = 2<br />End Enum<br /><br />Sub ClearClipboard()<br />'source: http://officeone.mvps.org/vba/clear_clipboard.html<br />'needs declared module functions above<br />OpenClipboard 0&<br />EmptyClipboard<br />CloseClipboard<br />End Sub<br /><br />Sub CopyPasteWithoutClipboard(rngSource As Range, rngTarget As Range, lngPasteType As PasteAs, Optional blnTranspose As Boolean = False)<br />'source: http://excelexperts.com/copy-values-vba<br />'Do not use this procedure with filtered/hidden rows as it considers all hidden/filtered cells<br />'While transposing only values can be transposed not formulae<br />'Merged cells are not considered<br /><br />Dim lngCalc As Long<br />Dim lngEvents As Long<br /><br />With Application<br />lngCalc = .Calculation<br />lngEvents = .EnableEvents<br />If Not .EnableEvents = False Then .EnableEvents = False<br />If Not .Calculation = xlCalculationManual Then .Calculation = xlCalculationManual<br />End With<br /><br />Select Case lngPasteType<br />Case copyByValue<br />If blnTranspose Then<br />rngTarget.Resize(rngSource.Columns.Count, rngSource.Rows.Count).Value = Application.Transpose(rngSource.Value)<br />Else<br />rngTarget.Resize(rngSource.Rows.Count, rngSource.Columns.Count).Value = rngSource.Value<br />End If<br />Case copyByFormula<br />If blnTranspose Then<br />rngTarget.Resize(rngSource.Columns.Count, rngSource.Rows.Count).Value = Application.Transpose(rngSource.Value)<br />Else<br />rngTarget.Resize(rngSource.Rows.Count, rngSource.Columns.Count).Formula = rngSource.FormulaR1C1<br />End If<br />End Select<br /><br />With Application<br />If Not .Calculation = lngCalc Then .Calculation = lngCalc<br />If Not .EnableEvents = lngEvents Then .EnableEvents = lngEvents<br />End With<br /><br />End Sub<br />Sub Test_CopyPasteWithoutClipboard()<br />'source: http://excelexperts.com/copy-values-vba<br />'Call CopyPasteWithoutClipboard(Sheet1.Range("A1").CurrentRegion, Sheet2.Range("A1"), copyByValue)<br />End Sub<br /><br /><br /><br /><br /><br /><br /><br /><br /><br />Sub PasteComments()<br />'<br />' Keyboard Shortcut: Ctrl+Shift+C<br />'<br /> Selection.PasteSpecial Paste:=xlPasteComments, Operation:=xlNone, _<br /> SkipBlanks:=False, Transpose:=False<br />End Sub<br /><br />Sub PasteFormulas()<br />'<br />' Keyboard Shortcut: Ctrl+Shift+Q<br />'<br /> Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _<br /> SkipBlanks:=False, Transpose:=False<br />End Sub<br /><br />Sub PasteValues()<br />'<br />' Keyboard Shortcut: Ctrl+Shift+V<br />'<br /> Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _<br /> :=False, Transpose:=False<br /><br />End Sub<br /><br />Sub PasteFormats()<br />'<br />' Keyboard Shortcut: Ctrl+Shift+T<br />'<br /> Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _<br /> SkipBlanks:=False, Transpose:=False<br /> <br />End Sub<br /><br />Sub Paste_Transpose()<br />'<br />' Keyboard Shortcut: Ctrl+Shift+E<br />'<br /> Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _<br /> False, Transpose:=True<br /><br />End Sub</span></span></blockquote>
baldmosher™http://www.blogger.com/profile/11281471751951639119noreply@blogger.com0Stretford M17 1QA, UK53.4609149 -2.318959400000039853.4609149 -2.3189594000000398 53.4609149 -2.3189594000000398tag:blogger.com,1999:blog-7264479838117802346.post-33091612749914092382013-08-05T08:37:00.000-07:002013-10-08T08:15:33.777-07:00VBA Modules: modAppsFirefox v3.04NB: updated 2013-09-02 - v3 works with <b>modProcedures</b><br />
<br />
<a href="http://baldywritten.blogspot.com/2013/08/vba-modules-modzip-v502aaa.html" target="_blank">Read this</a> for full information on these modules<br />
<br />
Another deadly simple and endlessly useful module, lifted from <a href="http://www.mrexcel.com/forum/excel-questions/568204-opening-url-firefox-excel.html" target="_blank">Mr Excel</a>. Note that you can do a lot of things automatically with Firefox if you install the <a href="https://addons.mozilla.org/en-US/firefox/addon/lastpass-password-manager/" target="_blank">LastPass</a> addon, which stores your site login information and automatically logs in to a site. This means you can easily download a remote file from a web server somewhere just by opening the URL for the file using <b>ff_GetDownload</b>. I don't think it's usually necessary to log in to the site first, LastPass will handle that, but it certainly doesn't do any harm, it just opens an extra FF tab.<br />
<br />
When downloading a file, Firefox will save the actual <b>filename.ext</b> with 0 bytes as a placeholder, and create <b>filename.ext.part</b> which is the actual downloading file. When FF completes the download, it'll delete the original <b>filename.ext </b>file, and rename the <b>filename.ext.part</b> file to <b>filename.ext</b>. So when it's completed the download, <b>filename.ext </b>will instantly be > 0 bytes.<br />
<br />
Code for Sleep:<br />
<blockquote class="tr_bq">
<span style="font-family: "Courier New",Courier,monospace;"><span style="font-size: x-small;">'source: http://www.vboffice.net/sample.html?mnu=2&lang=en&smp=56&cmd=showitem&pub=6<br />Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliSeconds As Long)<br /><br />Private Const fwLoginURL As String = "http://forwin.dhl.com" 'can be set to any site login<br /><br />Public Sub Sleep_Test()<br />'source: http://www.vboffice.net/sample.html?mnu=2&lang=en&smp=56&cmd=showitem&pub=6<br /> Sleep 3000<br /> MsgBox "Hello"<br />End Sub</span></span></blockquote>
<br />
This uses code from <b>modSpecialFolders </b>to find the location of the user's <b>Downloads </b>folder but you can also hard-code the path if preferred.<br />
<br />
I've never managed to get Internet Explorer to work in the same way, (un)surprisingly Microsoft just don't make it easy. There's plenty of support online if you really must use IE, e.g. if your corporate policy doesn't permit LastPass for automatic logins.<br />
<br />
<blockquote class="tr_bq">
<span style="font-family: "Courier New",Courier,monospace;"><span style="font-size: x-small;"><span style="font-size: xx-small;">'modAppsFirefox<br />'v3.04 2013-09-20 13:32<br /><br />'===========================================================================<br />' HELP CONTACT<br />'===========================================================================<br />' Code is provided without warranty and can be stolen and amended as required.<br />' Tom Parish<br />' TJP@tomparish.me.uk<br />' http://baldywrittencod.blogspot.com<br />' DGF Help Contact: see BPMHelpContact module<br />'=========================================================================<br /><br />'===========================================================================<br />' modAppsFirefox<br />'===========================================================================<br />' macros to load URL in Firefox, based on open source code:<br />' http://www.mrexcel.com/forum/excel-questions/568204-opening-url-firefox-excel.html<br />'<br />' Automatically determines standard Windows 7 Downloads folder location.<br />' Specify custom Downloads folder location as Private Const below.<br />'<br />' Save your site login details with the LastPass addon, and make sure it's<br />' set to always autologin to the site.<br /><br />'===========================================================================<br />' Additional modules required:<br />'===========================================================================<br />' modFile v1.03<br />'<br />' Code included from other modules:<br />' [modSpecialFolders]<br /><br />'===========================================================================<br />' Additional References required:<br />'===========================================================================<br />' None<br /><br />'===========================================================================<br />' External applications required:<br />'===========================================================================<br />' Mozilla Firefox<br />' LastPass Firefox Addon<br /><br />'===========================================================================<br />' VERSION HISTORY<br />'===========================================================================<br />' v3.04 minor edit, variable name change in modFile<br />' v3.03 ffGetSimultDownloads counts .part files in DLs folder<br />' v3.02 always wait for completion if running outside office hours<br />' v3.01 ffGetDownload = ffFileURL for queued downloads when max dl reached<br />' v3.00 works with modProcedures<br />' v2.01 ff_GetDownload: added ffLoginTime and improved ffSleepTime usage<br />' added ErrorHandlerNoFile<br />' v2.00 transferred code from modSpecialFolders<br />' v1.06 ff_GetDownload: bugfix, potentially .part file is newer<br />' v1.05 ff_GetDownload: redesigned download completion detection<br />' extended ffSleepTime<br />' improved annotations<br />' v1.04 added Private Const ffSleepTime<br />' v1.03 ff_GetDownload: only waits for site login if necessary<br />' v1.02 transferred ff_GetDownload from modForwin (was Forwin_GetDownload)<br />' v1.01aa renamed modAppsFirefox<br />' v1.01a annotations only<br />' v1.01 refers modSpecialFolders<br />' v1.00 original code from source:<br />' http://www.mrexcel.com/forum/excel-questions/568204-opening-url-firefox-excel.html<br /><br />Option Explicit<br /><br />Private Const ffSpecifyDownloadFolder As String = ""<br />'source: http://www.vboffice.net/sample.html?mnu=2&lang=en&smp=56&cmd=showitem&pub=6<br />Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliSeconds As Long)<br /><br />Private Const ffLoginTime As Long = 20000 'v2.01, 10s is too short to allow login and file transfer to begin<br />'!! if 1000ms causes issues, try a longer time<br />Private Const ffSleepTime As Long = 1000 'v1.05, ms, i.e. 10000ms = 10s<br /><br />'NB: Firefox can only run N simultaneous downloads, must store further URLs as Download procedures<br />'!! may need to improve this by clearing completed downloads? (i.e. run modProcedures.mp_Run_Procedures on sheets 1 and 2)<br />Public Const ffMaxSimultDownloads As Byte = 5 'v3.03 'v3.01<br />Private Const ffDownloadWaitTime As Long = 60000 'v3.01 - only if ffWaitForCompletion = True<br /><br />Private Const ffOffHrsMin As Byte = 9 'ALWAYS waits if Now < this<br />Private Const ffOffHrsMax As Byte = 18 'ALWAYS waits if Now > this<br />Private Const ffWEDay1 As String = "Sat" 'ALWAYS waits if running on Sat<br />Private Const ffWEDay2 As String = "Sun" 'change to Mon or "" as applicable to your country<br /><br />Public ffCompleted As Boolean 'v3.00<br /><br /><br />'=================================================================================================<br />'=================================================================================================<br />'=================================================================================================<br />'=================================================================================================<br /><br />'<br />' Code from modSpecialFolders module:<br />'<br /><br />'http://answers.microsoft.com/en-us/office/forum/office_2010-customize/how-2-refer-to-desktop/97eba910-54c9-409f-9454-6d7c8d54d009<br />Private Declare Function SHGetSpecialFolderLocation _<br /> Lib "shell32" (ByVal hwnd As Long, _<br /> ByVal nFolder As Long, ppidl As Long) As Long<br /><br />Private Declare Function SHGetPathFromIDList _<br /> Lib "shell32" Alias "SHGetPathFromIDListA" _<br /> (ByVal Pidl As Long, ByVal pszPath As String) As Long<br /><br />Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal pvoid As Long)<br /><br />'Desktop<br />Private Const CSIDL_INTERNET = &H1 'Internet Explorer (icon on desktop)<br />Private Const CSIDL_PROGRAMS = &H2 'Start Menu\Programs<br />Private Const CSIDL_CONTROLS = &H3 'My Computer\Control Panel<br />Private Const CSIDL_PRINTERS = &H4 'My Computer\Printers<br />Private Const CSIDL_PERSONAL = &H5 'My Documents<br />Private Const CSIDL_FAVORITES = &H6 '<user name>\Favorites<br />Private Const CSIDL_STARTUP = &H7 'Start Menu\Programs\Startup<br />Private Const CSIDL_RECENT = &H8 '<user name>\Recent<br />Private Const CSIDL_SENDTO = &H9 '<user name>\SendTo<br />Private Const CSIDL_BITBUCKET = &HA '<desktop>\Recycle Bin<br />Private Const CSIDL_STARTMENU = &HB '<user name>\Start Menu<br />Private Const CSIDL_DESKTOPDIRECTORY = &H10 '<user name>\Desktop<br />Private Const CSIDL_DRIVES = &H11 'My Computer<br />Private Const CSIDL_NETWORK = &H12 'Network Neighborhood<br />Private Const CSIDL_NETHOOD = &H13 '<user name>\nethood<br />Private Const CSIDL_FONTS = &H14 'Windows\fonts<br />Private Const CSIDL_TEMPLATES = &H15<br />Private Const CSIDL_COMMON_STARTMENU = &H16 'All Users\Start Menu<br />Private Const CSIDL_COMMON_PROGRAMS = &H17 'All Users\Programs<br />Private Const CSIDL_COMMON_STARTUP = &H18 'All Users\Startup<br />Private Const CSIDL_COMMON_DESKTOPDIRECTORY = &H19 'All Users\Desktop<br />Private Const CSIDL_APPDATA = &H1A '<user name>\Application Data<br />Private Const CSIDL_PRINTHOOD = &H1B '<user name>\PrintHood<br />Private Const CSIDL_LOCAL_APPDATA = &H1C '<user name>\Local Settings\Application Data (non roaming)<br />Private Const CSIDL_ALTSTARTUP = &H1D 'non localized startup<br />Private Const CSIDL_COMMON_ALTSTARTUP = &H1E 'non localized common startup<br />Private Const CSIDL_COMMON_FAVORITES = &H1F<br />Private Const CSIDL_INTERNET_CACHE = &H20<br />Private Const CSIDL_COOKIES = &H21<br />Private Const CSIDL_HISTORY = &H22<br />Private Const CSIDL_COMMON_APPDATA = &H23 'All Users\Application Data<br />Private Const CSIDL_WINDOWS = &H24 'Windows Directory<br />Private Const CSIDL_SYSTEM = &H25 'System Directory<br />Private Const CSIDL_PROGRAM_FILES = &H26 'C:\Program Files<br />Private Const CSIDL_MYPICTURES = &H27 'C:\Program Files\My Pictures<br />Private Const CSIDL_PROFILE = &H28 'USERPROFILE<br />Private Const CSIDL_SYSTEMX86 = &H29 'x86 system directory on RISC<br />Private Const CSIDL_PROGRAM_FILESX86 = &H2A 'x86 C:\Program Files on RISC<br />Private Const CSIDL_PROGRAM_FILES_COMMON = &H2B 'C:\Program Files\Common<br />Private Const CSIDL_PROGRAM_FILES_COMMONX86 = &H2C 'x86 Program Files\Common on RISC<br />Private Const CSIDL_COMMON_TEMPLATES = &H2D 'All Users\Templates<br />Private Const CSIDL_COMMON_DOCUMENTS = &H2E 'All Users\Documents<br />Private Const CSIDL_COMMON_ADMINTOOLS = &H2F 'All Users\Start Menu\Programs\Administrative Tools<br />Private Const CSIDL_ADMINTOOLS = &H30 '<user name>\Start Menu\Programs\Administrative Tools<br />Private Const CSIDL_CONNECTIONS = &H31 'Network and Dial-up Connections<br />Private Const MAX_PATH = 260<br />Private Const NOERROR = 0<br /><br />Private Function SpecFolder(ByVal lngFolder As Long) As String<br />Dim lngPidlFound As Long<br />Dim lngFolderFound As Long<br />Dim lngPidl As Long<br />Dim strPath As String<br /><br />strPath = Space(MAX_PATH)<br />lngPidlFound = SHGetSpecialFolderLocation(0, lngFolder, lngPidl)<br />If lngPidlFound = NOERROR Then<br /> lngFolderFound = SHGetPathFromIDList(lngPidl, strPath)<br /> If lngFolderFound Then<br /> SpecFolder = Left$(strPath, _<br /> InStr(1, strPath, vbNullChar) - 1)<br /> End If<br />End If<br />CoTaskMemFree lngPidl<br />End Function<br /><br />Sub Test_OpenFireFoxNewTab()<br /> OpenInFireFoxNewTab "http://www.mrexcel.com/forum/forumdisplay.php?f=10"<br />End Sub<br /><br />Sub OpenInFireFoxNewTab(url As String)<br />'v2.00 2013-08-09 11:59<br /> Dim pathFireFox As String<br /> pathFireFox = SpecFolder(CSIDL_PROGRAM_FILES) & "\Mozilla Firefox\firefox.exe" 'v1.01<br /> If Dir(pathFireFox) = "" Then pathFireFox = "C:\Program Files (x86)\Mozilla Firefox\firefox.exe"<br /> If Dir(pathFireFox) = "" Then pathFireFox = "C:\Program Files\Mozilla Firefox\firefox.exe"<br /> If Dir(pathFireFox) = "" Then<br /> MsgBox "FireFox Path Not Found", vbCritical, "Macro Ending"<br /> Exit Sub<br /> End If<br /> Shell """" & pathFireFox & """" & " -new-tab " & url, vbHide<br />End Sub<br /><br />Function ff_GetDownload(ByVal ffFileURL As String, ByVal ffFileExt As String _<br /> , Optional ByVal ffNewFileName As String, Optional ByVal ffWaitForCompletion As Boolean) As String<br />'v3.04 2013-09-20 13:32<br />'launches FireFox, logs in to web server, downloads Filename.FileExt<br />'then renames to specified [ffNewFileName] OR [cDefaultFilename].[ffFileExt]<br />'reports back new path & filename (NB: default is [userpath]\Downloads\[cDefaultFilename].[ffFileExt])<br />'v3.00 can report back temporary filename for use with modProcedures<br /><br />ffCompleted = False 'v3.00<br /><br />Const ffLoginURL As String = "" 'optional, forces login before launching actual URL<br />Dim sCount As Byte 'counts and limits number of sleeps<br /><br />On Error Resume Next 'validity checks done at end<br /><br />If ffGetCurrentSimultDownloads < ffMaxSimultDownloads Then 'v3.01<br /> 'download this file<br /> <br /> 'launch web server in FF (automatic login is handled with LastPass addon)<br /> If ffLoginURL <> "" Then<br /> modAppsFirefox.OpenInFireFoxNewTab ffLoginURL<br /> 'wait for LastPass to log in<br /> Sleep ffLoginTime<br /> End If<br /> <br /> 'launch URL to download (FF will automatically download files to user's specified Downloads folder)<br /> Dim dCreatedDate As Double<br /> dCreatedDate = Now() 'records date & time file creation was started, prevents false "newset file" matches<br /> modAppsFirefox.OpenInFireFoxNewTab ffFileURL<br /> <br /> 'minimum pause for LastPass to log in to site, and file transfer to begin<br /> '!! take care: if this causes the wrong file to be detected, increase ffLoginTime<br /> Sleep ffLoginTime<br /> <br /> 'get file name for NEWEST file in Downloads folder<br /> 'Firefox creates file.ext.part AND file.ext<br /> Dim pthDL As String, ffDownloadingFile As String<br /> pthDL = ffSpecifyDownloadFolder 'can specify path as Private Const<br /> If pthDL = "" Then pthDL = Replace(SpecFolder(CSIDL_PERSONAL), "\Documents", "\Downloads\") 'also adds trailing slash<br />FindNewestFile:<br /> ffDownloadingFile = modFile.mfLoopThroughFilesInAFolder(mfPath:=pthDL, mfNewestFile:=True, mfNewestFileNewerThan:=dCreatedDate) 'v3.04<br /> If ffDownloadingFile = "" Then<br /> 'newest file not found, wait then try again<br /> sCount = sCount + 1<br /> Sleep ffSleepTime<br /> If sCount < 10 Then GoTo FindNewestFile 'prevent endless loop<br /> End If<br /> If ffDownloadingFile = "" Then GoTo ErrorHandlerNoFile<br /> ffDownloadingFile = Replace(ffDownloadingFile, ".part", "") 'catch potential errors due to .part file being newer<br /> <br /> 'whilst downloading, file.ext placeholder will exist with 0 bytes, file.ext.part is temporary downloading file<br /> 'on completion, file.ext wil be deleted, then file.ext.part will be renamed, so file.ext will be >0 bytes<br /> 'v3.02 regardless of user setting, always wait for completion if running outside office hours<br /> If ffWaitForCompletion = True _<br /> Or Hour(Now()) < ffOffHrsMin _<br /> Or Hour(Now()) >= ffOffHrsMax _<br /> Or Format(Now(), "Ddd") = ffWEDay1 _<br /> Or Format(Now(), "Ddd") = ffWEDay2 _<br /> Then<br /> Dim f1 As Double<br /> On Error Resume Next<br /> f1 = FileLen(ffDownloadingFile)<br /> Do While f1 = 0<br /> 'when download completes, ffDownloadingFile is deleted (i.e. error) then reappears with f1 > 0<br /> f1 = FileLen(ffDownloadingFile)<br /> Loop<br /> On Error GoTo 0<br /> ffCompleted = True<br /> <br /> 'rename downloaded file if specified<br /> 'NB: renaming .csv to .xls will cause you problems!<br /> If ffNewFileName <> "" Then<br /> 'use specified filename<br /> ff_GetDownload = ffNewFileName<br /> Else<br /> 'use default download filename<br /> Const cDefaultFilename As String = "Downloaded Web Server Report." ' & ffFileExt<br /> Const cPrd As String = "."<br /> ffFileExt = Replace(LCase(ffFileExt), cPrd, "")<br /> ff_GetDownload = cDefaultFilename & ffFileExt<br /> End If<br /> 'before renaming download file, kill target filename, if it exists<br /> If Dir(ff_GetDownload) <> "" Then Kill ff_GetDownload<br /> 'rename/move downloaded file<br /> Name ffDownloadingFile As ff_GetDownload<br /> <br /> <br /> 'validity check to confirm download completed<br /> If Dir(ff_GetDownload) = "" Then<br /> 'downloaded file doesn't exist, something went wrong<br /> MsgBox "Downloaded file not found", vbCritical, "Error in ff_GetDownload"<br /> GoTo ErrorHandlerNoFile<br /> End If<br /> <br /> Else 'ffWaitForCompletion = False AND during business hours<br /> 'don't wait, store the first N download procedures for processing later<br /> 'NB: capture this in parent macro<br /> ff_GetDownload = ffDownloadingFile<br /> 'NB: ff_GetDownload <> ffNewFileName<br /> <br /> End If<br /><br />Else<br />'too many simultaneous downloads already, store this download URL for later<br />'NB: must capture this in parent macro<br /> ff_GetDownload = ffFileURL<br /><br />End If<br /><br />On Error GoTo 0<br />Exit Function<br /><br />ErrorHandlerNoFile:<br />ff_GetDownload = ""<br />End Function<br /><br />Function ffGetCurrentSimultDownloads() As Byte<br />'v3.03 2013-09-13 11:05<br />'counts .part files in Downloads folder<br />'Firefox can only run ffMaxSimultDownloads<br /><br />Dim pthDL As String<br />Const ffDLpartfile As String = ".part"<br />pthDL = ffSpecifyDownloadFolder 'can specify path as Private Const<br />If pthDL = "" Then pthDL = Replace(SpecFolder(CSIDL_PERSONAL), "\Documents", "\Downloads\") 'also adds trailing slash<br />ffGetCurrentSimultDownloads = modFile.mfLoopThroughFilesInAFolder(mfPath:=pthDL _<br /> , mfSearchString:=ffDLpartfile, mfCountMatches:=True)<br /><br />End Function</span></span></span></blockquote>
baldmosher™http://www.blogger.com/profile/11281471751951639119noreply@blogger.com0Stretford M17 1QA, UK53.4609149 -2.318959400000039853.4609149 -2.3189594000000398 53.4609149 -2.3189594000000398tag:blogger.com,1999:blog-7264479838117802346.post-67970079603343444112013-08-05T08:26:00.000-07:002013-10-08T08:17:09.016-07:00VBA Modules: modFile v1.05<a href="http://baldywritten.blogspot.com/2013/08/vba-modules-modzip-v502aaa.html" target="_blank">Read this</a> for full information on these modules<br />
<br />
This module contains a few useful VBA file and folder functions. I've lifted most of this from StackOverflow and Mr Excel and other forums, it's all fairly simple stuff.<br />
<br />
<blockquote class="tr_bq">
<span style="font-family: "Courier New",Courier,monospace;"><span style="font-size: x-small;"><span style="font-size: xx-small;">'modFile<br />'v1.05 2013-09-20 13:33<br /><br />'===========================================================================<br />' HELP CONTACT<br />'===========================================================================<br />' Code is provided without warranty and can be stolen and amended as required.<br />' Tom Parish<br />' TJP@tomparish.me.uk<br />' http://baldywrittencod.blogspot.com<br />' DGF Help Contact: see BPMHelpContact module<br />'=========================================================================<br /><br />'===========================================================================<br />' modFile<br />'===========================================================================<br />' Provides various VBA file & folder functions<br /><br />'===========================================================================<br />' Additional modules required:<br />'===========================================================================<br />' None<br /><br />'===========================================================================<br />' Additional References required:<br />'===========================================================================<br />' None<br /><br />'===========================================================================<br />' External applications required:<br />'===========================================================================<br />' None<br /><br />'=========================================================================<br />' VERSION HISTORY<br />'=========================================================================<br />' v1.05 mfLoopThroughFilesInAFolder: bugfix for NewerThan and variable name change<br />' v1.04 mfLoopThroughFilesInAFolder: function reports back Variant<br />' mfLoopThroughFilesInAFolder: will count pattern matches<br />' v1.03a annotations only<br />' v1.03 added mfLoopThroughFilesInAFolder<br />' added mfGetDateCreated<br />' v1.02a annotations only<br />' v1.02 addded mfGetFileExtension<br />' v1.01 added mf prefix to macronames<br />'************************************************************************<br />' v1.00 created from Allen Browne original code<br /><br />Option Explicit<br /><br />Function mfFileExists(ByVal strFile As String, Optional bFindFolders As Boolean) As Boolean<br />'Purpose: Return True if the file exists, even if it is hidden.<br />'Arguments: strFile: File name to look for. Current directory searched if no path included.<br />' bFindFolders. If strFile is a folder, mfFileExists() returns False unless this argument is True.<br />'Note: Does not look inside subdirectories for the file.<br />'Author: Allen Browne. http://allenbrowne.com June, 2006.<br />Dim lngAttributes As Long<br /><br />'Include read-only files, hidden files, system files.<br />lngAttributes = (vbReadOnly Or vbHidden Or vbSystem)<br /><br />If bFindFolders Then<br /> lngAttributes = (lngAttributes Or vbDirectory) 'Include folders as well.<br />Else<br /> 'Strip any trailing slash, so Dir does not look inside the folder.<br /> Do While Right$(strFile, 1) = "\"<br /> strFile = Left$(strFile, Len(strFile) - 1)<br /> Loop<br />End If<br /><br />'If Dir() returns something, the file exists.<br />On Error Resume Next<br />mfFileExists = (Len(Dir(strFile, lngAttributes)) > 0)<br /><br />End Function<br /><br />Function mfFolderExists(strPath As String) As Boolean<br /> On Error Resume Next<br /> mfFolderExists = ((GetAttr(strPath) And vbDirectory) = vbDirectory)<br />End Function<br /><br />Function mfTrailingSlash(varIn As Variant) As String<br /> If Len(varIn) > 0 Then<br /> If Right(varIn, 1) = "\" Then<br /> mfTrailingSlash = varIn<br /> Else<br /> mfTrailingSlash = varIn & "\"<br /> End If<br /> End If<br />End Function<br /><br />Function mfGetFileExtension(ByVal mfFileName As String) As String<br />'v1.02 2013-04-12 14:58<br />'reports characters after and including the LAST fullstop/period<br />'e.g. "File Name v3.45.xlsm" result is ".xlsm"<br /><br />Const cPrd As String = "."<br />Dim b As Byte, c As Byte, pp As String, tt As String<br />b = InStr(1, mfFileName, cPrd) 'find first period in string<br />If b = 0 Then<br />'no periods found = no file extension<br /> mfGetFileExtension = cPrd<br />Else<br />'make sure b is the last period in string<br /> c = b<br /> Do Until c = 0<br /> c = InStr(b + 1, mfFileName, cPrd)<br /> If c <> 0 Then b = c<br /> Loop<br /> mfGetFileExtension = cPrd & Right(mfFileName, Len(mfFileName) - b)<br />End If<br />End Function<br /><br />Function mfGetDateCreated(ByVal mfPathAndFileName As String) As Double<br />'v1.03 2013-07-18 16:05<br />'source: http://www.mrexcel.com/forum/excel-questions/73458-read-external-file-properties-date-created-using-visual-basic-applications.html<br /><br /> Dim oFS As Object<br /><br /> 'This creates an instance of the MS Scripting Runtime FileSystemObject class<br /> Set oFS = CreateObject("Scripting.FileSystemObject")<br /><br /> 'MsgBox mfPathAndFileName & " was created on " & oFS.GetFile(mfPathAndFileName).DateCreated<br /> mfGetDateCreated = oFS.GetFile(mfPathAndFileName).DateCreated<br /><br /> Set oFS = Nothing<br /><br />End Function<br /><br />Function mfLoopThroughFilesInAFolder(ByVal mfPath As String _<br /> , Optional ByVal mfSearchString As String = "" _<br /> , Optional ByVal mfNewestFile As Boolean = False, Optional ByVal mfNewestFileNewerThan As Double _<br /> , Optional ByVal mfCountMatches As Boolean)<br />'v1.05 2013-09-20 13:33<br />'original source: http://stackoverflow.com/questions/10380312/loop-through-files-in-a-folder-using-vba<br />'searches in order of variables specified, only ever searches one variable<br />'Usage:<br />' if mfSearchString is specified, searches for pattern match in filename<br />' if mfNewestFile is specified, searches for newest file created<br />' if mfCountMatches is True, counts pattern matches, mfSearchString is also required<br />' NB: mfNewestFileNewerThan [i.e. Now()] should also be specified as a validity check for search range<br /><br />Const cBsl As String = "\"<br />If Right(mfPath, 1) <> cBsl Then mfPath = mfPath & cBsl<br /><br />Dim mfFile As Variant<br /><br />If mfSearchString = "" And mfNewestFile = False Then 'mfFilenameMinLen = 0 And<br /> MsgBox "Must search for filename string OR minimum length of filename OR look for newest file"<br /> Exit Function<br /><br />ElseIf mfSearchString <> "" Then<br />'search for pattern match<br /> If mfCountMatches Then<br /> 'count pattern matches<br /> mfFile = Dir(mfPath)<br /> While (mfFile <> "")<br /> If InStr(mfFile, mfSearchString) > 0 Then<br /> 'MsgBox "found by pattern match: " & mfPath & mfFile<br /> mfLoopThroughFilesInAFolder = mfLoopThroughFilesInAFolder + 1<br /> End If<br /> mfFile = Dir<br /> Wend<br /> Else<br /> 'find first file<br /> mfFile = Dir(mfPath)<br /> While (mfFile <> "")<br /> If InStr(mfFile, mfSearchString) > 0 Then<br /> 'MsgBox "found by pattern match: " & mfPath & mfFile<br /> mfLoopThroughFilesInAFolder = mfPath & mfFile<br /> Exit Function<br /> End If<br /> mfFile = Dir<br /> Wend<br /> End If<br /><br />'ElseIf mfFilenameMinLen <> 0 Then 'can't see why this would ever be used<br />' mfFile = Dir(mfPath)<br />' While (mfFile <> "")<br />' If Len(mfFile) > 0 Then<br />' 'MsgBox "found by min length of filename: " & mfPath & mfFile<br />' mfLoopThroughFilesInAFolder = mfPath & mfFile<br />' Exit Function<br />' End If<br />' mfFile = Dir<br />' Wend<br /><br />ElseIf mfNewestFile = True Then<br />'search for newest file<br /> Dim mfCDthisfile As Double, mfCDnewest As Double<br /> mfFile = Dir(mfPath)<br /> If mfFile = "" Then GoTo ErrorHandler 'catches errors if no files found in path<br />On Error GoTo ErrorHandler 'catches errors if path invalid or some other error in mfGetDateCreated<br /> mfCDthisfile = mfGetDateCreated(mfPath & mfFile)<br /> If mfNewestFileNewerThan = 0 Then mfCDnewest = mfCDthisfile Else mfCDnewest = mfNewestFileNewerThan 'helps to limit searching for newer files than this one<br />On Error GoTo 0<br /> While (mfFile <> "")<br /> mfCDthisfile = mfGetDateCreated(mfPath & mfFile)<br /> If mfCDthisfile > mfCDnewest Then<br /> mfCDnewest = mfCDthisfile<br /> mfLoopThroughFilesInAFolder = mfPath & mfFile 'always newest file, .PART file is created FIRST<br /> End If<br /> mfFile = Dir<br /> Wend<br />'NB: returns "" if no newest file found<br />End If<br /><br />Exit Function<br />ErrorHandler:<br />MsgBox "Error in mfLoopThroughFilesInAFolder: no files found in path" & vbLf & vbLf & mfPath<br />End Function</span></span></span></blockquote>
baldmosher™http://www.blogger.com/profile/11281471751951639119noreply@blogger.com0Stretford M17 1QA, UK53.4609149 -2.318959400000039853.4609149 -2.3189594000000398 53.4609149 -2.3189594000000398tag:blogger.com,1999:blog-7264479838117802346.post-62885017701941155382013-08-05T08:23:00.000-07:002013-11-26T09:12:31.577-08:00VBA Modules: modEmail v1.09<br />
<br />
<a href="http://baldywritten.blogspot.com/2013/08/vba-modules-modzip-v502aaa.html" target="_blank">Read this</a> for full information on these modules<br />
<br />
This deadly simple piece of code will send an email via Outlook.<br />
<br />
Original source from <a href="http://support.microsoft.com/kb/161088" target="_blank">Microsoft support site</a><br />
<blockquote class="tr_bq">
<span style="font-size: x-small;"><span style="font-family: "Courier New",Courier,monospace;"><span style="font-size: xx-small;">'modEmail<br />'v1.09 2013-11-12 10:36<br /><br />'===========================================================================<br />' HELP CONTACT<br />'===========================================================================<br />' Code is provided without warranty and can be stolen and amended as required.<br />' Tom Parish<br />' TJP@tomparish.me.uk<br />' http://baldywrittencod.blogspot.com<br />' DGF Help Contact: see BPMHelpContact module<br />'=========================================================================<br /><br />'===========================================================================<br />' modEmail<br />'===========================================================================<br />' Routines for sending emails.<br /><br />'===========================================================================<br />' Additional modules required:<br />'===========================================================================<br />' None<br /><br />'===========================================================================<br />' Additional References required:<br />'===========================================================================<br />' None<br /><br />'===========================================================================<br />' External applications required:<br />'===========================================================================<br />' None<br /><br />'=========================================================================<br />' VERSION HISTORY<br />'=========================================================================<br />' v1.09 bugfix - AttachmentPaths as string <> ""<br />' upgrade from v1.08 essential<br />'*************************************************************************<br />' v1.08 bugfix - dim AttachmentPaths as string<br />'*************************************************************************<br />' v1.07 up to 3 attachments<br />' v1.06 bugfix - multiple To/CC/BCC didn't resolve if separated by ";"<br />' v1.05 bugfix - multiple To/CC/BCC recipients didn't resolve<br />'*************************************************************************<br />' v1.04 bugfix - upgrade advised<br />' v1.03 bugfix - upgrade essential<br />'*************************************************************************<br />' v1.02a annotations only<br />' v1.02 added cDefaultEmail<br />' v1.01 late bound references<br />' v1.00 SendEmail: code adapted from original source<br />' http://support.microsoft.com/kb/161088<br /><br />Option Explicit<br /><br />'default email address for Trigger Failure and if recipient is specified as "" (mainly for testing)<br />Public Const cDefaultEmail As String = "bpm.gb@dhl.com" 'v1.04<br /><br />Private Enum olDefaultFolders<br /> olFolderCalendar = 9<br /> olFolderContacts = 10<br /> olFolderDeletedItems = 3<br /> olFolderDrafts = 16<br /> olFolderInbox = 6<br /> olFolderJournal = 11<br /> olFolderJunk = 23<br /> olFolderNotes = 12<br /> olFolderOutbox = 4<br /> olFolderSentMail = 5<br /> olFolderTasks = 13<br /> olPublicFoldersAllPublicFolders = 18<br /> olFolderConflicts = 19<br /> olFolderLocalFailures = 21<br /> olFolderServerFailures = 22<br /> olFolderSyncIssues = 20<br />End Enum<br /><br />Private Enum olItemType<br /> olAppointmentItem = 1<br /> olContactItem = 2<br /> olDistributionListItem = 7<br /> olJournalItem = 4<br /> olMailItem = 0<br /> olNoteItem = 5<br /> olPostItem = 6<br /> olTaskItem = 3<br />End Enum<br /><br />Function SendEmail(ByVal Email_Recipient As String, Optional ByVal Email_RecipientCC As String _<br /> , Optional ByVal Email_RecipientBCC As String, Optional ByVal Email_Subject As String _<br /> , Optional ByVal Email_BodyText As String, Optional ByVal DisplayMsg As Boolean = False _<br /> , Optional AttachmentPath As String, Optional AttachmentPath2 As String, Optional AttachmentPath3 As String _<br /> ) As Byte<br />'v1.09 2013-11-12 10:36<br />'results: 0=success, 1=fail<br />'original source: http://support.microsoft.com/kb/161088<br />'v1.05 bugfix: http://stackoverflow.com/questions/13019651/automated-email-generation-not-resolving-multiple-recipients<br /><br />On Error GoTo SendEmailError<br /><br />Dim objOutlook As Object 'Outlook.Application<br />'Dim objOutlookMsg 'As Object 'Outlook.MailItem<br />Dim objOutlookRecip As Object 'Outlook.Recipient<br />Dim objOutlookAttach As Object 'Outlook.Attachment<br />'http://stackoverflow.com/questions/13019651/automated-email-generation-not-resolving-multiple-recipients<br />Dim EmailList As Variant, NumEmails As Long, AddEmailLoop As Long<br /><br />' Create the Outlook session.<br />If InStr(Application.Name, "Outlook") = 0 Then<br /> Set objOutlook = CreateObject("Outlook.Application")<br />Else<br /> Set objOutlook = Application<br />End If<br /><br />' Create the message.<br />'Set objOutlookMsg = objOutlook.CreateItem(0) 'olMailItem<br />Set objOutlook = objOutlook.CreateItem(0) 'olMailItem<br /><br />'With objOutlookMsg<br />With objOutlook<br /> ' Add the To recipient(s) to the message.<br /> If Email_Recipient = "" Then<br /> Set objOutlookRecip = .Recipients.Add(cDefaultEmail) 'for testing/blunt force only<br /> Else<br /> 'http://stackoverflow.com/questions/13019651/automated-email-generation-not-resolving-multiple-recipients<br /> Email_Recipient = Replace(Email_Recipient, ";", "; ") 'v1.06<br /> EmailList = Split(Email_Recipient, ";")<br /> NumEmails = UBound(EmailList)<br /> For AddEmailLoop = 0 To NumEmails<br /> Set objOutlookRecip = .Recipients.Add(EmailList(AddEmailLoop))<br /> objOutlookRecip.Type = 1 'olTo<br /> objOutlookRecip.Resolve<br /> Next<br /> End If<br /><br /> ' Add the CC recipient(s) to the message.<br /> If Email_RecipientCC <> "" Then<br /> Email_RecipientCC = Replace(Email_RecipientCC, ";", "; ") 'v1.06<br /> EmailList = Split(Email_RecipientCC, "; ")<br /> NumEmails = UBound(EmailList)<br /> For AddEmailLoop = 0 To NumEmails<br /> Set objOutlookRecip = .Recipients.Add(EmailList(AddEmailLoop))<br /> objOutlookRecip.Type = 2 'olCC<br /> objOutlookRecip.Resolve<br /> Next<br /> End If<br /> <br /> ' Add the BCC recipient(s) to the message.<br /> If Email_RecipientBCC <> "" Then<br /> Email_RecipientBCC = Replace(Email_RecipientBCC, ";", "; ") 'v1.06<br /> EmailList = Split(Email_RecipientBCC, "; ")<br /> NumEmails = UBound(EmailList)<br /> For AddEmailLoop = 0 To NumEmails<br /> Set objOutlookRecip = .Recipients.Add(EmailList(AddEmailLoop))<br /> objOutlookRecip.Type = 3 'olBCC<br /> objOutlookRecip.Resolve<br /> Next<br /> End If<br /><br /> ' Set the Subject, Body, and Importance of the message.<br /> .Subject = Email_Subject<br /> .Body = Email_BodyText & vbCrLf & vbCrLf<br /> .Importance = 2 'olImportanceHigh 'High importance<br /><br /> ' Add attachments to the message.<br /> If AttachmentPath <> "" Then 'v1.09<br /> Set objOutlookAttach = .Attachments.Add(AttachmentPath)<br /> End If<br /> If AttachmentPath2 <> "" Then 'v1.07<br /> Set objOutlookAttach = .Attachments.Add(AttachmentPath2)<br /> End If<br /> If AttachmentPath3 <> "" Then<br /> Set objOutlookAttach = .Attachments.Add(AttachmentPath3)<br /> End If<br /><br /> ' Resolve each Recipient's name. 'v1.06 now resolved separately on addition<br />' For Each objOutlookRecip In .Recipients<br />' objOutlookRecip.Resolve<br />' Next<br /><br /> ' Should we display the message before sending?<br /> If DisplayMsg Then<br /> .Display<br /> Else<br /> .Save<br /> .Send<br /> End If<br />End With<br /><br />Set objOutlook = Nothing<br />SendEmail = 0 'no error<br />Exit Function<br /><br />SendEmailError:<br />SendEmail = 1 'general failure<br />End Function</span></span></span></blockquote>
baldmosher™http://www.blogger.com/profile/11281471751951639119noreply@blogger.com0Stretford M17 1QA, UK53.4609149 -2.318959400000039853.4609149 -2.3189594000000398 53.4609149 -2.3189594000000398tag:blogger.com,1999:blog-7264479838117802346.post-2134582588743401462013-08-05T08:21:00.000-07:002013-08-06T07:02:25.630-07:00VBA Modules: Excel: xlCodeNames v1.00<a href="http://baldywritten.blogspot.com/2013/08/vba-modules-modzip-v502aaa.html" target="_blank">Read this</a> for full information on these modules<br />
<br />
This code is adapted from the original information by Chip Pearson. PLEASE READ THE <a href="http://www.cpearson.com/excel/codemods.htm" target="_blank">ORIGINAL INFORMATION</a> BEFORE USING THIS, you can quite easily break Excel if you don't know what you're doing.<br />
<br />
<br />
<blockquote class="tr_bq">
<span style="font-family: "Courier New",Courier,monospace;"><span style="font-size: x-small;">Option Explicit<br />'v1.00 2013-05-02 13:10<br />'Reference http://www.cpearson.com/excel/codemods.htm<br />'VBA code to update sheet, workbook, etc. code names<br /><br />Sub vbProjectCodeName(ByVal NewName As String, ByRef wb As Workbook)<br />wb.VBProject.Name = NewName<br />End Sub<br /><br />Sub vbWorkbookCodeName(ByVal NewName As String, ByRef wb As Workbook)<br />'!! use with caution, default object name is ThisWorkbook (you can always reset it afterwards)<br />wb.VBProject.VBComponents(wb.CodeName).Name = NewName<br />End Sub<br /><br />Sub vbWorksheetCodeName(ByVal NewName As String, ByRef wb As Workbook, ByRef ws As Worksheet)<br />wb.VBProject.VBComponents(ws.CodeName).Name = NewName<br />End Sub</span></span></blockquote>
<br />baldmosher™http://www.blogger.com/profile/11281471751951639119noreply@blogger.com0Stretford M17 1QA, UK53.4609149 -2.318959400000039853.4609149 -2.3189594000000398 53.4609149 -2.3189594000000398tag:blogger.com,1999:blog-7264479838117802346.post-74306036683545502592013-08-05T08:16:00.000-07:002013-11-26T09:19:13.067-08:00VBA Modules: modCheckUsers v2.02<a href="http://baldywritten.blogspot.com/2013/08/vba-modules-modzip-v502aaa.html" target="_blank">Read this</a> for full information on these modules<br />
<br />
Now this is one I have designed myself from scratch.<br />
<br />
At its simplest level, <b>CU_UserID("someID") </b>checks for a match in the Windows UserID, which is great if you distribute an XLSM file and don't want Event macros to run for anyone else but yourself.<br />
<br />
As a more complex function, <b>CU_Public </b>will check the current user against a specified file list of "valid users" which should be held in an Excel (or CSV) validation file, stored somewhere publicly accessible, e.g. a read-only SharePoint site or some other web URL.<br />
<br />
Makes use of code copied from <b>modSpecialFolders</b><br />
<br />
<blockquote class="tr_bq">
<span style="font-size: x-small;"><span style="font-family: "Courier New",Courier,monospace;"><span style="font-size: xx-small;">'modCheckUsers<br />'v2.02 2013-10-29 10:34<br /><br />'===========================================================================<br />' HELP CONTACT<br />'===========================================================================<br />' Code is provided without warranty and can be stolen and amended as required.<br />' Tom Parish<br />' TJP@tomparish.me.uk<br />' http://baldywrittencod.blogspot.com<br />' DGF Help Contact: see BPMHelpContact module<br />'=========================================================================<br /><br />'===========================================================================<br />' modCheckUsers<br />'===========================================================================<br />' Checks current Windows userID against specified userID, or against<br />' predetermined access list (outlined below)<br />'<br /><br />'===========================================================================<br />' Additional modules required:<br />'===========================================================================<br />' modAppsOffice v4.05<br />'<br />' Code included from other modules:<br />' [modSpecialFolders]<br />'<br /><br />'=========================================================================<br />' VERSION HISTORY<br />'=========================================================================<br />' v2.02 bugfix: CU_Controlled opens new Excel session invisible and quits<br />' (needed for compatibility with modAppsOffice v4.05)<br />' v2.01 bugfix: CU_Controlled always opens new Excel session<br />' v2.00 added code from modSpecialFolders<br />' v1.10a annotations only<br />' v1.10 late bound references<br />' v1.09 bugfix: opens lookup ReadOnly<br />' v1.08 bugfixes: CU_controlled open/close<br />' CheckUsers master list moved to iShare (hidden folder)<br />' v1.07 bugfix: Application.Statusbar for non-Excel applications<br />' v1.06 annotations improved, no functional change<br />' v1.05 added CU_userID (legacy: replaces CU_tparish and CU_userKID, both remain functional)<br />' renamed constants (e.g. CU_masterpth)<br />' v1.02 added StatusBar messages<br /><br />Option Explicit<br />'Checks current user KID against known access lists<br />' CU_userID - checks whether current user matches specified userID 'v1.05<br />' CU_Public - checks userIDs file in specified path<br />' CU_Controlled - checks Controlled userIDs file, here:<br /> Private Const CU_masterpth As String = "\\ishare.dhl.com\sites\DGFUK\BPMpublic\CheckUsers\" 'v1.08<br /> Private Const CU_masterfn As String = "Approved User IDs.xls" 'v1.05<br />'place list of valid KIDs in column 1 of each sheet / sheet 1 of each file<br />'further columns and column headers are irrelevant but can be used<br /> Private Const CU_StatusBar = "Checking user ID" 'v1.02<br /> Private blnASU As Boolean<br /><br /><br />'=================================================================================================<br />'=================================================================================================<br />'=================================================================================================<br />'=================================================================================================<br /><br />'<br />' Code from modSpecialFolders module:<br />'<br /><br />'http://answers.microsoft.com/en-us/office/forum/office_2010-customize/how-2-refer-to-desktop/97eba910-54c9-409f-9454-6d7c8d54d009<br />Private Declare Function SHGetSpecialFolderLocation _<br /> Lib "shell32" (ByVal hwnd As Long, _<br /> ByVal nFolder As Long, ppidl As Long) As Long<br /><br />Private Declare Function SHGetPathFromIDList _<br /> Lib "shell32" Alias "SHGetPathFromIDListA" _<br /> (ByVal Pidl As Long, ByVal pszPath As String) As Long<br /><br />Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal pvoid As Long)<br /><br />'Desktop<br />Private Const CSIDL_INTERNET = &H1 'Internet Explorer (icon on desktop)<br />Private Const CSIDL_PROGRAMS = &H2 'Start Menu\Programs<br />Private Const CSIDL_CONTROLS = &H3 'My Computer\Control Panel<br />Private Const CSIDL_PRINTERS = &H4 'My Computer\Printers<br />Private Const CSIDL_PERSONAL = &H5 'My Documents<br />Private Const CSIDL_FAVORITES = &H6 '<user name>\Favorites<br />Private Const CSIDL_STARTUP = &H7 'Start Menu\Programs\Startup<br />Private Const CSIDL_RECENT = &H8 '<user name>\Recent<br />Private Const CSIDL_SENDTO = &H9 '<user name>\SendTo<br />Private Const CSIDL_BITBUCKET = &HA '<desktop>\Recycle Bin<br />Private Const CSIDL_STARTMENU = &HB '<user name>\Start Menu<br />Private Const CSIDL_DESKTOPDIRECTORY = &H10 '<user name>\Desktop<br />Private Const CSIDL_DRIVES = &H11 'My Computer<br />Private Const CSIDL_NETWORK = &H12 'Network Neighborhood<br />Private Const CSIDL_NETHOOD = &H13 '<user name>\nethood<br />Private Const CSIDL_FONTS = &H14 'Windows\fonts<br />Private Const CSIDL_TEMPLATES = &H15<br />Private Const CSIDL_COMMON_STARTMENU = &H16 'All Users\Start Menu<br />Private Const CSIDL_COMMON_PROGRAMS = &H17 'All Users\Programs<br />Private Const CSIDL_COMMON_STARTUP = &H18 'All Users\Startup<br />Private Const CSIDL_COMMON_DESKTOPDIRECTORY = &H19 'All Users\Desktop<br />Private Const CSIDL_APPDATA = &H1A '<user name>\Application Data<br />Private Const CSIDL_PRINTHOOD = &H1B '<user name>\PrintHood<br />Private Const CSIDL_LOCAL_APPDATA = &H1C '<user name>\Local Settings\Application Data (non roaming)<br />Private Const CSIDL_ALTSTARTUP = &H1D 'non localized startup<br />Private Const CSIDL_COMMON_ALTSTARTUP = &H1E 'non localized common startup<br />Private Const CSIDL_COMMON_FAVORITES = &H1F<br />Private Const CSIDL_INTERNET_CACHE = &H20<br />Private Const CSIDL_COOKIES = &H21<br />Private Const CSIDL_HISTORY = &H22<br />Private Const CSIDL_COMMON_APPDATA = &H23 'All Users\Application Data<br />Private Const CSIDL_WINDOWS = &H24 'Windows Directory<br />Private Const CSIDL_SYSTEM = &H25 'System Directory<br />Private Const CSIDL_PROGRAM_FILES = &H26 'C:\Program Files<br />Private Const CSIDL_MYPICTURES = &H27 'C:\Program Files\My Pictures<br />Private Const CSIDL_PROFILE = &H28 'USERPROFILE<br />Private Const CSIDL_SYSTEMX86 = &H29 'x86 system directory on RISC<br />Private Const CSIDL_PROGRAM_FILESX86 = &H2A 'x86 C:\Program Files on RISC<br />Private Const CSIDL_PROGRAM_FILES_COMMON = &H2B 'C:\Program Files\Common<br />Private Const CSIDL_PROGRAM_FILES_COMMONX86 = &H2C 'x86 Program Files\Common on RISC<br />Private Const CSIDL_COMMON_TEMPLATES = &H2D 'All Users\Templates<br />Private Const CSIDL_COMMON_DOCUMENTS = &H2E 'All Users\Documents<br />Private Const CSIDL_COMMON_ADMINTOOLS = &H2F 'All Users\Start Menu\Programs\Administrative Tools<br />Private Const CSIDL_ADMINTOOLS = &H30 '<user name>\Start Menu\Programs\Administrative Tools<br />Private Const CSIDL_CONNECTIONS = &H31 'Network and Dial-up Connections<br />Private Const MAX_PATH = 260<br />Private Const NOERROR = 0<br /><br />Private Function SpecFolder(ByVal lngFolder As Long) As String<br />Dim lngPidlFound As Long<br />Dim lngFolderFound As Long<br />Dim lngPidl As Long<br />Dim strPath As String<br /><br />strPath = Space(MAX_PATH)<br />lngPidlFound = SHGetSpecialFolderLocation(0, lngFolder, lngPidl)<br />If lngPidlFound = NOERROR Then<br /> lngFolderFound = SHGetPathFromIDList(lngPidl, strPath)<br /> If lngFolderFound Then<br /> SpecFolder = Left$(strPath, _<br /> InStr(1, strPath, vbNullChar) - 1)<br /> End If<br />End If<br />CoTaskMemFree lngPidl<br />End Function<br /><br />'=================================================================================================<br />'=================================================================================================<br />'=================================================================================================<br />'=================================================================================================<br /><br />Private Sub CU_app(ByVal CU_Status As Boolean, Optional ByVal CU_StatusMsg As String)<br />'v1.07 2013-06-05 17:16<br />'always run CU_app(False,CU_StatusMsg) before and CU_app(True) after<br />'CU_StatusMsg is appended to CU_StatusBar<br /><br />If CU_Status = False Then<br />'start of process<br /> If InStr(Application.Name, "Excel") > 0 Then Application.StatusBar = CU_StatusBar & CU_StatusMsg<br /> blnASU = Application.ScreenUpdating<br /> Application.ScreenUpdating = False<br />Else<br />'end of process<br /> Application.ScreenUpdating = blnASU<br /> If InStr(Application.Name, "Excel") > 0 Then Application.StatusBar = False<br />End If<br /><br />End Sub<br /><br />Function CU_userID(ByVal userID As String) As Boolean<br />'v2.00 2013-08-09 11:20<br />'checks whether current user matches specified userID<br /><br />Dim CU_StatusMsg As String<br />CU_StatusMsg = ": user " & userID<br /><br />CU_app False, CU_StatusMsg<br /><br />If InStr(UCase(SpecFolder(CSIDL_PROFILE)), UCase(userID)) > 0 Then CU_userID = True<br /><br />CU_app True<br /><br />End Function<br /><br />Function CU_Public(ByVal UserListFolder As String) As Boolean<br />'v1.10 2013-07-10 13:07<br />'checks current user KID against approved KIDs. This function checks<br />'KID file [CU_masterfn] in [UserListFolder], so can be used by anyone<br /><br />'list of KIDs in column 1 of CU_masterfn in UserListFolder<br />'further columns and column headers are irrelevant<br /><br />Dim CU_StatusMsg As String<br />CU_StatusMsg = " against approved KIDs in " & CU_masterfn & " in " & UserListFolder<br /><br />CU_app False, CU_StatusMsg<br /><br />'open RecordSet from TXT, instead of opening XLS user IDs file?<br />Const cBsl As String = "\"<br />Const cFsl As String = "/"<br />Dim pth As String, WB As Object, rng As Object<br />pth = UserListFolder<br />If InStr(pth, cBsl) = 0 And InStr(pth, cFsl) = 0 Then<br /> MsgBox pth & vbLf & "Path incorrect or not specified", vbCritical, "CU_Public failed"<br /> Exit Function<br />Else<br /> pth = pth_sl(pth) 'adds slash to end of path if required<br />End If<br /><br />Dim XLapp As Object<br />Set XLapp = XLlaunch 'requires modAppsOffice<br />Set WB = XLapp.Workbooks.Open(FileName:=CU_masterpth & CU_masterfn, ReadOnly:=True)<br />Set rng = WB.Sheets(1).Columns(1).Cells(1)<br />If rng.Offset(1) <> "" Then Set rng = WB.Sheets(1).Range(rng, rng.End(-4121)) 'xlDown<br /><br />CU_Public = CU_KIDlist(rng)<br /><br />WB.Close<br />Set WB = Nothing<br /><br />XLapp.Quit<br />'Set XLapp = XLclose(XLapp)<br />If XLapp Is Nothing Then Else MsgBox "Warn: XLclose failed"<br /><br />CU_app True<br /><br />End Function<br /><br />Function CU_Controlled(ByVal UserList As String) As Boolean<br />'v2.02 2013-10-29 10:34<br />'checks current user KID against approved KIDs. This function<br />'checks sheet [UserList] in master file on BPMpublic shared drive<br />'which can only be edited by specific users<br />'e.g. "Sales Admin" or "BPM Admin"<br /><br />Dim CU_StatusMsg As String<br />CU_StatusMsg = " against protected KIDs in " & UserList & " sheet in " & CU_masterfn & " on BPMpublic shared drive"<br /><br />CU_app False, CU_StatusMsg<br /><br />If Dir(CU_masterpth & CU_masterfn) <> CU_masterfn Then Exit Function<br /><br />'open RecordSet from TXT, instead of opening XLS user IDs file?<br />Dim XLapp As Object, WB As Object, rng As Object 'v1.10<br />Set XLapp = XLlaunch(False) 'v2.02 'v2.01<br />Set WB = XLapp.Workbooks.Open(FileName:=CU_masterpth & CU_masterfn, ReadOnly:=True)<br />Set rng = WB.Sheets(UserList).Columns(1).Cells(1)<br />If rng.Offset(1) <> "" Then Set rng = WB.Sheets(UserList).Range(rng, rng.End(-4121)) 'xlDown<br /><br />CU_Controlled = CU_KIDlist(rng)<br /><br />WB.Close<br />Set WB = Nothing<br /><br />If Not XLapp Is Application Then<br /> Set XLapp = Nothing<br /> If XLapp Is Nothing Then Else MsgBox "Warn: XLclose failed"<br />End If<br /><br />CU_app True<br /><br />End Function<br /><br />Private Function CU_KIDlist(ByRef KIDlist As Object) As Boolean<br />'v1.10 2013-07-10 13:03<br /><br />Dim k As Byte, kmax As Byte, userfolder As String<br />userfolder = UCase(SpecFolder(CSIDL_PROFILE))<br />kmax = KIDlist.Cells.Count<br />Dim userKID() As String<br />ReDim userKID(1 To kmax) As String<br />For k = 1 To kmax<br /> userKID(k) = UCase("" & KIDlist.Cells(k).Text)<br />Next k<br />For k = 1 To kmax<br />'NB: PROFILE includes \Documents and Settings\ in WinXP or \Users\ in Win7<br /> If InStr(userfolder, userKID(k)) > 0 Then<br /> CU_KIDlist = True<br /> Exit Function<br /> End If<br />Next k<br /><br />End Function<br /><br />Private Function pth_sl(ByVal PathToAddSlash As String) As String<br />'v1.02 2013-01-06 10:40<br />'from modZip v3.04 2012-11-06 16:06<br />'adds a slash to end of path (if required)<br /><br />Const cFsl As String = "/" 'URL<br />Const cBsl As String = "\" 'UNC<br /><br />If InStr(PathToAddSlash, cFsl) > 0 And Right(PathToAddSlash, 1) <> cFsl Then<br /> pth_sl = PathToAddSlash & cFsl<br /> Do Until InStr(cFsl & cFsl, pth_sl) = 0<br /> pth_sl = Replace(pth_sl, cFsl & cFsl, cFsl)<br /> Loop<br /> Exit Function<br />ElseIf InStr(PathToAddSlash, cBsl) > 0 And Right(PathToAddSlash, 1) <> cBsl Then<br /> pth_sl = PathToAddSlash & cBsl<br /> Do Until InStr(cBsl & cBsl, pth_sl) = 0<br /> pth_sl = Replace(pth_sl, cBsl & cBsl, cBsl)<br /> Loop<br /> Exit Function<br />End If<br /><br />End Function<br /><br />'**** legacy code, replaced by CU_userID in v1.05 ****<br />Function CU_userKID(ByVal userKID As String) As Boolean<br />'v1.02 2013-01-06 10:32 **** legacy code only, replaced by CU_userID in v1.05<br />CU_userKID = CU_userID(userKID)<br />End Function<br /><br />'**** legacy code, replaced by CU_userID in v1.05 ****<br />Function CU_tparish() As Boolean<br />'v1.02 2013-01-06 10:32 **** legacy code only, replaced by CU_userID in v1.05<br />Const userKID As String = "tparish"<br />CU_tparish = CU_userID(userKID)<br />End Function<br /></span></span></span></blockquote>
baldmosher™http://www.blogger.com/profile/11281471751951639119noreply@blogger.com0Stretford M17 1QA, UK53.4609149 -2.318959400000039853.4514614 -2.3391294000000395 53.4703684 -2.29878940000004tag:blogger.com,1999:blog-7264479838117802346.post-3387483851264766122013-08-05T08:09:00.000-07:002013-11-26T09:08:48.296-08:00VBA Modules: modAppsOffice v4.08<a href="http://baldywritten.blogspot.com/2013/08/vba-modules-modzip-v502aaa.html" target="_blank">Read this</a> for full information on these modules<br />
<br />
<b>modAppsOffice </b>is a module I use all the time. It has a few simple but endlessly useful functions for launching Access and Excel, and running SQL/Access macros/queries. I probably haven't developed this one as much as I could have, but my needs are fairly simple! I prefer to handle more complicated requirements within Excel using the Workbook_Open event to launch other custom macros.<br />
<br />
This makes use of <a href="http://www.cpearson.com/" target="_blank"><b>modKeyState</b> by Chip Pearson</a> - included within the module as of v4.<br />
<br />
<blockquote class="tr_bq">
<span style="font-family: "Courier New",Courier,monospace;"><span style="font-size: x-small;"><span style="font-size: xx-small;">'modAppsOffice<br />'v4.08 2013-11-06 13:26<br /><br />'===========================================================================<br />' HELP CONTACT<br />'===========================================================================<br />' Code is provided without warranty and can be stolen and amended as required.<br />' Tom Parish<br />' TJP@tomparish.me.uk<br />' http://baldywrittencod.blogspot.com<br />' DGF Help Contact: see BPMHelpContact module<br />'=========================================================================<br /><br />'*************************************************************<br />' NOTE: all prior versions MUST be upgraded to v3.14 or later<br />'*************************************************************<br /><br />'********************************************<br />'**** two settings to be changed below ****<br />'********************************************<br /><br />'===========================================================================<br />' modAppsOffice<br />'===========================================================================<br />' Routines for launching MS Office applications, opening files, running<br />' macros, etc. Requires application reference libraries to be enabled<br />' via Tools > References ONLY if you are running from a different Office<br />' application (e.g. launching Excel from Access). Enabling unnecessary<br />' libraries will cause no harm.<br /><br />'===========================================================================<br />' Additional modules required:<br />'===========================================================================<br />' None<br /><br />'===========================================================================<br />' Additional References required:<br />'===========================================================================<br />' None<br /><br />'===========================================================================<br />' External applications required:<br />'===========================================================================<br />' Microsoft Outlook (for Outlook functions)<br />' Microsoft Access (for Access functions)<br />' Microsoft Excel (for Excel functions)<br /><br />'=========================================================================<br />' VERSION HISTORY<br />'=========================================================================<br />' v4.08 run_Excel: bugfix in error handler<br />' v4.07 run_Excel: added bForceVisibility (defaults to maoVisibleByDefault)<br />' run_Excel: added bForceVisibility<br />' XL_launch: changed XLvisible to bForceVisibility<br />' v4.06 mao_fix_path bugfix when pth includes fn<br />' v4.05 run_Access: permits use of VB "function()" as DBmacro<br />' strQuery variable relabelled as SQLcommand<br />' v4.04 run_Access/run_Excel: persistence bugfix<br />' v4.03 run_Excel: RunNative bugfix<br />' v4.02 run_Access/run_Excel error handlers (Not DBapp/XLapp Is Nothing)<br />' v4.01 retired runOutlook_SendMail, use modEmail instead<br />' v4.00 added optional SharePoint domain to check when opening XL_WB<br />' v3.18 maoVisibleByDefault set Public for use with other modules<br />' XLlaunch: visibility bugfix<br />' v3.17 run_Excel: can specify Read-Only (rxlOpenReadOnly)<br />' v3.16 run_Excel: determine Read-Only/Editable from iShare/not<br />' v3.15 late bound references<br />' v3.14 changed Access.Application to Object, fixes Debug issue for<br />' users without MS Access installed - OL and XL still required<br />'*************************************************************<br />' v3.13 minor bugfix in run_Excel (just saves a little time)<br />' v3.12 MAJOR BUGFIX in XLlaunch<br />'*************************************************************<br />'!! v3.11 fixed persistent DBapp and XLapp issue (Objects set Public)<br />' moved to GBMNCWSA050, annotations changed<br />' v3.10a MAJOR BUGFIX mao_fix_path<br />'*************************************************************<br />'!! v3.10 FAULTY mao_fix_path adds the last slash to paths<br />'*************************************************************<br />' v3.09 annotations improved, no functional change<br />' v3.08 run_AppName application objects changed to AppName.Application<br />' runOutlook_SendMail tested in 2010<br />' ** DOESN'T WORK IN OFFICE 2003 **<br />' v3.07 run_Access changed to function (so XLapp, DBapp not required)<br />' v3.03 runOutlook_SendMail sSubject, sRecipient, sBodyText, [DisplayFirst], [sAttach_pthfn1], [sAttach_pthfn2]<br />' v2.xx run_Excel XLpth, XLfn, [XLmacro], [RunNative], [LeaveOpenWhenDone](v2.09), [OpenOnly](v3.03)<br />' v1.xx run_Access DBpath, DBfn, [DBmacro], [DBquery], [strQuery], [LeaveOpenWhenDone](v2.09), [OpenOnly](v3.03)<br /><br />Option Explicit<br />'References must be enabled via Tools > References<br />'Public prevents app always closing when macro ends<br />'--> must Set XXapp = Nothing to clean up<br />Public DBapp As Object 'Access.Application 'requires Access object library<br />Public OLapp As Object 'Outlook.Application 'requires Outlook object library<br />Public XLapp As Object 'Excel.Application 'requires Excel object library<br /><br />'********************************************<br />'**** two settings to be changed below ****<br />'********************************************<br /><br />Public Const maoVisibleByDefault As Boolean = True 'v3.18 set public for use with other modules<br /> 'set this to False for background-only operations<br /><br />Private Const SP_domain As String = "ishare.dhl.com"<br /> 'SharePoint domain, optional, "" if not required<br /><br />'======================================================================<br />'======================================================================<br />'======================================================================<br />'======================================================================<br /><br />Function run_Access(ByVal DBpath As String, ByVal DBfn As String _<br /> , Optional ByVal DBmacro As String _<br /> , Optional ByVal DBquery As String _<br /> , Optional ByVal SQLcommand As String _<br /> , Optional ByVal LeaveOpenWhenDone As Boolean _<br /> , Optional ByVal OpenOnly As Boolean _<br /> , Optional ByVal bForceVisibility As Boolean = maoVisibleByDefault) _<br /> As Object 'v3.14 was Access.Application 'v3.08 requires Microsoft Access object library via Tools > References<br />'v4.07 2013-11-04 14:04<br />'runs Access and opens DB [then runs Query OR Macro OR SQL command]<br /><br />'DBpath = "C:\JBA\"<br />DBpath = mao_fix_path(DBpath) 'v3.10<br />'DBfn = "JBA G7 Detail.mdb"<br />'DBmacro = "macro name 1"<br />'DBquery = "query name 1"<br />'SQLcommand = "SELECT stuff FROM table WHERE this"<br /><br />Set DBapp = Nothing 'v4.04<br /><br />Dim strcount As Byte, pp As String, tt As String<br />Dim InXL As Boolean 'v3.07, v3.11<br />If InStr(Application.Name, "Excel") > 0 Then InXL = True<br />If InXL = True Then<br /> Set XLapp = Application 'v3.07<br /> XLapp.DisplayAlerts = False 'v3.07<br />End If<br /><br />strcount = 0<br />tt = "FATAL ERROR"<br />pp = "Warning: can only process DBmacro OR DBquery OR SQLcommand." & vbLf<br />If DBmacro <> "" Then<br /> strcount = strcount + 1<br /> pp = pp & " - specified DBmacro " & DBmacro & vbLf<br />End If<br />If DBquery <> "" Then<br /> strcount = strcount + 1<br /> pp = pp & " - specified DBquery " & DBquery & vbLf<br />End If<br />If SQLcommand <> "" Then<br /> strcount = strcount + 1<br /> pp = pp & " - specified SQLcommand " & SQLcommand & vbLf<br />End If<br />If (strcount = 0 And OpenOnly = False) _<br />Or strcount > 1 Then<br /> MsgBox pp, , tt<br /> Exit Function<br />End If<br /><br />Set run_Access = CreateObject("Access.Application")<br /><br />On Error GoTo ErrorHandler 'leaves DBapp <> Nothing on error<br /><br />With run_Access<br /> .Visible = bForceVisibility<br />'errors here means DBpath or DBfn is wrong<br /> .OpenCurrentDatabase DBpath & DBfn<br />'errors here could mean Excel Connection is not Read-Only<br />'solution here: http://social.msdn.microsoft.com/Forums/en/sqlintegrationservices/thread/d03e4b1a-6be0-4b3c-8b31-42d6fc79bf39<br /> If OpenOnly = False Then<br /> If DBmacro <> "" Then<br /> 'OL macro fails here doing Append macro - works when rerun - add a 2 second delay?<br /> 'Application.Wait Val(Now() + TimeSerial(0, 0, 5))<br /> If Right(DBmacro, 2) = "()" Then 'v4.05 runs VB function or DB macro as required<br /> 'DBmacro ends with "()", run VB function<br /> DBmacro = Left(DBmacro, Len(DBmacro) - 2) 'remove "()" from function name<br /> run_Access.Run DBmacro<br /> Else<br /> 'run DB macro<br /> .DoCmd.RunMacro DBmacro<br /> End If<br /> ElseIf DBquery <> "" Then<br /> .DoCmd.OpenQuery DBquery<br /> ElseIf SQLcommand <> "" Then<br /> .DoCmd.RunSQL SQLcommand<br /> End If<br /> End If<br /> If maoVisibleByDefault = False Then<br /> .Visible = OpenOnly<br /> End If<br /> If OpenOnly = False And LeaveOpenWhenDone = False Then<br /> .CloseCurrentDatabase<br /> .Quit<br /> Set run_Access = Nothing<br /> Else<br /> If DBapp Is Nothing Then Set DBapp = run_Access 'Else MsgBox "Cannot persist >1 instance of Access" 'v3.11<br /> Set run_Access = Nothing<br /> .Visible = True<br /> Set XLapp = Nothing<br /> Exit Function 'v4.04 stops Access quitting<br /> End If<br />End With<br /><br />ErrorHandler: 'leaves DBapp <> Nothing<br /><br />Set DBapp = run_Access<br /><br />If InXL = True Then<br /> XLapp.DisplayAlerts = True 'v3.07<br />End If<br /><br />Set XLapp = Nothing<br /><br />End Function<br /><br />Function run_Excel(ByVal XLpth As String, ByVal XLfn As String _<br /> , Optional ByVal XLmacro As String _<br /> , Optional ByVal RunNative As Boolean _<br /> , Optional ByVal LeaveOpenWhenDone As Boolean _<br /> , Optional ByVal rxlOpenReadOnly As Boolean = False _<br /> , Optional ByVal bForceVisibility As Boolean = maoVisibleByDefault) _<br /> As Object<br />'v4.08 2013-11-06 13:26<br />'simply runs Excel and opens WB [then runs macro] --> will run XLmacro when opened, if optional macro name specified<br />'WB should normally have macros that run on Workbook.Open<br />'v3.16 uses xlSharePoint, such files are ALWAYS opened Read-Only to allow automation and bypass message boxes<br />'otherwise use IsShiftKeyDown=True and Application.Wait to allow users to bypass any autoroutines<br /><br />If RunNative = False Then Set XLapp = Nothing 'v4.04<br /><br />On Error GoTo ErrorHandler 'leaves XLapp <> Nothing on error<br /><br />If XLpth <> "" Then XLpth = mao_fix_path(XLpth) 'v3.13<br /><br />Dim WB As Object 'Excel.Workbook v3.15<br />Set run_Excel = XLlaunch(LeaveOpenWhenDone, RunNative) 'v4.03<br /><br />With run_Excel<br /> .Visible = bForceVisibility 'v4.07<br /> .DisplayAlerts = False<br /> If XLmacro <> vbNullString Then<br /> 'open WB, run macro<br /> Set WB = .Workbooks.Open(XLpth & XLfn)<br /> .Run XLmacro<br /> On Error Resume Next 'prevents errors where ThisWorbook closes automatically<br /> If LeaveOpenWhenDone = False Then .Close SaveChanges:=True<br /> On Error GoTo 0<br /> Else<br /> 'macro(s) will autorun on Workbook.Open<br /> If SP_domain <> "" And (InStr(XLpth, SP_domain) > 0 Or InStr(XLfn, SP_domain) > 0) Then<br /> 'always open RO from SharePoint (prevents issues with CheckIn and can dictate automation when opened Read-Only)<br /> .Workbooks.Open FileName:=XLpth & XLfn, ReadOnly:=True<br /> Else<br /> 'always open writeable from shared drive (unless rxlOpenReadOnly is specified)<br /> .Workbooks.Open FileName:=XLpth & XLfn, ReadOnly:=rxlOpenReadOnly<br /> End If<br /> On Error Resume Next 'prevents errors where ThisWorbook closes automatically<br /> If LeaveOpenWhenDone = True Then .ActiveWorkbook.Close SaveChanges:=True<br /> On Error GoTo 0<br /> End If<br /> .DisplayAlerts = False<br /> On Error Resume Next 'prevents errors where Excel closes automatically<br /> If LeaveOpenWhenDone = False Then<br /> .Quit<br /> Set run_Excel = Nothing<br /> Else<br /> .Visible = True<br /> End If<br /> On Error GoTo 0<br />End With<br />Exit Function 'v4.08<br /><br />ErrorHandler:<br />On Error Resume Next 'v4.08<br />run_Excel.Visible = True 'v4.07<br />Set XLapp = run_Excel<br /><br />End Function<br /><br />Function XLlaunch(Optional ByVal bForceVisibility As Boolean = maoVisibleByDefault _<br /> , Optional RunNative As Boolean = False) _<br /> As Object<br />'v4.07 2013-11-04 14:04<br /><br />Dim InXL As Boolean<br />If InStr(Application.Name, "Excel") > 0 Then InXL = True 'v3.12<br /><br />If RunNative = True And InXL = True Then<br /> Set XLlaunch = Application<br />Else<br /> Set XLlaunch = CreateObject("Excel.Application")<br /> XLlaunch.Visible = bForceVisibility<br />End If<br /><br />End Function<br /><br />Function mao_fix_path(ByVal pth As String) As String<br />'v4.06 2013-10-31 11:32<br />'adds the relevant last slash to the path, if missing, and if not including .accdb/.mdb/.xl<br /><br />Const cBsl As String = "\"<br />Const cFsl As String = "/"<br /><br />If InStr(pth, ".xl") > 0 Or InStr(pth, ".accdb") > 0 Or InStr(pth, ".mdb") > 0 Then<br /> mao_fix_path = pth<br />ElseIf InStr(pth, cBsl) > 0 And Right(pth, 1) <> cBsl Then<br /> mao_fix_path = pth & cBsl<br />ElseIf InStr(pth, cFsl) > 0 And Right(pth, 1) <> cFsl Then<br /> mao_fix_path = pth & cFsl<br />Else<br /> mao_fix_path = pth<br />End If<br /><br />End Function<br /><br /><br /><br />'Sub runOutlook_SendMail(sSubject As String, sRecipient As String _<br />' , sBodyText As String, DisplayFirst As Boolean _<br />' , Optional sAttach_pthfn1 As String _<br />' , Optional sAttach_pthfn2 As String)<br />'retired v4.01 2013-08-21 16:27<br />'<br />'legacy code:<br />'modEmail.SendEmail sRecipient, "", "", sSubject, sBodyText, DisplayFirst, sAttach_pthfn1<br />'<br />''v3.15 2013-07-10 12:25<br />''*** DOESN'T WORK IN OFFICE 2003? *** tested OK in 2010<br />'' - haven't bypassed Outlook virus protection so will ask for permission?<br />'' - can only attach max 2 files, need to change this to allow more<br />'<br />''Syntax:<br />'' SendMail "My email with attachment", "name@host.com", "Here is an email", False, "c:\test.txt"<br />''source: http://www.vbaexpress.com/kb/getarticle.php?kb_id=758<br />'<br />' Dim olMail As Object 'Outlook.MailItem<br />' Dim blRunning As Boolean<br />'<br />' 'get application<br />' blRunning = True<br />' On Error Resume Next<br />' Set OLapp = GetObject(, "Outlook.Application")<br />' If OLapp Is Nothing Then<br />' Set OLapp = CreateObject("Outlook.Application")<br />' blRunning = False<br />' End If<br />' On Error GoTo 0<br />'<br />' Set olMail = OLapp.CreateItem(0) '0=olMailItem, see http://www.ozgrid.com/forum/showthread.php?t=148735<br />' With olMail<br />' 'Specify the email subject<br />' .Subject = sSubject<br />' 'Specify who it should be sent to<br />' 'Repeat this line to add further recipients<br />' .Recipients.Add sRecipient<br />' 'specify the file to attach<br />' 'repeat this line to add further attachments<br />' If sAttach_pthfn1 <> vbNullString Then<br />' .Attachments.Add sAttach_pthfn1<br />' If sAttach_pthfn2 <> vbNullString Then<br />' .Attachments.Add sAttach_pthfn2<br />' End If<br />' End If<br />' 'specify the text to appear in the email<br />' .Body = sBodyText<br />' 'Choose which of the following 2 lines to have commented out<br />' If DisplayFirst = True Then<br />' .Display 'This will display the message for you to check and send yourself<br />' Else<br />' .Send ' This will send the message straight away<br />' End If<br />' End With<br />'<br />' If Not blRunning Then OLapp.Quit<br />'<br />' Set OLapp = Nothing<br />' Set olMail = Nothing<br />'<br />'End Sub<br /><br /></span></span></span></blockquote>
baldmosher™http://www.blogger.com/profile/11281471751951639119noreply@blogger.com0Stretford M17 1QA, UK53.4609149 -2.318959400000039853.4514614 -2.3391294000000395 53.4703684 -2.29878940000004tag:blogger.com,1999:blog-7264479838117802346.post-6822851857084337422013-08-05T08:03:00.000-07:002013-08-06T07:02:53.559-07:00VBA Modules: modSpecialFolders v1.00a<a href="http://baldywritten.blogspot.com/2013/08/vba-modules-modzip-v502aaa.html" target="_blank">Read this</a> for full information on these modules<br />
<br />
modSpecialFolders reports back the path for a variety of "special folders" from Windows Shell32. It's fairly standard and extremely useful code, great for deducing where to save output files and such.<br />
<br />
This code is copied from <a href="http://answers.microsoft.com/en-us/office/forum/office_2010-customize/how-2-refer-to-desktop/97eba910-54c9-409f-9454-6d7c8d54d009" target="_blank">Microsoft support site</a>, I've just added my own annotations.<br />
<br />
<blockquote class="tr_bq">
<span style="font-family: "Courier New",Courier,monospace;"><span style="font-size: x-small;">'modSpecialFolders<br />'v1.00a 2013-07-19 11:55<br />'always export to \\GBMNCWSA050\BPMpublic\VBA Modules\<br /><br />'===========================================================================<br />' modSpecialFolders<br />'===========================================================================<br />' Finds path to various "special folders" in Windows<br />' e.g. My Documents, Program Files, Shared Documents, etc.<br /><br />'===========================================================================<br />' Additional modules required:<br />'===========================================================================<br />' None<br /><br />'===========================================================================<br />' Additional References required:<br />'===========================================================================<br />' None<br /><br />'===========================================================================<br />' External applications required:<br />'===========================================================================<br />' None<br /><br />'=========================================================================<br />' VERSION HISTORY<br />'=========================================================================<br />' v1.00a annotations only<br />' v1.00 created from source:<br />' http://answers.microsoft.com/en-us/office/forum/office_2010-customize/how-2-refer-to-desktop/97eba910-54c9-409f-9454-6d7c8d54d009<br /><br /><br /><br />Option Explicit<br /><br />Public Declare Function SHGetSpecialFolderLocation _<br /> Lib "shell32" (ByVal hwnd As Long, _<br /> ByVal nFolder As Long, ppidl As Long) As Long<br /><br />Public Declare Function SHGetPathFromIDList _<br /> Lib "shell32" Alias "SHGetPathFromIDListA" _<br /> (ByVal Pidl As Long, ByVal pszPath As String) As Long<br /><br />Public Declare Sub CoTaskMemFree Lib "ole32" (ByVal pvoid As Long)<br /><br />'Desktop<br />Public Const CSIDL_INTERNET = &H1 'Internet Explorer (icon on desktop)<br />Public Const CSIDL_PROGRAMS = &H2 'Start Menu\Programs<br />Public Const CSIDL_CONTROLS = &H3 'My Computer\Control Panel<br />Public Const CSIDL_PRINTERS = &H4 'My Computer\Printers<br />Public Const CSIDL_PERSONAL = &H5 'My Documents<br />Public Const CSIDL_FAVORITES = &H6 '<user name="">\Favorites<br />Public Const CSIDL_STARTUP = &H7 'Start Menu\Programs\Startup<br />Public Const CSIDL_RECENT = &H8 '<user name="">\Recent<br />Public Const CSIDL_SENDTO = &H9 '<user name="">\SendTo<br />Public Const CSIDL_BITBUCKET = &HA '<desktop>\Recycle Bin<br />Public Const CSIDL_STARTMENU = &HB '<user name="">\Start Menu<br />Public Const CSIDL_DESKTOPDIRECTORY = &H10 '<user name="">\Desktop<br />Public Const CSIDL_DRIVES = &H11 'My Computer<br />Public Const CSIDL_NETWORK = &H12 'Network Neighborhood<br />Public Const CSIDL_NETHOOD = &H13 '<user name="">\nethood<br />Public Const CSIDL_FONTS = &H14 'Windows\fonts<br />Public Const CSIDL_TEMPLATES = &H15<br />Public Const CSIDL_COMMON_STARTMENU = &H16 'All Users\Start Menu<br />Public Const CSIDL_COMMON_PROGRAMS = &H17 'All Users\Programs<br />Public Const CSIDL_COMMON_STARTUP = &H18 'All Users\Startup<br />Public Const CSIDL_COMMON_DESKTOPDIRECTORY = &H19 'All Users\Desktop<br />Public Const CSIDL_APPDATA = &H1A '<user name="">\Application Data<br />Public Const CSIDL_PRINTHOOD = &H1B '<user name="">\PrintHood<br />Public Const CSIDL_LOCAL_APPDATA = &H1C '<user name="">\Local Settings\Application Data (non roaming)<br />Public Const CSIDL_ALTSTARTUP = &H1D 'non localized startup<br />Public Const CSIDL_COMMON_ALTSTARTUP = &H1E 'non localized common startup<br />Public Const CSIDL_COMMON_FAVORITES = &H1F<br />Public Const CSIDL_INTERNET_CACHE = &H20<br />Public Const CSIDL_COOKIES = &H21<br />Public Const CSIDL_HISTORY = &H22<br />Public Const CSIDL_COMMON_APPDATA = &H23 'All Users\Application Data<br />Public Const CSIDL_WINDOWS = &H24 'Windows Directory<br />Public Const CSIDL_SYSTEM = &H25 'System Directory<br />Public Const CSIDL_PROGRAM_FILES = &H26 'C:\Program Files<br />Public Const CSIDL_MYPICTURES = &H27 'C:\Program Files\My Pictures<br />Public Const CSIDL_PROFILE = &H28 'USERPROFILE<br />Public Const CSIDL_SYSTEMX86 = &H29 'x86 system directory on RISC<br />Public Const CSIDL_PROGRAM_FILESX86 = &H2A 'x86 C:\Program Files on RISC<br />Public Const CSIDL_PROGRAM_FILES_COMMON = &H2B 'C:\Program Files\Common<br />Public Const CSIDL_PROGRAM_FILES_COMMONX86 = &H2C 'x86 Program Files\Common on RISC<br />Public Const CSIDL_COMMON_TEMPLATES = &H2D 'All Users\Templates<br />Public Const CSIDL_COMMON_DOCUMENTS = &H2E 'All Users\Documents<br />Public Const CSIDL_COMMON_ADMINTOOLS = &H2F 'All Users\Start Menu\Programs\Administrative Tools<br />Public Const CSIDL_ADMINTOOLS = &H30 '<user name="">\Start Menu\Programs\Administrative Tools<br />Public Const CSIDL_CONNECTIONS = &H31 'Network and Dial-up Connections<br />Public Const MAX_PATH = 260<br />Public Const NOERROR = 0<br /><br />Public Function SpecFolder(ByVal lngFolder As Long) As String<br />Dim lngPidlFound As Long<br />Dim lngFolderFound As Long<br />Dim lngPidl As Long<br />Dim strPath As String<br /><br />strPath = Space(MAX_PATH)<br />lngPidlFound = SHGetSpecialFolderLocation(0, lngFolder, lngPidl)<br />If lngPidlFound = NOERROR Then<br /> lngFolderFound = SHGetPathFromIDList(lngPidl, strPath)<br /> If lngFolderFound Then<br /> SpecFolder = Left$(strPath, _<br /> InStr(1, strPath, vbNullChar) - 1)<br /> End If<br />End If<br />CoTaskMemFree lngPidl<br />End Function</user></user></user></user></user></user></user></desktop></user></user></user></span></span></blockquote>
baldmosher™http://www.blogger.com/profile/11281471751951639119noreply@blogger.com0Stretford M17 1QA, UK53.4609149 -2.318959400000039853.4514614 -2.3391294000000395 53.4703684 -2.29878940000004tag:blogger.com,1999:blog-7264479838117802346.post-40990632146601420152013-08-05T07:59:00.000-07:002014-01-16T06:54:10.384-08:00VBA Modules: Excel: xlShellAndWait v1.00aa<a href="http://baldywritten.blogspot.com/2013/08/vba-modules-modzip-v502aaa.html" target="_blank">Read this</a> for full information on these modules<br />
<br />
This code is copied exactly from Chip Pearson's <a href="http://www.cpearson.com/Excel/ShellAndWait.aspx" target="_blank">modShellAndWait</a> code.<br />
<br />
v2.00 has late binding so it can be used outside of Excel<br />
<br />
<blockquote class="tr_bq">
<span style="font-family: "Courier New",Courier,monospace;"><span style="font-size: xx-small;">'xlShellAndWait<br />'v2.00 2013-12-17 15:58<br />'always export to \\GBMNCWSA050\BPMpublic\VBA Modules\<br /><br />'===========================================================================<br />' xlShellAndWait<br />'===========================================================================<br />' Based on original code in modShellAndWait by Chip Pearson<br />'<br />' See below for original code & info, this version is renamed to prevent<br />' accidental use in other Office applications (it only works in Excel)<br /><br />'===========================================================================<br />' Additional modules required:<br />'===========================================================================<br />' None<br /><br />'===========================================================================<br />' Additional References required:<br />'===========================================================================<br />' Microsoft Excel Object Library (if not running from Excel)<br /><br />'===========================================================================<br />' External applications required:<br />'===========================================================================<br />' None<br /><br />'=========================================================================<br />' VERSION HISTORY<br />'=========================================================================<br />' v2.00 late binding<br />' v1.00aa annotations only<br />' v1.00a annotations only<br />' v1.00 original code from source<br /><br />'===========================================================================<br />' HELP CONTACT<br />'===========================================================================<br />' Tom Parish tom.parish@dhl.com +44 161 772 7359<br />' Performance Measurement Analyst for Business Performance Measurement (GB)<br />' DHL Global Forwarding (UK) Limited<br />' Registered in England, registered number 4056042<br />' Registered Office: Magna House, 18-32 London Road, Staines TW18 4BP<br />'=========================================================================<br /><br />Option Explicit<br />Option Compare Text<br /><br />'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''<br />'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''<br />' modShellAndWait<br />' By Chip Pearson, chip@cpearson.com, www.cpearson.com<br />' This page on the web site: www.cpearson.com/Excel/ShellAndWait.aspx<br />' 9-September-2008<br />'<br />' This module contains code for the ShellAndWait function that will Shell to a process<br />' and wait for that process to end before returning to the caller.<br />'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''<br />'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''<br />Private Declare Function WaitForSingleObject Lib "kernel32" ( _<br /> ByVal hHandle As Long, _<br /> ByVal dwMilliSeconds As Long) As Long<br /><br />Private Declare Function OpenProcess Lib "kernel32.dll" ( _<br /> ByVal dwDesiredAccess As Long, _<br /> ByVal bInheritHandle As Long, _<br /> ByVal dwProcessId As Long) As Long<br /><br />Private Declare Function CloseHandle Lib "kernel32" ( _<br /> ByVal hObject As Long) As Long<br /><br />Private Const SYNCHRONIZE = &H100000<br /><br />Public Enum ShellAndWaitResult<br /> Success = 0<br /> Failure = 1<br /> TimeOut = 2<br /> InvalidParameter = 3<br /> SysWaitAbandoned = 4<br /> UserWaitAbandoned = 5<br /> UserBreak = 6<br />End Enum<br /><br />Public Enum ActionOnBreak<br /> IgnoreBreak = 0<br /> AbandonWait = 1<br /> PromptUser = 2<br />End Enum<br /><br />Private Const STATUS_ABANDONED_WAIT_0 As Long = &H80<br />Private Const STATUS_WAIT_0 As Long = &H0<br />Private Const WAIT_ABANDONED As Long = (STATUS_ABANDONED_WAIT_0 + 0)<br />Private Const WAIT_OBJECT_0 As Long = (STATUS_WAIT_0 + 0)<br />Private Const WAIT_TIMEOUT As Long = 258&<br />Private Const WAIT_FAILED As Long = &HFFFFFFFF<br />Private Const WAIT_INFINITE = -1&<br /><br /><br />Public Function ShellAndWait(ShellCommand As String, _<br /> TimeOutMs As Long, _<br /> ShellWindowState As VbAppWinStyle, _<br /> BreakKey As ActionOnBreak) As ShellAndWaitResult<br />'v2.00 2013-12-17 15:58 - late binding for non-Excel Application use<br />'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''<br />' ShellAndWait<br />'<br />' This function calls Shell and passes to it the command text in ShellCommand. The function<br />' then waits for TimeOutMs (in milliseconds) to expire.<br />'<br />' Parameters:<br />' ShellCommand<br />' is the command text to pass to the Shell function.<br />'<br />' TimeOutMs<br />' is the number of milliseconds to wait for the shell'd program to wait. If the<br />' shell'd program terminates before TimeOutMs has expired, the function returns<br />' ShellAndWaitResult.Success = 0. If TimeOutMs expires before the shell'd program<br />' terminates, the return value is ShellAndWaitResult.TimeOut = 2.<br />'<br />' ShellWindowState<br />' is an item in VbAppWinStyle specifying the window state for the shell'd program.<br />'<br />' BreakKey<br />' is an item in ActionOnBreak indicating how to handle the application's cancel key<br />' (Ctrl Break). If BreakKey is ActionOnBreak.AbandonWait and the user cancels, the<br />' wait is abandoned and the result is ShellAndWaitResult.UserWaitAbandoned = 5.<br />' If BreakKey is ActionOnBreak.IgnoreBreak, the cancel key is ignored. If<br />' BreakKey is ActionOnBreak.PromptUser, the user is given a ?Continue? message. If the<br />' user selects "do not continue", the function returns ShellAndWaitResult.UserBreak = 6.<br />' If the user selects "continue", the wait is continued.<br />'<br />' Return values:<br />' ShellAndWaitResult.Success = 0<br />' indicates the the process completed successfully.<br />' ShellAndWaitResult.Failure = 1<br />' indicates that the Wait operation failed due to a Windows error.<br />' ShellAndWaitResult.TimeOut = 2<br />' indicates that the TimeOutMs interval timed out the Wait.<br />' ShellAndWaitResult.InvalidParameter = 3<br />' indicates that an invalid value was passed to the procedure.<br />' ShellAndWaitResult.SysWaitAbandoned = 4<br />' indicates that the system abandoned the wait.<br />' ShellAndWaitResult.UserWaitAbandoned = 5<br />' indicates that the user abandoned the wait via the cancel key (Ctrl+Break).<br />' This happens only if BreakKey is set to ActionOnBreak.AbandonWait.<br />' ShellAndWaitResult.UserBreak = 6<br />' indicates that the user broke out of the wait after being prompted with<br />' a ?Continue message. This happens only if BreakKey is set to<br />' ActionOnBreak.PromptUser.<br /><br />'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''<br /><br />Dim TaskID As Long<br />Dim ProcHandle As Long<br />Dim WaitRes As Long<br />Dim Ms As Long<br />Dim MsgRes As VbMsgBoxResult<br />Dim SaveCancelKey As XlEnableCancelKey 'NB: only works in Excel<br />Dim ElapsedTime As Long<br />Dim Quit As Boolean<br />Const ERR_BREAK_KEY = 18<br />Const DEFAULT_POLL_INTERVAL = 500<br />Dim XLapp As Object 'v2.00<br />If InStr(Application.Name, "Excel") > 0 Then Set XLapp = Application Else Set XLapp = CreateObject("Excel.Application")<br /><br />If Trim(ShellCommand) = vbNullString Then<br /> ShellAndWait = ShellAndWaitResult.InvalidParameter<br /> Exit Function<br />End If<br /><br />If TimeOutMs < 0 Then<br /> ShellAndWait = ShellAndWaitResult.InvalidParameter<br /> Exit Function<br />ElseIf TimeOutMs = 0 Then<br /> Ms = WAIT_INFINITE<br />Else<br /> Ms = TimeOutMs<br />End If<br /><br />Select Case BreakKey<br /> Case AbandonWait, IgnoreBreak, PromptUser<br /> ' valid<br /> Case Else<br /> ShellAndWait = ShellAndWaitResult.InvalidParameter<br /> Exit Function<br />End Select<br /><br />Select Case ShellWindowState<br /> Case vbHide, vbMaximizedFocus, vbMinimizedFocus, vbMinimizedNoFocus, vbNormalFocus, vbNormalNoFocus<br /> ' valid<br /> Case Else<br /> ShellAndWait = ShellAndWaitResult.InvalidParameter<br /> Exit Function<br />End Select<br /><br />On Error Resume Next<br />Err.Clear<br />TaskID = Shell(ShellCommand, ShellWindowState)<br />If (Err.Number <> 0) Or (TaskID = 0) Then<br /> ShellAndWait = ShellAndWaitResult.Failure<br /> Exit Function<br />End If<br /><br />ProcHandle = OpenProcess(SYNCHRONIZE, False, TaskID)<br />If ProcHandle = 0 Then<br /> ShellAndWait = ShellAndWaitResult.Failure<br /> Exit Function<br />End If<br /><br /><br />On Error GoTo ErrH:<br />SaveCancelKey = XLapp.EnableCancelKey<br />XLapp.EnableCancelKey = xlErrorHandler<br />WaitRes = WaitForSingleObject(ProcHandle, DEFAULT_POLL_INTERVAL)<br />Do Until WaitRes = WAIT_OBJECT_0<br /> DoEvents<br /> Select Case WaitRes<br /> Case WAIT_ABANDONED<br /> ' Windows abandoned the wait<br /> ShellAndWait = ShellAndWaitResult.SysWaitAbandoned<br /> Exit Do<br /> Case WAIT_OBJECT_0<br /> ' Successful completion<br /> ShellAndWait = ShellAndWaitResult.Success<br /> Exit Do<br /> Case WAIT_FAILED<br /> ' attach failed<br /> ShellAndWait = ShellAndWaitResult.Success<br /> Exit Do<br /> Case WAIT_TIMEOUT<br /> ' Wait timed out. Here, this time out is on DEFAULT_POLL_INTERVAL.<br /> ' See if ElapsedTime is greater than the user specified wait<br /> ' time out. If we have exceed that, get out with a TimeOut status.<br /> ' Otherwise, reissue as wait and continue.<br /> ElapsedTime = ElapsedTime + DEFAULT_POLL_INTERVAL<br /> If Ms > 0 Then<br /> ' user specified timeout<br /> If ElapsedTime > Ms Then<br /> ShellAndWait = ShellAndWaitResult.TimeOut<br /> Exit Do<br /> Else<br /> ' user defined timeout has not expired.<br /> End If<br /> Else<br /> ' infinite wait -- do nothing<br /> End If<br /> ' reissue the Wait on ProcHandle<br /> WaitRes = WaitForSingleObject(ProcHandle, DEFAULT_POLL_INTERVAL)<br /> <br /> Case Else<br /> ' unknown result, assume failure<br /> ShellAndWait = ShellAndWaitResult.Failure<br /> Quit = True<br /> End Select<br />Loop<br /><br />CloseHandle ProcHandle<br />XLapp.EnableCancelKey = SaveCancelKey<br />Exit Function<br /><br />ErrH:<br />Debug.Print "ErrH: Cancel: " & XLapp.EnableCancelKey<br />If Err.Number = ERR_BREAK_KEY Then<br /> If BreakKey = ActionOnBreak.AbandonWait Then<br /> CloseHandle ProcHandle<br /> ShellAndWait = ShellAndWaitResult.UserWaitAbandoned<br /> XLapp.EnableCancelKey = SaveCancelKey<br /> Set XLapp = Nothing<br /> Exit Function<br /> ElseIf BreakKey = ActionOnBreak.IgnoreBreak Then<br /> Err.Clear<br /> Resume<br /> ElseIf BreakKey = ActionOnBreak.PromptUser Then<br /> MsgRes = MsgBox("User Process Break." & vbCrLf & _<br /> "Continue to wait?", vbYesNo)<br /> If MsgRes = vbNo Then<br /> CloseHandle ProcHandle<br /> ShellAndWait = ShellAndWaitResult.UserBreak<br /> XLapp.EnableCancelKey = SaveCancelKey<br /> Else<br /> Err.Clear<br /> Resume Next<br /> End If<br /> Else<br /> 'Debug.Print "Unknown value of 'BreakKey': " & CStr(BreakKey)<br /> CloseHandle ProcHandle<br /> XLapp.EnableCancelKey = SaveCancelKey<br /> ShellAndWait = ShellAndWaitResult.Failure<br /> End If<br />Else<br /> ' some other error. assume failure<br /> CloseHandle ProcHandle<br /> ShellAndWait = ShellAndWaitResult.Failure<br />End If<br /><br />XLapp.EnableCancelKey = SaveCancelKey<br />Set XLapp = Nothing<br /><br />End Function</span></span></blockquote>
baldmosher™http://www.blogger.com/profile/11281471751951639119noreply@blogger.com0Stretford M17 1QA, UK53.4609149 -2.318959400000039853.4514614 -2.3391294000000395 53.4703684 -2.29878940000004tag:blogger.com,1999:blog-7264479838117802346.post-13516830468487614712013-08-05T07:56:00.000-07:002014-01-16T05:57:07.427-08:00VBA Modules: modZip v8.04<a href="http://baldywritten.blogspot.com/2013/08/vba-modules-modzip-v502aaa.html" target="_blank">Read this</a> for full information on these modules<br />
<br />
This particular module is very useful, uses the excellent 7zip command line application to automatically zip or unzip any type of file. It will work with URL source/targets, but always more reliable with UNC.<br />
The <b>Zip7sub</b> macro will "install" 7zip automatically if you save <b>7za.exe</b> somewhere publicly accessible on your network and specify the location in the code below. Note that the "iShare" UNC address I've used is not accessible to the public, so you just have to replace the location with one you can access. It can of course also be any accessible location on your own machine, e.g. your Desktop or Documents or Downloads folder.<br />
<br />
This module makes use of <a href="http://www.cpearson.com/excel/ShellAndWait.aspx" target="_blank"><b>ShellAndWait</b> by Chip Pearson</a> and <b>modSpecialFolders</b> -- standard function code from the Microsoft support site. Code from both is included within this module.<br />
<br />
v8 adds<b> z7_Force_Connection </b>-- adapted from the xlSharePoint module. Highly recommended to run this before zipping to SharePoint locations.<br />
<br />
If you're running this from Access or Outlook, it'll work fine, but you should enable Excel Object Library via Tools > References to prevent Debug > Compile errors with a couple of Excel Application commands. <br />
<br />
As it says below, it <u>should</u> still work in XP, but I've not tested it since I updated the code for Windows 7.<br />
<br />
<blockquote class="tr_bq">
<span style="font-size: x-small;"><span style="font-family: "Courier New",Courier,monospace;"><span style="font-size: xx-small;">'modZip<br />'v8.04 2014-01-10 14:27<br /><br />'===========================================================================<br />' HELP CONTACT<br />'===========================================================================<br />' Code is provided without warranty and can be stolen and amended as required.<br />' Tom Parish<br />' TJP@tomparish.me.uk<br />' http://baldywrittencod.blogspot.com<br />' DGF Help Contact: see BPMHelpContact module<br />'=========================================================================<br /><br />'************************************************************<br />'***** WARNING: SETTINGS BELOW MAY NEED TO BE AMENDED *****<br />'************************************************************<br /><br />'===========================================================================<br />' modZip<br />'===========================================================================<br />' Various zipping functions. Uses 7zip Command Line Utility (7za.exe)<br />' 7zip is free for personal or business use http://www.7zip.com/<br />'<br />' Module self-installs (copies) 7zip from shared drive or SharePoint<br />' location(s) to [C:\Users\[userID]\Documents]\[zSubFolder]\[z7pth]\<br />'<br />' Can easily be adapted to use WinZip or any command line utility,<br />' but pay careful attention to app-specific command line syntax.<br />'<br />' Syntax to zip file(s):<br />' Zip7Sub [FilesPathFn], [ArchivePathFn], True<br />'<br />' Also see:<br />' Sub syntax_to_zip_one_file()<br /><br />'===========================================================================<br />' Additional modules required:<br />'===========================================================================<br />' None<br />'<br />' Code included from other modules:<br />' [modSpecialFolders]<br />' [xlShellAndWait]<br /><br />'===========================================================================<br />' Additional References required:<br />'===========================================================================<br />' Microsoft Excel Object Library (if not running from Excel)<br /><br />'===========================================================================<br />' External applications required:<br />'===========================================================================<br />' None<br /><br />'=========================================================================<br />' VERSION HISTORY<br />'=========================================================================<br />'v8.04 2014-01-10 14:27 - Z7_Force_Connection - bugfix for zips (remove "" from ends)<br />'v8.03 2014-01-09 18:13 - Z7_CloseExplorerWindow - bugfix to prevent errors with Internet Explorer shell windows<br />'v8.02 2014-01-09 17:10 - Z7_CloseExplorerWindow - bugfix to prevent blank folder name<br />'v8.01 2014-01-09 15:46 - Z7_Force_Connection - added bExplorerKill failsafe option to kill all Explorer windows (prevents leaving countless processes open - although rarely triggered)<br />'v8.00 2014-01-10 10:28 - Z7_Force_Connection - checks/forces connection (to SharePoint) adapted from xlSharePoint v5.03<br />' v7.01 syntax_to_zip_one_file: zips .rwz file first (Outlook Rules Wizard)<br />' v7.01 syntax_to_zip_one_file: also zips .docx files<br />' v7.00 ZIP_EXE_pthfn: rebuild, uses secondary/tertiary install locations<br />' v6.00 included code from xlShellAndWait and modSpecialFolders<br />' v5.03 syntax_to_zip_one_file: improved validity check in non-Excel apps<br />' v5.02 syntax_to_zip_one_file: msgbox added<br />' v5.01 ZIP_EXE_copy: added z7exn<br />' v5.00a annotations only<br />' v5.00 WINDOWS 7 ONLY: moved to C:\Users\All Users\BPM Tools\<br />' zlmax set to 2, now only refers to iShare sources (UNC then URL)<br />' v4.02 syntax_to_zip_one_file: now sources from GBMNCWSA050<br />' v4.01 bugfix: Application.Statusbar in non-Excel applications<br />' bugfix: xlShellAndWait is only possible in Excel<br />' v4.00 Zip7Sub: added zKillFirst and zRecurse options<br />' ZIP_EXE_copy: process massively improved<br />' annotations improved<br />' v3.08 bugfix<br /><br />Option Explicit<br /><br />'************************************************************<br />'***** WARNING: SETTINGS BELOW MAY NEED TO BE AMENDED *****<br />'************************************************************<br /><br />'zlmax = possible source locations in scope, MAX 2 in code v5.00<br /> Private Const zlmax As Byte = 2 'v5.00<br />'users must have access to shared drive and SharePoint UNC/URL locations (read-only)<br />'NB: SharePoint cannot host exe files, so remove file extension, ".exe" will be renamed during FileCopy<br /> Private Const z7e1 As String = "\\ishare.dhl.com\sites\DGFUK\BPMpublic\Resources\" 'v5.00<br /> Private Const z7e2 As String = "http://ishare.dhl.com/sites/DGFUK/BPMpublic/Resources/" 'v5.00<br />'subfolders in local [C:\Users]\All Users\ folder to create for copying 7za.exe (can be "")<br /> Private Const zSubFolder As String = "BPM Tools" 'use backslash to specify 2 deep e.g. "SubFolder1\SubFolder2"<br /> Private Const z7pth As String = "7z" 'subfolder for 7zip 'v5.01<br />'possible 7zip executable filenames<br /> Private Const z7exe As String = "7za.exe" 'any location where .exe is permitted 'v5.01<br /> Private Const z7ext As String = "7za.ext" 'any location where .exe forbidden 'v5.01<br /> Private Const z7exn As String = "7za" 'any location where .exe forbidden, without extension 'v5.01<br /><br />'source: http://www.vboffice.net/sample.html?mnu=2&lang=en&smp=56&cmd=showitem&pub=6<br /> Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliSeconds As Long)<br /> Private Const zSleepTime As Long = 10000 'v5.03, time in ms, i.e. 10000 = 10s<br /><br />'==========================================================================<br />'==========================================================================<br />'==========================================================================<br />'==========================================================================<br /><br />'<br />' Code from xlShellAndWait module:<br />'<br /><br />Option Compare Text<br /><br />'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''<br />'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''<br />' modShellAndWait<br />' By Chip Pearson, chip@cpearson.com, www.cpearson.com<br />' This page on the web site: www.cpearson.com/Excel/ShellAndWait.aspx<br />' 9-September-2008<br />'<br />' This module contains code for the ShellAndWait function that will Shell to a process<br />' and wait for that process to end before returning to the caller.<br />'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''<br />'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''<br />Private Declare Function WaitForSingleObject Lib "kernel32" ( _<br /> ByVal hHandle As Long, _<br /> ByVal dwMilliSeconds As Long) As Long<br /><br />Private Declare Function OpenProcess Lib "kernel32.dll" ( _<br /> ByVal dwDesiredAccess As Long, _<br /> ByVal bInheritHandle As Long, _<br /> ByVal dwProcessId As Long) As Long<br /><br />Private Declare Function CloseHandle Lib "kernel32" ( _<br /> ByVal hObject As Long) As Long<br /><br />Private Const SYNCHRONIZE = &H100000<br /><br />Private Enum ShellAndWaitResult<br /> Success = 0<br /> Failure = 1<br /> TimeOut = 2<br /> InvalidParameter = 3<br /> SysWaitAbandoned = 4<br /> UserWaitAbandoned = 5<br /> UserBreak = 6<br />End Enum<br /><br />Private Enum ActionOnBreak<br /> IgnoreBreak = 0<br /> AbandonWait = 1<br /> PromptUser = 2<br />End Enum<br /><br />Private Const STATUS_ABANDONED_WAIT_0 As Long = &H80<br />Private Const STATUS_WAIT_0 As Long = &H0<br />Private Const WAIT_ABANDONED As Long = (STATUS_ABANDONED_WAIT_0 + 0)<br />Private Const WAIT_OBJECT_0 As Long = (STATUS_WAIT_0 + 0)<br />Private Const WAIT_TIMEOUT As Long = 258&<br />Private Const WAIT_FAILED As Long = &HFFFFFFFF<br />Private Const WAIT_INFINITE = -1&<br /><br /><br /><br />'==========================================================================<br />'==========================================================================<br />'==========================================================================<br />'==========================================================================<br /><br />'<br />' Code from modSpecialFolders module:<br />'<br /><br />'http://answers.microsoft.com/en-us/office/forum/office_2010-customize/how-2-refer-to-desktop/97eba910-54c9-409f-9454-6d7c8d54d009<br />Private Declare Function SHGetSpecialFolderLocation _<br /> Lib "shell32" (ByVal hwnd As Long, _<br /> ByVal nFolder As Long, ppidl As Long) As Long<br /><br />Private Declare Function SHGetPathFromIDList _<br /> Lib "shell32" Alias "SHGetPathFromIDListA" _<br /> (ByVal Pidl As Long, ByVal pszPath As String) As Long<br /><br />Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal pvoid As Long)<br /><br />'Desktop<br />Private Const CSIDL_INTERNET = &H1 'Internet Explorer (icon on desktop)<br />Private Const CSIDL_PROGRAMS = &H2 'Start Menu\Programs<br />Private Const CSIDL_CONTROLS = &H3 'My Computer\Control Panel<br />Private Const CSIDL_PRINTERS = &H4 'My Computer\Printers<br />Private Const CSIDL_PERSONAL = &H5 'My Documents<br />Private Const CSIDL_FAVORITES = &H6 '<user name>\Favorites<br />Private Const CSIDL_STARTUP = &H7 'Start Menu\Programs\Startup<br />Private Const CSIDL_RECENT = &H8 '<user name>\Recent<br />Private Const CSIDL_SENDTO = &H9 '<user name>\SendTo<br />Private Const CSIDL_BITBUCKET = &HA '<desktop>\Recycle Bin<br />Private Const CSIDL_STARTMENU = &HB '<user name>\Start Menu<br />Private Const CSIDL_DESKTOPDIRECTORY = &H10 '<user name>\Desktop<br />Private Const CSIDL_DRIVES = &H11 'My Computer<br />Private Const CSIDL_NETWORK = &H12 'Network Neighborhood<br />Private Const CSIDL_NETHOOD = &H13 '<user name>\nethood<br />Private Const CSIDL_FONTS = &H14 'Windows\fonts<br />Private Const CSIDL_TEMPLATES = &H15<br />Private Const CSIDL_COMMON_STARTMENU = &H16 'All Users\Start Menu<br />Private Const CSIDL_COMMON_PROGRAMS = &H17 'All Users\Programs<br />Private Const CSIDL_COMMON_STARTUP = &H18 'All Users\Startup<br />Private Const CSIDL_COMMON_DESKTOPDIRECTORY = &H19 'All Users\Desktop<br />Private Const CSIDL_APPDATA = &H1A '<user name>\Application Data<br />Private Const CSIDL_PRINTHOOD = &H1B '<user name>\PrintHood<br />Private Const CSIDL_LOCAL_APPDATA = &H1C '<user name>\Local Settings\Application Data (non roaming)<br />Private Const CSIDL_ALTSTARTUP = &H1D 'non localized startup<br />Private Const CSIDL_COMMON_ALTSTARTUP = &H1E 'non localized common startup<br />Private Const CSIDL_COMMON_FAVORITES = &H1F<br />Private Const CSIDL_INTERNET_CACHE = &H20<br />Private Const CSIDL_COOKIES = &H21<br />Private Const CSIDL_HISTORY = &H22<br />Private Const CSIDL_COMMON_APPDATA = &H23 'All Users\Application Data<br />Private Const CSIDL_WINDOWS = &H24 'Windows Directory<br />Private Const CSIDL_SYSTEM = &H25 'System Directory<br />Private Const CSIDL_PROGRAM_FILES = &H26 'C:\Program Files<br />Private Const CSIDL_MYPICTURES = &H27 'C:\Program Files\My Pictures<br />Private Const CSIDL_PROFILE = &H28 'USERPROFILE<br />Private Const CSIDL_SYSTEMX86 = &H29 'x86 system directory on RISC<br />Private Const CSIDL_PROGRAM_FILESX86 = &H2A 'x86 C:\Program Files on RISC<br />Private Const CSIDL_PROGRAM_FILES_COMMON = &H2B 'C:\Program Files\Common<br />Private Const CSIDL_PROGRAM_FILES_COMMONX86 = &H2C 'x86 Program Files\Common on RISC<br />Private Const CSIDL_COMMON_TEMPLATES = &H2D 'All Users\Templates<br />Private Const CSIDL_COMMON_DOCUMENTS = &H2E 'All Users\Documents<br />Private Const CSIDL_COMMON_ADMINTOOLS = &H2F 'All Users\Start Menu\Programs\Administrative Tools<br />Private Const CSIDL_ADMINTOOLS = &H30 '<user name>\Start Menu\Programs\Administrative Tools<br />Private Const CSIDL_CONNECTIONS = &H31 'Network and Dial-up Connections<br />Private Const MAX_PATH = 260<br />Private Const NOERROR = 0<br /><br />Private Function SpecFolder(ByVal lngFolder As Long) As String<br />Dim lngPidlFound As Long<br />Dim lngFolderFound As Long<br />Dim lngPidl As Long<br />Dim strPath As String<br /><br />strPath = Space(MAX_PATH)<br />lngPidlFound = SHGetSpecialFolderLocation(0, lngFolder, lngPidl)<br />If lngPidlFound = NOERROR Then<br /> lngFolderFound = SHGetPathFromIDList(lngPidl, strPath)<br /> If lngFolderFound Then<br /> SpecFolder = Left$(strPath, _<br /> InStr(1, strPath, vbNullChar) - 1)<br /> End If<br />End If<br />CoTaskMemFree lngPidl<br />End Function<br /><br />'==========================================================================<br />'==========================================================================<br />'==========================================================================<br />'==========================================================================<br /><br />Private Function ShellAndWait(ShellCommand As String, _<br /> TimeOutMs As Long, _<br /> ShellWindowState As VbAppWinStyle, _<br /> BreakKey As ActionOnBreak) As ShellAndWaitResult<br />'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''<br />' ShellAndWait<br />'<br />' This function calls Shell and passes to it the command text in ShellCommand. The function<br />' then waits for TimeOutMs (in milliseconds) to expire.<br />'<br />' Parameters:<br />' ShellCommand<br />' is the command text to pass to the Shell function.<br />'<br />' TimeOutMs<br />' is the number of milliseconds to wait for the shell'd program to wait. If the<br />' shell'd program terminates before TimeOutMs has expired, the function returns<br />' ShellAndWaitResult.Success = 0. If TimeOutMs expires before the shell'd program<br />' terminates, the return value is ShellAndWaitResult.TimeOut = 2.<br />'<br />' ShellWindowState<br />' is an item in VbAppWinStyle specifying the window state for the shell'd program.<br />'<br />' BreakKey<br />' is an item in ActionOnBreak indicating how to handle the application's cancel key<br />' (Ctrl Break). If BreakKey is ActionOnBreak.AbandonWait and the user cancels, the<br />' wait is abandoned and the result is ShellAndWaitResult.UserWaitAbandoned = 5.<br />' If BreakKey is ActionOnBreak.IgnoreBreak, the cancel key is ignored. If<br />' BreakKey is ActionOnBreak.PromptUser, the user is given a ?Continue? message. If the<br />' user selects "do not continue", the function returns ShellAndWaitResult.UserBreak = 6.<br />' If the user selects "continue", the wait is continued.<br />'<br />' Return values:<br />' ShellAndWaitResult.Success = 0<br />' indicates the the process completed successfully.<br />' ShellAndWaitResult.Failure = 1<br />' indicates that the Wait operation failed due to a Windows error.<br />' ShellAndWaitResult.TimeOut = 2<br />' indicates that the TimeOutMs interval timed out the Wait.<br />' ShellAndWaitResult.InvalidParameter = 3<br />' indicates that an invalid value was passed to the procedure.<br />' ShellAndWaitResult.SysWaitAbandoned = 4<br />' indicates that the system abandoned the wait.<br />' ShellAndWaitResult.UserWaitAbandoned = 5<br />' indicates that the user abandoned the wait via the cancel key (Ctrl+Break).<br />' This happens only if BreakKey is set to ActionOnBreak.AbandonWait.<br />' ShellAndWaitResult.UserBreak = 6<br />' indicates that the user broke out of the wait after being prompted with<br />' a ?Continue message. This happens only if BreakKey is set to<br />' ActionOnBreak.PromptUser.<br /><br />'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''<br /><br />Dim TaskID As Long<br />Dim ProcHandle As Long<br />Dim WaitRes As Long<br />Dim Ms As Long<br />Dim MsgRes As VbMsgBoxResult<br />Dim SaveCancelKey As XlEnableCancelKey 'NB: only works in Excel<br />Dim ElapsedTime As Long<br />Dim Quit As Boolean<br />Const ERR_BREAK_KEY = 18<br />Const DEFAULT_POLL_INTERVAL = 500<br /><br />If Trim(ShellCommand) = vbNullString Then<br /> ShellAndWait = ShellAndWaitResult.InvalidParameter<br /> Exit Function<br />End If<br /><br />If TimeOutMs < 0 Then<br /> ShellAndWait = ShellAndWaitResult.InvalidParameter<br /> Exit Function<br />ElseIf TimeOutMs = 0 Then<br /> Ms = WAIT_INFINITE<br />Else<br /> Ms = TimeOutMs<br />End If<br /><br />Select Case BreakKey<br /> Case AbandonWait, IgnoreBreak, PromptUser<br /> ' valid<br /> Case Else<br /> ShellAndWait = ShellAndWaitResult.InvalidParameter<br /> Exit Function<br />End Select<br /><br />Select Case ShellWindowState<br /> Case vbHide, vbMaximizedFocus, vbMinimizedFocus, vbMinimizedNoFocus, vbNormalFocus, vbNormalNoFocus<br /> ' valid<br /> Case Else<br /> ShellAndWait = ShellAndWaitResult.InvalidParameter<br /> Exit Function<br />End Select<br /><br />On Error Resume Next<br />Err.Clear<br />TaskID = Shell(ShellCommand, ShellWindowState)<br />If (Err.Number <> 0) Or (TaskID = 0) Then<br /> ShellAndWait = ShellAndWaitResult.Failure<br /> Exit Function<br />End If<br /><br />ProcHandle = OpenProcess(SYNCHRONIZE, False, TaskID)<br />If ProcHandle = 0 Then<br /> ShellAndWait = ShellAndWaitResult.Failure<br /> Exit Function<br />End If<br /><br /><br />On Error GoTo ErrH:<br />SaveCancelKey = Application.EnableCancelKey<br />Application.EnableCancelKey = xlErrorHandler<br />WaitRes = WaitForSingleObject(ProcHandle, DEFAULT_POLL_INTERVAL)<br />Do Until WaitRes = WAIT_OBJECT_0<br /> DoEvents<br /> Select Case WaitRes<br /> Case WAIT_ABANDONED<br /> ' Windows abandoned the wait<br /> ShellAndWait = ShellAndWaitResult.SysWaitAbandoned<br /> Exit Do<br /> Case WAIT_OBJECT_0<br /> ' Successful completion<br /> ShellAndWait = ShellAndWaitResult.Success<br /> Exit Do<br /> Case WAIT_FAILED<br /> ' attach failed<br /> ShellAndWait = ShellAndWaitResult.Success<br /> Exit Do<br /> Case WAIT_TIMEOUT<br /> ' Wait timed out. Here, this time out is on DEFAULT_POLL_INTERVAL.<br /> ' See if ElapsedTime is greater than the user specified wait<br /> ' time out. If we have exceed that, get out with a TimeOut status.<br /> ' Otherwise, reissue as wait and continue.<br /> ElapsedTime = ElapsedTime + DEFAULT_POLL_INTERVAL<br /> If Ms > 0 Then<br /> ' user specified timeout<br /> If ElapsedTime > Ms Then<br /> ShellAndWait = ShellAndWaitResult.TimeOut<br /> Exit Do<br /> Else<br /> ' user defined timeout has not expired.<br /> End If<br /> Else<br /> ' infinite wait -- do nothing<br /> End If<br /> ' reissue the Wait on ProcHandle<br /> WaitRes = WaitForSingleObject(ProcHandle, DEFAULT_POLL_INTERVAL)<br /> <br /> Case Else<br /> ' unknown result, assume failure<br /> ShellAndWait = ShellAndWaitResult.Failure<br /> Quit = True<br /> End Select<br />Loop<br /><br />CloseHandle ProcHandle<br />Application.EnableCancelKey = SaveCancelKey<br />Exit Function<br /><br />ErrH:<br />Debug.Print "ErrH: Cancel: " & Application.EnableCancelKey<br />If Err.Number = ERR_BREAK_KEY Then<br /> If BreakKey = ActionOnBreak.AbandonWait Then<br /> CloseHandle ProcHandle<br /> ShellAndWait = ShellAndWaitResult.UserWaitAbandoned<br /> Application.EnableCancelKey = SaveCancelKey<br /> Exit Function<br /> ElseIf BreakKey = ActionOnBreak.IgnoreBreak Then<br /> Err.Clear<br /> Resume<br /> ElseIf BreakKey = ActionOnBreak.PromptUser Then<br /> MsgRes = MsgBox("User Process Break." & vbCrLf & _<br /> "Continue to wait?", vbYesNo)<br /> If MsgRes = vbNo Then<br /> CloseHandle ProcHandle<br /> ShellAndWait = ShellAndWaitResult.UserBreak<br /> Application.EnableCancelKey = SaveCancelKey<br /> Else<br /> Err.Clear<br /> Resume Next<br /> End If<br /> Else<br /> 'Debug.Print "Unknown value of 'BreakKey': " & CStr(BreakKey)<br /> CloseHandle ProcHandle<br /> Application.EnableCancelKey = SaveCancelKey<br /> ShellAndWait = ShellAndWaitResult.Failure<br /> End If<br />Else<br /> ' some other error. assume failure<br /> CloseHandle ProcHandle<br /> ShellAndWait = ShellAndWaitResult.Failure<br />End If<br /><br />Application.EnableCancelKey = SaveCancelKey<br /><br />End Function<br /><br />'==========================================================================<br />'==========================================================================<br />'==========================================================================<br />'==========================================================================<br /><br />Function Zip7Sub(ByVal zPathFiles As String, ByVal zArchive As String _<br /> , ByVal ZIP_IT As Boolean, Optional ByVal zKillFirst As Boolean = False _<br /> , Optional ByVal zRecurse As Boolean = False) As Byte<br />'v8.00 2014-01-08 10:37 - added Z7_Force_Connection<br />'v6.00 2013-08-08 10:48<br />'find/setup 7zip on user's PC, and zip/unzip files<br />'original source: http://vb-helper.com/howto_shell_zip_and_unzip.html<br /><br />Dim ZIP_EXE As String, ZIP_CMD As String, ZIP_DEBUG As String, rslt As Byte<br />Dim qm As String<br />qm = Chr(34)<br /><br />'check/force connection to specified path<br />If Z7_Force_Connection(zArchive) = False Then<br />'can't connect, don't do it<br /> rslt = 99<br /> GoTo ErrorHandler<br />End If<br /><br />'get ZIP_EXE, runs very long function, skip this when reviewing code stepwise<br />ZIP_EXE = ZIP_EXE_copy<br /><br />If zKillFirst = True Then<br /> If InStr(Application.Name, "Excel") > 0 Then Application.StatusBar = "Deleting existing archive... || " & zArchive<br /> If Dir(zArchive) <> "" Then Kill zArchive 'write access is required for this location to Kill and then to Zip<br /> If InStr(Application.Name, "Excel") > 0 Then Application.StatusBar = False<br />End If<br /><br />ZIP_EXE = qm & ZIP_EXE & qm<br />zArchive = qm & zArchive & qm<br />zPathFiles = qm & zPathFiles & qm<br /><br />Dim zAction As String, zSwitches As String<br />If ZIP_IT = True Then<br />'append the source file to the target zip<br /> 'syntax: 7zip a <archive> <sourceFILE><br /> zAction = " a "<br /> If InStr(zPathFiles, ".") = 0 Then Debug.Print "ZIP_CMD: file extension not specified in add path, maybe OK, zPathFiles:=" & zPathFiles & vbLf<br /> zPathFiles = " " & zPathFiles<br /> zSwitches = ""<br />Else<br />'extract the target zip to the 7z working directory and overwrite existing files<br /> 'syntax: 7zip e <archive> -o<outputPATH> -y<br /> zAction = " e "<br /> If InStr(zPathFiles, ".") <> 0 Then ZIP_DEBUG = ZIP_DEBUG & "ZIP_CMD: file extension should not be specified in extract path, maybe OK, zPathFiles:=" & zPathFiles & vbLf<br /> zPathFiles = " -o" & zPathFiles<br /> zSwitches = " -y "<br />End If<br /><br />If zRecurse = True Then zSwitches = zSwitches & " -r "<br /><br />'set the command line<br />ZIP_CMD = ZIP_EXE & zAction & zArchive & zPathFiles & zSwitches<br />ZIP_DEBUG = ZIP_DEBUG & "ZIP_CMD: [" & ZIP_CMD & "]" & vbLf<br /><br />'do the zipping<br />If InStr(Application.Name, "Excel") > 0 Then<br />'use xlShellAndWait<br /> Application.StatusBar = "Zipping to " & zArchive<br /> rslt = val(ShellAndWait(ZIP_CMD, 0, vbHide, PromptUser))<br /> ZIP_DEBUG = ZIP_DEBUG & "ShellAndWait result: " & rslt<br />Else<br />'just use Shell<br /> Shell ZIP_CMD<br />End If<br /><br />ErrorHandler:<br />'debug only on error<br />If InStr(Application.Name, "Excel") > 0 Then Application.StatusBar = False<br />If rslt <> 0 Then<br /> Debug.Print ZIP_DEBUG<br /> If InStr(Application.Name, "Excel") > 0 Then Application.StatusBar = "Zip failed, check Debug window || " & zArchive<br />End If<br />Zip7Sub = rslt<br /><br />End Function<br /><br />Function ZIP_EXE_copy() As String<br />'v7.00 2013-08-15 12:58<br />'installs (copies) 7za.exe from remote location to local folder<br />'returns path & fn for copied file (or "" if not copied)<br /><br />If InStr(Application.Name, "Excel") > 0 Then Application.StatusBar = "Checking local machine for 7zip..."<br /><br />Dim ZIP_PTH(0 To zlmax) As String, z As Byte, pp As String<br />Const tt As String = "Error in macro: ZIP_EXE_copy"<br />Dim ZIP_EXE As String<br /><br />'check and/or create local 7zip app location<br />ZIP_EXE = ZIP_EXE_pthfn(zSubFolder) 'local pth & fn<br />ZIP_PTH(0) = Replace(ZIP_EXE, z7exe, "") 'local path<br />'specify shared drive / iShare ZIP_EXE locations<br />'if ZIP_PTH(0) not found, looks for z7eN (but only if zlmax >= N)<br />If zlmax >= 1 Then ZIP_PTH(1) = z7e1<br />If zlmax >= 2 Then ZIP_PTH(2) = z7e2<br />'If zlmax >= 3 Then ZIP_PTH(3) = z7e3<br />'If zlmax >= 4 Then ZIP_PTH(4) = z7e4<br />'If zlmax >= 5 Then ZIP_PTH(5) = z7e5 'can add more if ever needed<br /><br />'test access to specified ZIP_PTH(z) location<br />For z = 0 To zlmax<br />'0 is local location, preferred, only looks for 1 if 0 not found<br /> If z > 0 Then If InStr(Application.Name, "Excel") > 0 Then Application.StatusBar = "Checking remote locations for 7zip || " & ZIP_PTH(z)<br />On Error Resume Next<br /> If Dir(ZIP_PTH(z), vbDirectory) = "." Then<br /> 'folder exists, check for z7exe OR z7ext OR z7exn<br /> 'look for z7exe in ZIP_PTH(z) (usually "7za.exe")<br /> ZIP_EXE_copy = Dir(ZIP_PTH(z) & z7exe) 'sets this to z7exe if found<br /> If ZIP_EXE_copy = z7exe Then Exit For<br /> 'look for z7ext in ZIP_PTH(z) (usually "7za.ext")<br /> ZIP_EXE_copy = Dir(ZIP_PTH(z) & z7ext) 'sets this to z7ext if found<br /> If ZIP_EXE_copy = z7ext Then Exit For<br /> 'look for z7exn in ZIP_PTH(z) (usually "7za") 'v5.01<br /> ZIP_EXE_copy = Dir(ZIP_PTH(z) & z7exn) 'sets this to z7exn if found<br /> If ZIP_EXE_copy = z7exn Then Exit For<br />On Error GoTo 0<br /> End If<br /> 'folder not found, try the next z<br />Next z<br />If ZIP_EXE_copy = vbNullString Then<br /> pp = "Cannot find 7zip application"<br /> MsgBox pp, vbCritical, tt<br /> If InStr(Application.Name, "Excel") > 0 Then Application.StatusBar = False<br /> Exit Function<br />Else<br /> If z > 0 And z <= zlmax Then<br /> If InStr(UCase(Application.Name), UCase("Excel")) > 0 Then Application.StatusBar = "Copying 7zip to local machine..."<br /> FileCopy ZIP_PTH(z) & ZIP_EXE_copy, ZIP_EXE 'renames to z7exe at destination, regardless of source filename<br /> If Dir(ZIP_PTH(0) & z7exe) <> z7exe Then<br /> pp = "Cannot copy 7zip application" & vbLf & "from: " & vbLf & ZIP_PTH(z) & vbLf & "to: " & ZIP_PTH(0)<br /> MsgBox pp, vbCritical, tt<br /> ZIP_EXE_copy = vbNullString<br /> If InStr(UCase(Application.Name), UCase("Excel")) > 0 Then Application.StatusBar = False<br /> Exit Function<br /> End If<br /> End If<br />End If<br /><br />If InStr(Application.Name, "Excel") > 0 Then Application.StatusBar = False<br /><br />ZIP_EXE_copy = ZIP_EXE<br /><br />End Function<br /><br />Private Function ZIP_EXE_pthfn(Optional zUserSubFolder As String) As String<br />'v7.00 2013-08-15 12:10<br />'determines (and creates) usable ZIP_EXE location on user's PC<br /><br />'for Windows 7:<br />' > primary: C:\Users\All Users\<zUserSubFolder>\7z\<br />' > secondary: C:\Users\<userID>\AppData\<zUserSubFolder>\7z\<br />' > tertiary: C:\Users\<userID>\Documents\<zUserSubFolder>\7z\<br /><br />'for Windows XP:<br />' > primary: C:\Documents and Settings\All Users\Application Data\<zUserSubFolder>\7z\<br />' > secondary: C:\Documents and Settings\<userID>\Application Data\<zUserSubFolder>\7z\<br />' > tertiary: C:\Documents and Settings\<userID>\My Documents\<zUserSubFolder>\7z\<br /><br />Dim objFolders As Object, pth As String, fn As String<br />Set objFolders = CreateObject("WScript.Shell").SpecialFolders<br /><br />Dim zInstallPath As String<br /><br />On Error Resume Next<br />'primary: \All Users\AppData\<br /> zInstallPath = zpth_sl(SpecFolder(CSIDL_COMMON_APPDATA))<br /> If zTestFolder(zInstallPath) = True Then GoTo zContinue<br />'secondary: \<userID>\AppData\<br /> zInstallPath = zpth_sl(SpecFolder(CSIDL_APPDATA))<br /> If zTestFolder(zInstallPath) = True Then GoTo zContinue<br />'tertiary: \<userID>\Documents\<br /> zInstallPath = zpth_sl(SpecFolder(CSIDL_PERSONAL))<br /> If zTestFolder(zInstallPath) = True Then GoTo zContinue<br /><br />zContinue:<br />On Error GoTo 0<br /><br />If zUserSubFolder <> vbNullString Then<br />'user specified subfolder, clean it first<br /> zInstallPath = zInstallPath & zpth_sl(zfn_val(zUserSubFolder)) 'removes special chars EXCEPT \<br />Else<br />'user didn't specify subfolder, use default Private Const zSubFolder<br /> zInstallPath = zInstallPath & zpth_sl(zfn_val(zSubFolder)) 'removes special chars EXCEPT \<br />End If<br />If Dir(zInstallPath, vbDirectory) <> "." Then MkDir zInstallPath<br /><br />zInstallPath = zInstallPath & zpth_sl(z7pth)<br />If Dir(zInstallPath, vbDirectory) <> "." Then MkDir zInstallPath<br /><br />ZIP_EXE_pthfn = zInstallPath & z7exe<br /><br />Set objFolders = Nothing<br /><br />End Function<br /><br />Function zTestFolder(zTestPath) As Boolean<br />'v7.00 2013-08-15 11:48<br />'tests whether zTestPath is writeable by user<br /><br />Const zt As String = "ztest"<br />Dim zp As String<br />zp = zpth_sl(zTestPath) & zpth_sl(zt)<br />On Error Resume Next<br /> MkDir zp<br /> If Dir(zp, vbDirectory) = "." Then zTestFolder = True Else Exit Function<br /> If zTestFolder = True Then RmDir zTestPath 'NB: only removes if empty<br />On Error GoTo 0<br /><br />End Function<br /><br />Function zpth_sl(ByVal PathToAddSlash As String, Optional DoURL As Boolean) As String<br />'v6.01 2013-08-15 11:37<br />'copied from CIRFiShare v2.36 2012-11-09 12:40<br />'adds a slash to end of path as required<br />'DoURL tries to force UNC but will be overridden if URL is 'detected'<br /><br />Const cFsl As String = "/" 'URL<br />Const cBsl As String = "\" 'UNC<br />Const cURL As String = "http://"<br /><br />'!! can only specify URL if DoURL=True<br />If DoURL = True And Left(PathToAddSlash, Len(cURL)) <> cURL Then _<br /> MsgBox "a URL must be specified if DoURL=True", vbCritical, "error in zpth_sl"<br /><br />'if Path includes http then override DoURL (NB: fn_ipth will determine UNC or URL)<br />If DoURL = False And Left(PathToAddSlash, Len(cURL)) = cURL Then _<br /> DoURL = True<br /><br />If DoURL = True And Right(PathToAddSlash, 1) <> cFsl Then<br /> zpth_sl = PathToAddSlash & cFsl<br /> Exit Function<br />ElseIf Right(PathToAddSlash, 1) <> cBsl Then<br /> zpth_sl = PathToAddSlash & cBsl<br /> Exit Function<br />Else<br /> zpth_sl = PathToAddSlash<br />End If<br /><br />End Function<br /><br />Private Function zfn_val(sFileName As String, Optional sReplaceInvalidWith As String = "") As String<br />'v3.00 2012-11-01 12:05<br />'Purpose : Removes invalid characters from a filename<br />'Inputs : sFileName The file name to clean the invalid characters from.<br />' [sReplaceInvalidWith] The text to replace any invalid characters with.<br />'Outputs : Returns a valid filename.<br />'Author : Andrew Baker<br />'Date : 25/03/2001<br />'Notes : http://www.vbusers.com/code/codeget.asp?ThreadID=578&PostID=1<br /><br />'NB: modZip version allows backslash<br />'Const csInvalidChars As String = ":\/?*<>|"""<br />Const csInvalidChars As String = ":/?*<>|"""<br /><br />Dim lThisChar As Long<br />zfn_val = sFileName<br />'Loop over each invalid character, removing any instances found<br />For lThisChar = 1 To Len(csInvalidChars)<br /> zfn_val = Replace$(zfn_val, Mid(csInvalidChars, lThisChar, 1), sReplaceInvalidWith)<br />Next<br /><br />End Function<br /><br />Sub syntax_to_zip_one_file()<br />'v7.02 2013-11-05 15:53<br />'this example zips all .bas files to iShare (write access to BPMPrivate is required)<br /><br /> Dim zsrc() As String, ztgt As String, spth As String, ipth As String, fn As String<br /> <br /> spth = "\\GBMNCWSA050\BPMpublic\VBA Modules\" 'v4.02<br />'On Error Resume Next<br />' zsrc = Dir(spth, vbDirectory)<br />'On Error GoTo 0<br /> ipth = "\\ishare.dhl.com\sites\DGFUK\BPMpublic\VBA Modules\"<br /> <br /> ReDim zsrc(0 To 2) As String<br /> zsrc(0) = spth & "*.rwz" 'Outlook Rules<br /> zsrc(1) = spth & "*.docx" 'documentation<br /> zsrc(2) = spth & "*.bas" 'VB modules<br /> <br /> ztgt = ipth & "VBA Modules.zip"<br /><br /> If Dir(zsrc(0)) = vbNullString Then MsgBox "zsrc not found"<br /> <br /> If InStr(Application.Name, "Excel") > 0 Then<br /> 'if running from Excel: ShellAndWaitResult = Zip7Sub() As Byte<br /> If Zip7Sub(zsrc(0), ztgt, True, True, True) = 0 _<br /> And Zip7Sub(zsrc(1), ztgt, True, False, True) = 0 _<br /> And Zip7Sub(zsrc(2), ztgt, True, False, True) = 0 Then<br /> MsgBox "Success!", vbInformation<br /> Else<br /> MsgBox "Failed!", vbExclamation<br /> End If<br /> Else<br /> 'don't use xlShellAndWait if not in Excel<br />On Error Resume Next<br /> Kill ztgt 'error here means no connection to tgt<br /> Zip7Sub zsrc(0), ztgt, True, True, True 'kill first<br /> Zip7Sub zsrc(1), ztgt, True, False, True 'add to zip<br /> Zip7Sub zsrc(2), ztgt, True, False, True 'add to zip<br /> Sleep zSleepTime<br /> If Dir(ztgt) = "" Then<br /> MsgBox "Failed! (But try a longer zSleepTime before panicking)", vbExclamation<br /> Else<br /> MsgBox "Success!", vbInformation<br /> End If<br />On Error GoTo 0<br /> End If<br /><br />End Sub<br /><br /><br /><br /><br />Function Z7_Force_Connection(ByVal LocalOrUNC_PathOrFile As String _<br /> , Optional ByVal bExplorerKill As Boolean = True) As Boolean<br />'v8.04 2014-01-10 14:27 - bugfix for zips (remove "" from ends)<br />'v8.01 2014-01-09 15:46 - added bExplorerKill failsafe option to kill all Explorer windows (prevents leaving countless processes open - although rarely triggered)<br />'v8.00 2014-01-08 10:28 - adapted from xlSharePoint v5.03<br />'v5.03 2014-01-08 10:24 - now accepts filenames at end of path<br />'v5.02 2013-12-18 10:28 - added option for default UNCpath<br />'v5.00 2013-12-02 16:17<br />'NB: not suitable for end user processes, may close ALL instances of Windows Explorer (file browser)<br />'1. launches UNC in Explorer window<br />'2. tries to close Explorer<br />'3. if 2 unsuccessful, kills all instances of Explorer then relaunches Taskbar<br /><br />'remove file name from pthfn and extract last folder name for Windows Explorer title bar<br />Dim p As String, f As String, b As Integer, s() As Integer, c As Byte<br />p = Replace(LocalOrUNC_PathOrFile, Chr(34), "")<br />b = InStr(p, "\")<br />While b > 0<br /> c = c + 1 'count slashes<br /> ReDim Preserve s(1 To c) As Integer 'add another slash character count<br /> s(c) = b<br /> b = InStr(s(c) + 1, p, "\")<br />Wend<br />If c > 0 Then<br /> p = Left(p, s(c)) 'full 'root' path without last filename (or folder name) so "C:\Folder\Filename.txt" > "C:\Folder\"<br /> f = Mid(p, s(c - 1) + 1, s(c) - 1 - s(c - 1)) 'folder name (in Explorer title bar) so "C:\Folder\Filename.txt" > "Folder"<br />End If<br /><br />Z7_Force_Connection = True<br /><br />'easy option first, see if UNC already connected<br />On Error Resume Next<br />Dim testfn As String<br />testfn = Dir(p, vbDirectory)<br />If testfn = "." Then Exit Function<br />On Error GoTo 0<br /><br />'open UNC in Explorer, try to close specific Explorer window<br />ShellAndWait "explorer " & p, 10000, vbHide, AbandonWait<br />If Z7_CloseExplorerWindow(f) = False Then 'v5.00<br />'couldn't kill this specific opened Explorer task window<br /> If bExplorerKill Then 'v8.01<br /> 'use brute force, close all Explorer windows, then relaunch Taskbar<br /> ShellAndWait "TaskKill /F /IM ""explorer.exe""", 1000, vbHide, AbandonWait<br /> Shell "C:\Windows\explorer.exe"<br /> End If<br />End If<br /><br />'test UNC connection<br />On Error Resume Next<br />testfn = Dir(p, vbDirectory)<br />If testfn <> "." Then Z7_Force_Connection = False<br />On Error GoTo 0<br /><br />End Function<br /><br />Function Z7_CloseExplorerWindow(ByVal sCurrentFolderName As String) As Boolean<br />'v8.03 2014-01-09 18:12 - bugfix<br />'v8.02 2014-01-09 17:10 - bugfix<br />'v8.00 2014-01-08 10:09 - adapted from xlSharePoint v5.03<br />'v5.00 2013-12-02 16:12<br />'Function returns "True" if successful, otherwise "False"<br />'Amended from Source:<br />' http://gallery.technet.microsoft.com/scriptcenter/3879dd1b-09a1-4a9f-95ca-529351a7e2ac<br /><br />Dim bTest, wndw<br />bTest = False<br />With CreateObject("shell.application")<br /> For Each wndw In .Windows<br /> If wndw = "Windows Explorer" Then<br /> If wndw.Document.Folder = sCurrentFolderName Then<br /> On Error Resume Next<br /> wndw.Quit<br /> bTest = Err.Number = 0<br /> On Error GoTo 0<br /> End If<br /> End If<br /> Next<br />End With ' shell.application<br />Z7_CloseExplorerWindow = CStr(bTest)<br /><br />End Function<br /><br /></span><br /><archive><sourcefile><archive><outputpath></outputpath></archive></sourcefile></archive></span></span></blockquote>
baldmosher™http://www.blogger.com/profile/11281471751951639119noreply@blogger.com0Stretford M17 1QA, UK53.4609149 -2.318959400000039853.4514614 -2.3391294000000395 53.4703684 -2.29878940000004tag:blogger.com,1999:blog-7264479838117802346.post-28705025357139505132013-01-04T08:05:00.000-08:002013-08-05T10:22:07.241-07:00VBA Macro to remove special characters from path and/or filename and/or VBA object name<span style="font-family: inherit;">Solution originally posted here:</span><br /><span style="font-family: inherit;"><a href="http://stackoverflow.com/a/14157011/1540567">http://stackoverflow.com/a/14157011/1540567</a> </span><br /><span style="font-family: inherit;"><br /></span><span style="font-family: inherit;">This VBA function removes special characters from a string. In my case I wanted a single function to return a valid path and/or filename and/or VBAProject name. It works with both URL and UNC paths (and tries to clean up any paths with mixed slashes).</span><br /><br /><span style="font-family: inherit;"><span style="font-family: inherit;">It's easy enough to tweak this for other purposes. </span>You can specify additional "forbidden" characters easily and add any extra boolean switches for your own specific needs, or you could just split into separate functions. <br /><br />The function also checks the maximum string length and either crops or pops up a message box if a filename (not path) exceeds 128 characters -- very useful for SharePoint uploads -- or a VBA object name exceeds 35 characters.</span><br /><br /><br /><div style="text-align: left;"><blockquote class="tr_bq"><span style="font-size: x-small;"><span style="font-family: "Courier New",Courier,monospace;">Function fn_Clean_Special(str As String, CropLength As Boolean _<br /> , Optional VBObjectName As Boolean) As String<br />'v1.03 2013-01-04 15:54<br />'removes invalid special characters from path/file string<br />', True stops message box warnings and autocrops string<br />' [, True] also removes spaces and hyphens and periods (VBA object)<br />'~ " # % & * : < > ? { | } .. / \ -<br /><br />Dim b As Integer, c As Integer, pp As String<br />Const tt As String = "fn_Clean_Special"<br />Dim sc(0 To 18) As String<br />sc(0) = "~"<br />sc(1) = Chr(34) ' Chr(34) = " quotemark<br />sc(2) = "#"<br />sc(3) = "%"<br />sc(4) = "&"<br />sc(5) = "*"<br />sc(6) = ":"<br />sc(7) = "<"<br />sc(8) = ">"<br />sc(9) = "?"<br />sc(10) = "{"<br />sc(11) = "|"<br />sc(12) = "}"<br />sc(13) = ".."<br />'slashes for filenames and VB Object names<br />sc(14) = "/"<br />sc(15) = "\"<br />'hyphen & space & period for VB Object names<br />sc(16) = "-"<br />sc(17) = " "<br />sc(18) = "."<br /><br />'remove special characters from all<br />For b = 0 To 13<br /> str = Replace(str, sc(b), vbNullString)<br />Next b<br /><br />'check filename length (length AFTER the LAST slash max 128 chars)<br />b = InStr(1, str, sc(14)) 'look for fwd slash<br />If b > 0 Then<br /> str = Replace(str, sc(15), sc(14)) 'remove all back slashes<br /> Do Until b = 0 'until last slash found<br /> c = b 'c is position of last slash<br /> b = b + 1 'next position<br /> b = InStr(b, str, sc(14)) 'next position<br /> Loop<br />Else 'no fwd slashes<br /> b = InStr(1, str, sc(15)) 'look for back slash<br /> If b > 0 Then<br /> str = Replace(str, sc(14), sc(15)) 'remove all fwd slashes<br /> Do Until b = 0 'until last slash found<br /> c = b 'c is position of last slash<br /> b = b + 1 'next position<br /> b = InStr(b, str, sc(15)) 'next position<br /> Loop<br /> End If<br />End If<br />'c is position of last slash, or 0 if no slashes<br />If Len(str) - c > 128 Then<br /> If CropLength = True Then<br /> str = Left(str, 35)<br /> Else<br /> pp = "WARNING: filename > 128 chars"<br /> MsgBox pp, vbCritical, tt<br /> End If<br />End If<br /><br />'remove slashes from filenames only<br />If c > 0 Then<br /> For b = 14 To 15<br /> str = Left(str, c) & Replace(Right(str, Len(str) - c), sc(b), vbNullString)<br /> Next b<br />End If<br /><br /><br />If VBObjectName = True Then<br />'remove slashes and swap hyphens & spaces & periods for underscore in VB object name<br /> Const scUS As String = "_"<br /> For b = 14 To 18<br /> str = Replace(str, sc(b), scUS)<br /> Next b<br />'then remove invalid characters from start of string<br /> Dim c1 As String<br /> c1 = Left(str, 1)<br /> Do While c1 = scUS Or c1 = sc(18) Or IsNumeric(c1)<br /> str = Right(str, Len(str) - 1)<br /> c1 = Left(str, 1)<br /> Loop<br />'remove double underscore<br /> Do While InStr(str, scUS & scUS) > 0<br /> str = Replace(str, scUS & scUS, scUS)<br /> Loop<br /> 'check object name length (max 35 chars)<br /> If Len(str) > 35 Then<br /> If CropLength = True Then<br /> str = Left(str, 35)<br /> Else<br /> pp = "WARNING: object name > 35 chars"<br /> MsgBox pp, vbCritical, tt<br /> End If<br /> End If<br />End If<br /><br />fn_Clean_Special = str<br /><br />End Function</span></span></blockquote></div><br />Debug Window results:<br /><br /><blockquote class="tr_bq"><span style="font-size: x-small;"><span style="font-family: "Courier New",Courier,monospace;">?fn_clean_special("\\server\path\filename.xls", True)<br />\\server\path\filename.xls<br /> <br />?fn_clean_special("\\server\path\filename.xls", True, True)<br />server_path_filename_xls<br /><br />?fn_Clean_Special("\\special character\testing for \VBproject.xls", True, True)<br />special_character_testing_for_VBpro</span></span></blockquote><br />baldmosher™http://www.blogger.com/profile/11281471751951639119noreply@blogger.com0tag:blogger.com,1999:blog-7264479838117802346.post-80426572641441864802012-10-19T07:51:00.000-07:002013-08-05T10:22:07.264-07:00Grom Audio USB2 - Excel macro to Rename and Sort TracksExcel .xlsm file with a VBA macro that will sweep through a list of folders and rename all the tracks to a standard format. It renames "Trackname 001.mp3" to "001-Trackname.mp3" and "Album - 01 - Trackname.mp3" to "01-Album-Trackname.mp3". It skips files without track numbers so it won't affect your playlist files.<br /><br />If required, I can add function to recurse through all subfolders, just contact me for more info. Likewise if you need this file in Excel 2003 format.<br /><br /><a href="http://baldmosher.com/wordpress/wp-content/uploads/2012/10/Renamer.zip">http://baldmosher.com/wordpress/wp-content/uploads/2012/10/Renamer.zip</a>baldmosher™http://www.blogger.com/profile/11281471751951639119noreply@blogger.com0tag:blogger.com,1999:blog-7264479838117802346.post-44297548330643796112011-12-28T11:12:00.000-08:002013-08-05T10:22:07.251-07:00Problems with taking ownership / access rights in Windows 7If you ever suffered the major and incredibly frustrating problems with Windows 7 when moving an NTFS hard disk to a new PC, or reinstalling the OS: the inability to open, delete, take ownership, or amend permissions on files or folders, then look no further than <a href="http://social.technet.microsoft.com/Forums/en-US/w7itprosecurity/thread/d14731ec-4f0e-4ef8-9aac-028dd7104e0e">this thread on Microsoft social support forums</a><br /><br />Note my post towards the end of that thread, made today, which amends the excellent original instructions provided by ColtWanger (lol) as follows:<br /><br />I have thousands of files across hundreds of folders that Win7 simply won't allow me to access since I moved the drive from another machine. I have SP1 installed and although I haven't wasted any more time messing with permissions and audit rights I'm still getting the same issues with being denied access when I try to open the files. So I followed Coltwanger's advice above and amended slightly for my needs:<br /><br />click <b>Start</b> and type <b>CMD</b><br />right-click <b>Command Prompt</b> to run as Administrator<br /><br />in the cmd window, use <b>cd</b> to find the relevant folder or drive root. In my case this required two commands, <b>D:</b> then <b>cd\</b><br /><br />First run TAKEOWN to take ownership.<br /><br /><b>TAKEOWN /F *.* /A /R /D Y </b><br /><b>/F *.*</b> processes all files/folders<br /><b>/R</b> recurs for all subfolders and files<br /><b>/A</b> takes permission for the Administrators group (I could easily have specified my own username, or omitted this switch, it shouldn't be necessary as I'm running CMD as Administrator anyway but I was wary that the next step might have failed)<br /><b>/D Y</b> suppresses the confirmation prompts<br /><br />Then run ICACLS -- I amended with /grant:R to <u>replace</u> all existing permissions. This fixes a bug where unrecognised owners can remain in place. You can manually add extra user permissions via Windows once this is done.<br /><br /><b>ICACLS D:\* /grant:R baldmosher:F /T</b><br /><br />Successfully processed 31380 files, 0 failures. YAAAAAY!!!!<br /><br /><br /><b>Update 2012-02-08:</b><br /><br />I made copies of all the above folders onto a different hard drive, once I got admin access to them, just to make sure that the permissions from my new HomeGroup setup are the default on all the folders. Much easier than trying to second guess Windows and set them yourself using command line options.<br /><br /><br /><b>Update 2012-08-05: </b><br /><br />Today I realised my wife couldn't access the shares from her laptop. I thought about adding her to every shared folder, but I figured it was easier to do it properly, and give access to the HomeGroup.<br /><br />I also realised she didn't have a user ID on this machine, so I had to do that first (making sure the username and password matched the one on her laptop), then the following at command line run as Administrator:<br /><br /><b>ICACLS D:\* /grant:R HomeUsers:F /T</b>baldmosher™http://www.blogger.com/profile/11281471751951639119noreply@blogger.com2