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.
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.
Note that this module is currently in beta simply because I've not tested 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.
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!
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.
'xlSharePoint
'v5.07 2014-01-16 14:56
'===========================================================================
' HELP CONTACT
'===========================================================================
' Code is provided without warranty and can be stolen and amended as required.
' Tom Parish
' TJP@tomparish.me.uk
' http://baldywrittencod.blogspot.com
' DGF Help Contact: see BPMHelpContact module
'=========================================================================
'*** BETA ***
'SP_Open_and_CheckIn untested with SharePoint Document Libraries that force CheckOut
'always export to \\GBMNCWSA050\BPMpublic\VBA Modules\
' ***********************************************
' ***** WARNING: v3+ incompatible with v2 *****
' ***********************************************
' *****************************************************
' ***** WARNING: SETTINGS BELOW MUST BE AMENDED *****
' *****************************************************
'===========================================================================
' xlSharePoint
'===========================================================================
' This module handles various SharePoint functions with either UNC
' or URL addresses, depending on user settings.
'
' Works for Office 2007/2010 and Windows 7
' (2003 and XP sort of works, but is buggy)
'===========================================================================
' Additional modules required:
'===========================================================================
' modAppsOffice v4
' modCheckUsers v2
' modKeyState
' modZip v6
'
' Code included from other modules:
' [modSpecialFolders]
' [xlShellAndWait]
'===========================================================================
' Additional References required:
'===========================================================================
' Microsoft Excel Object Library (if not running from Excel)
'===========================================================================
' External applications required:
'===========================================================================
' Microsoft Outlook (for Outlook functions)
' Microsoft Access (for Access functions)
' Microsoft Excel (for Excel functions)
'=========================================================================
' VERSION HISTORY
'=========================================================================
'v5.07 2014-01-16 14:56 - ShellAndWait now Private, resolves conflict with xlShellAndWait module
'v5.06 2014-01-13 17:45 - ThisWorkbook code updated to allow VBA weekly update automation
'v5.05 2014-01-10 14:27 - SP_Force_Connection - bugfix for zips (remove "" from ends)
'v5.04 2014-01-09 17:11 - SP_CloseExplorerWindow - bugfix
'v5.03 2014-01-08 10:24 - SP_Force_Connection - now accepts filenames at end of path
'v5.02 2013-12-18 10:28 - SP_Force_Connection - added option for default UNCpath
' v5.01 xlShellAndWait - late binding bugfix
' v5.00 SP_Force_Connection/SP_CloseExplorerWindow: major improvement
' to closing Explorer window opened during forced UNC connection
'*************************************************************************
' previous versions should be upgraded to v5.00
'*************************************************************************
' v4.10 SP_Force_Connection: result changed to Boolean
' v4.09 Workbook_Open routine added to ThisWorkbook module code at end
' v4.08 bugfix in ThisWorkbook module code at end
' v4.07b SP_Open_and_CheckIn bugfix: Workbooks(fn).CanCheckIn
' v4.06 spXLapp, stops reliance on XLapp in modAppsOffice
' v4.05a improved ThisWorkbook module code at end
' v4.05 SP_Upload_from_2007: safer Quit routine
' v4.04 improved ThisWorkbook module code at end
' v4.03 SP_Upload_from_2007: added option to Break Links
' v4.02 SP_Force_Connection: less brutal, checks Dir(UNCpath) first
' v4.01 added SP_Force_Connection, uses ShellAndWait
' added code from xlShellAndWait
' v4.00 added code from modSpecialFolders
' v3.03 SP_Upload_from_2007: shortened option variable names; added
' validity check; all output variables optional
' v3.02 SP_Upload_from_2007: added AlsoSaveCopyToSecondaryPath
' v3.01 SP_Upload_from_2007: added XLSX; process improvements
'*** SP_Open_and_CheckIn BETA ***
'*** untested with folders that force CheckOut / CheckIn when publishing ***
' v3.01b SP_Open_and_CheckIn runs in background
' v3.00b added SP_Open_and_CheckIn
' v3.00 SP_Upload_from_2007: allows Publish to SharePoint
' retired SPCheckUpload (superseded)
' retired fextn and textn (only used in CIRF)
' renamed SP_pth_sl and SP_fn_val (conflict with CIRF)
' renamed SP_Upload_XLS_and_XLSM to SP_Upload_from_2007
'*************************************************************************
' WARNING: previous versions not compatible with v3 and must be upgraded
'*************************************************************************
' v2.07 SP_Upload_XLS_and_XLSM: temp pth changed to \\UserDocs\BPM Tools\temp\
' SP_Upload_XLS_and_XLSM: allows Publish of XLS and XLSM
' v2.06 SP_Upload_XLS_and_XLSM: added CSV option
' removed SPpthS, not needed
' annotations (additional modules)
' v2.05 added SP_Check_Special (moved from xlUtils.xlU_Check_Special)
' v2.04 renamed file extension constants (more consistent)
' SP_Upload_from_2003: renamed from SP_Upload and error handlers improved
' v2.03 added SP_Upload_XLS_and_XLSM
' v2.02 changed Public constants & functions to Private (conflicts)
' v2.01 removed ftyp=52 as misleading coding; updated annotations
' v2.00 module name changed (was modSharePoint but needs Excel library)
' v1.16 bugfix: Application.Statusbar for non-Excel applications
' v1.15 code tidy up, annotations improved, no functional change
' v1.14 added cPrd "."
' v1.13 added xzip extension
' v1.12 added xxlx, xxlm, xxlb extensions
' v1.11 added SP_Upload
' v1.10 added fn_SPpth
' v1.09 added warning at top of module
' v1.08 added SPdom, SP_OfferToCheckInAllWorkbooks
' v1.07 renamed module and macros, iMacroName to SPMacroName
' v1.06 SPUseCheckOut improvements, but still quite buggy
' v1.05 bugfixes, cleanups
' v1.04 bugfixes, cleanups
' v1.03 bugfixes, cleanups
' v1.02 added SPUseCheckOut
' *****************************************************
' ***** WARNING: SETTINGS BELOW MUST BE AMENDED *****
' *****************************************************
Option Explicit
Option Compare Text 'for ShellAndWait
'*** SYNTAX:
'*** Use fn_SPpth(SomeURL) in code to convert SPpth URL into UNC and force connection (if possible for this user)
'*** --> [SomeURL] should always be a PUBLIC SharePoint location to prevent user access errors
'*** --> ideally has Read permission for "NT Authority\Authenticated Users" (or equivalent generic public access group)
'*** Specify your 'parent' top level SharePoint SITE here as URL
Public Const SPpth As String _
= "http://ishare.dhl.com/sites/DGFUK/"
'Public Const SPpthUNC As String = fn_SPpth(SPpth)
'*** Specify your 'parent' top level SharePoint DOMAIN here (must be same as above)
Public Const SPdom As String = "ishare.dhl.com"
Private spXLapp As Excel.Application 'v4.06 prevents reliance on & conflicts with modAppsOffice
Private Const cURL As String = "http:" 'If Left(SPpth, 5) = cURL Then SPsetsl = cFsl Else cBsl
'Private Const cUNC As String = "\\" 'not necessary
Private Const xzip As String = ".zip" 'zip file
'Excel <=2003
Private Const xxls As String = ".xls" 'FileFormat:=56, Office 2003 macro enabled workbook
Private Const xxlt As String = ".xlt" 'FileFormat:=??, Office 2003 macro enabled template
Private Const x2k3 As String = " (2003)" 'added to filename during zip upload, i.e. "Report Name (2003).zip"
'Excel >2003
Private Const xxlx As String = ".xlsx" 'FileFormat:=51, Office 2007/10 workbook
Private Const xxlm As String = ".xlsm" 'FileFormat:=52, Office 2007/10 macro enabled workbook
Private Const xxlb As String = ".xlsb" 'FileFormat:=??, Office 2007/10 binary workbook
Private Const xxtm As String = ".xltm" 'FileFormat:=??, Office 2007/10 macro enabled template
Private Const xcsv As String = ".csv" 'FileFormat:=6, CSV file
'Office 2010: Val(Application.Version) = 14 Office 2007: Application.Version = "12.0" Office 2003: Application.Version = "11.0"
'Private Const v3 As Byte = 11
Private Const v7 As Byte = 12 '>=v7 proves 2007/2010
'Private Const v10 As Byte = 14
Private Const cSpc As String = " "
Private Const cHyp As String = "-"
Private Const cFsl As String = "/"
Private Const cBsl As String = "\"
Private Const cAst As String = "*"
Private Const cPrd As String = "."
Private Const wsA As String = "admin"
'==========================================================================
'==========================================================================
'==========================================================================
'==========================================================================
'
' Code from modSpecialFolders module:
'
'http://answers.microsoft.com/en-us/office/forum/office_2010-customize/how-2-refer-to-desktop/97eba910-54c9-409f-9454-6d7c8d54d009
Private Declare Function SHGetSpecialFolderLocation _
Lib "shell32" (ByVal hwnd As Long, _
ByVal nFolder As Long, ppidl As Long) As Long
Private Declare Function SHGetPathFromIDList _
Lib "shell32" Alias "SHGetPathFromIDListA" _
(ByVal Pidl As Long, ByVal pszPath As String) As Long
Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal pvoid As Long)
'Desktop
Private Const CSIDL_INTERNET = &H1 'Internet Explorer (icon on desktop)
Private Const CSIDL_PROGRAMS = &H2 'Start Menu\Programs
Private Const CSIDL_CONTROLS = &H3 'My Computer\Control Panel
Private Const CSIDL_PRINTERS = &H4 'My Computer\Printers
Private Const CSIDL_PERSONAL = &H5 'My Documents
Private Const CSIDL_FAVORITES = &H6 '<user name>\Favorites
Private Const CSIDL_STARTUP = &H7 'Start Menu\Programs\Startup
Private Const CSIDL_RECENT = &H8 '<user name>\Recent
Private Const CSIDL_SENDTO = &H9 '<user name>\SendTo
Private Const CSIDL_BITBUCKET = &HA '<desktop>\Recycle Bin
Private Const CSIDL_STARTMENU = &HB '<user name>\Start Menu
Private Const CSIDL_DESKTOPDIRECTORY = &H10 '<user name>\Desktop
Private Const CSIDL_DRIVES = &H11 'My Computer
Private Const CSIDL_NETWORK = &H12 'Network Neighborhood
Private Const CSIDL_NETHOOD = &H13 '<user name>\nethood
Private Const CSIDL_FONTS = &H14 'Windows\fonts
Private Const CSIDL_TEMPLATES = &H15
Private Const CSIDL_COMMON_STARTMENU = &H16 'All Users\Start Menu
Private Const CSIDL_COMMON_PROGRAMS = &H17 'All Users\Programs
Private Const CSIDL_COMMON_STARTUP = &H18 'All Users\Startup
Private Const CSIDL_COMMON_DESKTOPDIRECTORY = &H19 'All Users\Desktop
Private Const CSIDL_APPDATA = &H1A '<user name>\Application Data
Private Const CSIDL_PRINTHOOD = &H1B '<user name>\PrintHood
Private Const CSIDL_LOCAL_APPDATA = &H1C '<user name>\Local Settings\Application Data (non roaming)
Private Const CSIDL_ALTSTARTUP = &H1D 'non localized startup
Private Const CSIDL_COMMON_ALTSTARTUP = &H1E 'non localized common startup
Private Const CSIDL_COMMON_FAVORITES = &H1F
Private Const CSIDL_INTERNET_CACHE = &H20
Private Const CSIDL_COOKIES = &H21
Private Const CSIDL_HISTORY = &H22
Private Const CSIDL_COMMON_APPDATA = &H23 'All Users\Application Data
Private Const CSIDL_WINDOWS = &H24 'Windows Directory
Private Const CSIDL_SYSTEM = &H25 'System Directory
Private Const CSIDL_PROGRAM_FILES = &H26 'C:\Program Files
Private Const CSIDL_MYPICTURES = &H27 'C:\Program Files\My Pictures
Private Const CSIDL_PROFILE = &H28 'USERPROFILE
Private Const CSIDL_SYSTEMX86 = &H29 'x86 system directory on RISC
Private Const CSIDL_PROGRAM_FILESX86 = &H2A 'x86 C:\Program Files on RISC
Private Const CSIDL_PROGRAM_FILES_COMMON = &H2B 'C:\Program Files\Common
Private Const CSIDL_PROGRAM_FILES_COMMONX86 = &H2C 'x86 Program Files\Common on RISC
Private Const CSIDL_COMMON_TEMPLATES = &H2D 'All Users\Templates
Private Const CSIDL_COMMON_DOCUMENTS = &H2E 'All Users\Documents
Private Const CSIDL_COMMON_ADMINTOOLS = &H2F 'All Users\Start Menu\Programs\Administrative Tools
Private Const CSIDL_ADMINTOOLS = &H30 '<user name>\Start Menu\Programs\Administrative Tools
Private Const CSIDL_CONNECTIONS = &H31 'Network and Dial-up Connections
Private Const MAX_PATH = 260
Private Const NOERROR = 0
'==========================================================================
'==========================================================================
'==========================================================================
'==========================================================================
'
' Code from xlShellAndWait module:
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' modShellAndWait
' By Chip Pearson, chip@cpearson.com, www.cpearson.com
' This page on the web site: www.cpearson.com/Excel/ShellAndWait.aspx
' 9-September-2008
'
' This module contains code for the ShellAndWait function that will Shell to a process
' and wait for that process to end before returning to the caller.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Declare Function WaitForSingleObject Lib "kernel32" ( _
ByVal hHandle As Long, _
ByVal dwMilliSeconds As Long) As Long
Private Declare Function OpenProcess Lib "kernel32.dll" ( _
ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" ( _
ByVal hObject As Long) As Long
Private Const SYNCHRONIZE = &H100000
Private Enum ShellAndWaitResult
Success = 0
Failure = 1
TimeOut = 2
InvalidParameter = 3
SysWaitAbandoned = 4
UserWaitAbandoned = 5
UserBreak = 6
End Enum
Private Enum ActionOnBreak
IgnoreBreak = 0
AbandonWait = 1
PromptUser = 2
End Enum
Private Const STATUS_ABANDONED_WAIT_0 As Long = &H80
Private Const STATUS_WAIT_0 As Long = &H0
Private Const WAIT_ABANDONED As Long = (STATUS_ABANDONED_WAIT_0 + 0)
Private Const WAIT_OBJECT_0 As Long = (STATUS_WAIT_0 + 0)
Private Const WAIT_TIMEOUT As Long = 258&
Private Const WAIT_FAILED As Long = &HFFFFFFFF
Private Const WAIT_INFINITE = -1&
'==========================================================================
'==========================================================================
'==========================================================================
'==========================================================================
Private Function SpecFolder(ByVal lngFolder As Long) As String
Dim lngPidlFound As Long
Dim lngFolderFound As Long
Dim lngPidl As Long
Dim strPath As String
strPath = Space(MAX_PATH)
lngPidlFound = SHGetSpecialFolderLocation(0, lngFolder, lngPidl)
If lngPidlFound = NOERROR Then
lngFolderFound = SHGetPathFromIDList(lngPidl, strPath)
If lngFolderFound Then
SpecFolder = Left$(strPath, _
InStr(1, strPath, vbNullChar) - 1)
End If
End If
CoTaskMemFree lngPidl
End Function
'==========================================================================
'==========================================================================
'==========================================================================
'==========================================================================
Private Function ShellAndWait(ShellCommand As String, _
TimeOutMs As Long, _
ShellWindowState As VbAppWinStyle, _
BreakKey As ActionOnBreak) As ShellAndWaitResult
'v1.01 2013-12-17 15:58 - late binding for non-Excel Application use
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ShellAndWait
'
' This function calls Shell and passes to it the command text in ShellCommand. The function
' then waits for TimeOutMs (in milliseconds) to expire.
'
' Parameters:
' ShellCommand
' is the command text to pass to the Shell function.
'
' TimeOutMs
' is the number of milliseconds to wait for the shell'd program to wait. If the
' shell'd program terminates before TimeOutMs has expired, the function returns
' ShellAndWaitResult.Success = 0. If TimeOutMs expires before the shell'd program
' terminates, the return value is ShellAndWaitResult.TimeOut = 2.
'
' ShellWindowState
' is an item in VbAppWinStyle specifying the window state for the shell'd program.
'
' BreakKey
' is an item in ActionOnBreak indicating how to handle the application's cancel key
' (Ctrl Break). If BreakKey is ActionOnBreak.AbandonWait and the user cancels, the
' wait is abandoned and the result is ShellAndWaitResult.UserWaitAbandoned = 5.
' If BreakKey is ActionOnBreak.IgnoreBreak, the cancel key is ignored. If
' BreakKey is ActionOnBreak.PromptUser, the user is given a ?Continue? message. If the
' user selects "do not continue", the function returns ShellAndWaitResult.UserBreak = 6.
' If the user selects "continue", the wait is continued.
'
' Return values:
' ShellAndWaitResult.Success = 0
' indicates the the process completed successfully.
' ShellAndWaitResult.Failure = 1
' indicates that the Wait operation failed due to a Windows error.
' ShellAndWaitResult.TimeOut = 2
' indicates that the TimeOutMs interval timed out the Wait.
' ShellAndWaitResult.InvalidParameter = 3
' indicates that an invalid value was passed to the procedure.
' ShellAndWaitResult.SysWaitAbandoned = 4
' indicates that the system abandoned the wait.
' ShellAndWaitResult.UserWaitAbandoned = 5
' indicates that the user abandoned the wait via the cancel key (Ctrl+Break).
' This happens only if BreakKey is set to ActionOnBreak.AbandonWait.
' ShellAndWaitResult.UserBreak = 6
' indicates that the user broke out of the wait after being prompted with
' a ?Continue message. This happens only if BreakKey is set to
' ActionOnBreak.PromptUser.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim TaskID As Long
Dim ProcHandle As Long
Dim WaitRes As Long
Dim Ms As Long
Dim MsgRes As VbMsgBoxResult
Dim SaveCancelKey As XlEnableCancelKey 'NB: only works in Excel
Dim ElapsedTime As Long
Dim Quit As Boolean
Const ERR_BREAK_KEY = 18
Const DEFAULT_POLL_INTERVAL = 500
Dim XLapp As Object 'v1.01
If InStr(Application.Name, "Excel") > 0 Then Set XLapp = Application Else Set XLapp = CreateObject("Excel.Application")
If Trim(ShellCommand) = vbNullString Then
ShellAndWait = ShellAndWaitResult.InvalidParameter
Exit Function
End If
If TimeOutMs < 0 Then
ShellAndWait = ShellAndWaitResult.InvalidParameter
Exit Function
ElseIf TimeOutMs = 0 Then
Ms = WAIT_INFINITE
Else
Ms = TimeOutMs
End If
Select Case BreakKey
Case AbandonWait, IgnoreBreak, PromptUser
' valid
Case Else
ShellAndWait = ShellAndWaitResult.InvalidParameter
Exit Function
End Select
Select Case ShellWindowState
Case vbHide, vbMaximizedFocus, vbMinimizedFocus, vbMinimizedNoFocus, vbNormalFocus, vbNormalNoFocus
' valid
Case Else
ShellAndWait = ShellAndWaitResult.InvalidParameter
Exit Function
End Select
On Error Resume Next
Err.Clear
TaskID = Shell(ShellCommand, ShellWindowState)
If (Err.Number <> 0) Or (TaskID = 0) Then
ShellAndWait = ShellAndWaitResult.Failure
Exit Function
End If
ProcHandle = OpenProcess(SYNCHRONIZE, False, TaskID)
If ProcHandle = 0 Then
ShellAndWait = ShellAndWaitResult.Failure
Exit Function
End If
On Error GoTo ErrH:
SaveCancelKey = XLapp.EnableCancelKey
XLapp.EnableCancelKey = xlErrorHandler
WaitRes = WaitForSingleObject(ProcHandle, DEFAULT_POLL_INTERVAL)
Do Until WaitRes = WAIT_OBJECT_0
DoEvents
Select Case WaitRes
Case WAIT_ABANDONED
' Windows abandoned the wait
ShellAndWait = ShellAndWaitResult.SysWaitAbandoned
Exit Do
Case WAIT_OBJECT_0
' Successful completion
ShellAndWait = ShellAndWaitResult.Success
Exit Do
Case WAIT_FAILED
' attach failed
ShellAndWait = ShellAndWaitResult.Success
Exit Do
Case WAIT_TIMEOUT
' Wait timed out. Here, this time out is on DEFAULT_POLL_INTERVAL.
' See if ElapsedTime is greater than the user specified wait
' time out. If we have exceed that, get out with a TimeOut status.
' Otherwise, reissue as wait and continue.
ElapsedTime = ElapsedTime + DEFAULT_POLL_INTERVAL
If Ms > 0 Then
' user specified timeout
If ElapsedTime > Ms Then
ShellAndWait = ShellAndWaitResult.TimeOut
Exit Do
Else
' user defined timeout has not expired.
End If
Else
' infinite wait -- do nothing
End If
' reissue the Wait on ProcHandle
WaitRes = WaitForSingleObject(ProcHandle, DEFAULT_POLL_INTERVAL)
Case Else
' unknown result, assume failure
ShellAndWait = ShellAndWaitResult.Failure
Quit = True
End Select
Loop
CloseHandle ProcHandle
XLapp.EnableCancelKey = SaveCancelKey
Exit Function
ErrH:
Debug.Print "ErrH: Cancel: " & XLapp.EnableCancelKey
If Err.Number = ERR_BREAK_KEY Then
If BreakKey = ActionOnBreak.AbandonWait Then
CloseHandle ProcHandle
ShellAndWait = ShellAndWaitResult.UserWaitAbandoned
XLapp.EnableCancelKey = SaveCancelKey
Set XLapp = Nothing
Exit Function
ElseIf BreakKey = ActionOnBreak.IgnoreBreak Then
Err.Clear
Resume
ElseIf BreakKey = ActionOnBreak.PromptUser Then
MsgRes = MsgBox("User Process Break." & vbCrLf & _
"Continue to wait?", vbYesNo)
If MsgRes = vbNo Then
CloseHandle ProcHandle
ShellAndWait = ShellAndWaitResult.UserBreak
XLapp.EnableCancelKey = SaveCancelKey
Else
Err.Clear
Resume Next
End If
Else
'Debug.Print "Unknown value of 'BreakKey': " & CStr(BreakKey)
CloseHandle ProcHandle
XLapp.EnableCancelKey = SaveCancelKey
ShellAndWait = ShellAndWaitResult.Failure
End If
Else
' some other error. assume failure
CloseHandle ProcHandle
ShellAndWait = ShellAndWaitResult.Failure
End If
XLapp.EnableCancelKey = SaveCancelKey
Set XLapp = Nothing
End Function
'==========================================================================
'==========================================================================
'==========================================================================
'==========================================================================
Function SP_Upload_from_2007(ByRef WBToUpload As Workbook, ByVal UploadPath As String _
, ByVal OutputFilename As String _
, Optional ByVal spPublishXLSM As Boolean = False _
, Optional ByVal spPublishXLSX As Boolean = False _
, Optional ByVal spPublishXLS As Boolean = False _
, Optional ByVal spUploadZipXLSM As Boolean = False _
, Optional ByVal spUploadZipXLSX As Boolean = False _
, Optional ByVal spUploadZipXLS As Boolean = False _
, Optional ByVal spUploadWorksheetAsCSV As Worksheet = Nothing _
, Optional ByVal AllowEvents As Boolean = False, Optional ByVal QuitWhenDone As Boolean = False _
, Optional ByVal AlsoCopyXLSToSharedPath As String = "" _
, Optional ByVal AlsoSaveCopyToSecondaryPath As String = "" _
, Optional ByVal AlsoBreakLinks As Boolean = True) _
As String
'v4.06 2013-09-23 10:28
'[uploads copies of XLSM file as XLSM, XLSX, XLS, unzipped]
'[uploads as XLSM, XLSX, XLS, zipped]
'[uploads as raw CSV, unzipped]
'[also copies XLS to specified path]
'[also saves copy to specified path]
'--> returns text error message if unsuccessful (good for message boxes)
'!! may not always publish versions correctly, need to wait until Upload Center
'!! has finished uploading before CheckIn/Out works OK?
'=================================================================================
' SEE END OF THIS MODULE FOR TYPICAL CODE FOR THISWORKBOOK MODULE
'=================================================================================
' xlSharePoint.SP_Upload_from_2007 WBToUpload:=ThisWorkbook _
' , UploadPath:=ipth _
' , OutputFilename:=ofn _
' , spPublishXLSM:=True _
' , spPublishXLSX:=True _
' , spPublishXLS:=True _
' , spUploadZipXLSM:=True _
' , spUploadZipXLSX:=True _
' , spUploadZipXLS:=True _
' , spUploadWorksheetAsCSV:=Nothing _
' , AllowEvents:=False, QuitWhenDone:=False _
' , AlsoCopyXLSToSharedPath:=xpth _
' , AlsoSaveCopyToSecondaryPath:=spth _
' , AlsoBreakLinks:=True
'=================================================================================
'validity check, must specify at least one output option
If spPublishXLSM = False _
And spPublishXLSX = False _
And spPublishXLS = False _
And spUploadZipXLSM = False _
And spUploadZipXLSX = False _
And spUploadZipXLS = False _
And spUploadWorksheetAsCSV Is Nothing _
Then GoTo ErrorHandlerNothingToDo
'convert UploadPath to UNC (URL doesn't work) and force connection
UploadPath = Replace(UploadPath, cFsl, cBsl)
UploadPath = Replace(UploadPath, cURL, "")
If Right(UploadPath, 1) <> cBsl Then UploadPath = UploadPath & cBsl
SP_Force_Connection UploadPath 'NB: this will close all open Explorer windows
If Val(Application.Version) < v7 Then
MsgBox "Error: only for use with Excel 2007/2010. Use SP_Upload_from_2003", vbCritical, "SP_Upload_from_2007" 'v4.05
Exit Function
End If
Dim blnAEE As Boolean
With Application
blnAEE = .EnableEvents
If QuitWhenDone = True Then
.StatusBar = "WARNING: HOLD SHIFT to prevent Excel application quitting when done"
.Wait Now() + TimeSerial(0, 0, 2)
If IsShiftKeyDown = True Then
QuitWhenDone = False
.StatusBar = "Will NOT quit when done"
Else
.StatusBar = "WARNING: Excel will Quit when done. Hold SHIFT to attempt to cancel Quit"
End If
End If
.DisplayAlerts = False
.EnableEvents = AllowEvents
End With
Dim pth As String, fn As String, wbTemp As Workbook, p As Byte
With WBToUpload
If QuitWhenDone = True Then If InStr(Application.Caption, "Read-Only") = 0 Then .Save 'this file in situ - will quit when done
'!! multiple "." in file name will cause unexpected behaviour here, maybe errors
p = InStr(OutputFilename, ".")
If p = 0 Then p = Len(OutputFilename) + 1
fn = Left(OutputFilename, p - 1) 'fn without file extension
If fn & xxlm = ThisWorkbook.Name Then
'safety net - workaround is to call master file "(master)"
MsgBox "OutputFilename (" & OutputFilename & xxlm & ") must differ from ThisWorkbook.Name (" & ThisWorkbook.Name & ")" & vbLf & vbLf & "Simple workaround is to include '(master)' in master file name", vbCritical, ""
End
End If
'save XLSM [and XLSX] [and XLS] files to temp folder (will be deleted later)
On Error GoTo ErrorHandlerTempFailed
'Shift+F8 over this line when reviewing
pth = SpecFolder(CSIDL_PERSONAL) & "\BPM Tools\" 'v3.00
If Dir(pth, vbDirectory) <> "." Then MkDir pth
pth = pth & "temp\"
If Dir(pth, vbDirectory) <> "." Then MkDir pth
Application.DisplayAlerts = False
.SaveCopyAs pth & fn & xxlm 'save XLSM copy to temp folder
If spPublishXLS = True Or spPublishXLSX = True Or spUploadZipXLS = True Or spUploadZipXLSX = True _
Or AlsoBreakLinks = True Then
Set spXLapp = modAppsOffice.XLlaunch
spXLapp.EnableEvents = AllowEvents
spXLapp.DisplayAlerts = False
On Error Resume Next
Set wbTemp = spXLapp.Workbooks.Open(pth & fn & xxlm)
If wbTemp Is Nothing Then
spXLapp.Workbooks.Open pth & fn & xxlm
On Error GoTo ErrorHandlerTempFailed
Set wbTemp = spXLapp.Workbooks(fn & xxlm)
End If
With wbTemp
'Break Links in XLSM first (converts formulas to values)
If AlsoBreakLinks = True Then
'code copied from xlUtils (v2.07)
Dim lnk As Variant, i As Integer
lnk = .LinkSources(xlLinkTypeExcelLinks)
On Error GoTo NothingToBreak
For i = 1 To UBound(lnk)
.BreakLink lnk(i), xlLinkTypeExcelLinks
Next i
spXLapp.EnableEvents = False 'prevents any macros running during this step
.Save
spXLapp.EnableEvents = AllowEvents
NothingToBreak:
On Error GoTo ErrorHandlerTempFailed
End If
'save XLSX copy to temp (keeps macros temporarily until closed)
If spPublishXLSX = True Or spUploadZipXLSX = True Then .SaveAs pth & fn & xxlx, FileFormat:=51
'save XLS copy to temp (with macros)
If spPublishXLS = True Or spUploadZipXLS = True Then .SaveAs pth & fn & x2k3 & xxls, FileFormat:=56
.Close False
End With
Set wbTemp = Nothing
spXLapp.Quit
Set spXLapp = Nothing
End If
On Error GoTo 0
'copy XLS to shared path 'v3.01
On Error GoTo ErrorHandlerXLSSharedPathCopyFailed
If AlsoCopyXLSToSharedPath <> "" Then
If Right(AlsoCopyXLSToSharedPath, 1) <> cBsl Then AlsoCopyXLSToSharedPath = AlsoCopyXLSToSharedPath & cBsl
FileCopy pth & fn & x2k3 & xxls, AlsoCopyXLSToSharedPath & fn & xxls 'NB: copied without " (2003)" in filename
End If
On Error GoTo 0
'upload (and CheckIn) XLSM to SharePoint
On Error GoTo ErrorHandlerXLSMFailed
If spPublishXLSM = True Then
FileCopy pth & fn & xxlm, UploadPath & fn & xxlm
SP_Open_and_CheckIn UploadPath & fn & xxlm
End If
On Error GoTo 0
'upload (and CheckIn) XLSX to SharePoint
On Error GoTo ErrorHandlerXLSXFailed
If spPublishXLSX = True Then
FileCopy pth & fn & xxlx, UploadPath & fn & xxlx
SP_Open_and_CheckIn UploadPath & fn & xxlx
End If
On Error GoTo 0
'upload (and CheckIn) XLS to SharePoint
On Error GoTo ErrorHandlerXLSFailed
If spPublishXLS = True Then
FileCopy pth & fn & x2k3 & xxls, UploadPath & fn & x2k3 & xxls
SP_Open_and_CheckIn UploadPath & fn & x2k3 & xxls
End If
On Error GoTo 0
'save zip[s] to SharePoint
If spUploadZipXLSM = True Then If Zip7Sub(pth & fn & xxlm, UploadPath & fn & xzip, True, True) <> 0 Then GoTo ErrorHandlerZipXLSMFailed
If spUploadZipXLSX = True Then If Zip7Sub(pth & fn & xxlx, UploadPath & fn & xzip, True, True) <> 0 Then GoTo ErrorHandlerZipXLSXFailed
If spUploadZipXLS = True Then If Zip7Sub(pth & fn & x2k3 & xxls, UploadPath & fn & x2k3 & xzip, True, True) <> 0 Then GoTo ErrorHandlerZipXLSFailed
'remove temp files & folder
'NB: only removes temp folder, leaves \\UserDocs\BPM Tools\ folder in place
If Dir(pth & fn & xxlm) <> "" Then Kill pth & fn & xxlm
If Dir(pth & fn & xxlx) <> "" Then Kill pth & fn & xxlx
If Dir(pth & fn & x2k3 & xxls) <> "" Then Kill pth & fn & x2k3 & xxls
If Dir(pth) = "" Then RmDir pth 'only if pth empty
'upload (and CheckIn) CSV to SharePoint (works for single sheet only)
On Error GoTo ErrorHandlerCSVFailed
If Not spUploadWorksheetAsCSV Is Nothing Then
Application.DisplayAlerts = False
spUploadWorksheetAsCSV.Copy
Set wbTemp = ActiveWorkbook
With wbTemp
.SaveAs UploadPath & fn & xcsv, FileFormat:=6
.Close False
End With
Set wbTemp = Nothing
SP_Open_and_CheckIn UploadPath & fn & xcsv
End If
On Error GoTo 0
'upload (and CheckIn?) copy to secondary location
On Error GoTo ErrorHandlerSaveCopyAsFailed
If AlsoSaveCopyToSecondaryPath <> "" Then
.SaveCopyAs AlsoSaveCopyToSecondaryPath & fn & xxlm
'force check in if location is SharePoint
If InStr(AlsoSaveCopyToSecondaryPath, SPdom) > 0 Then SP_Open_and_CheckIn AlsoSaveCopyToSecondaryPath & fn & xxlm
End If
On Error GoTo 0
End With 'WBToUpload
'clear error message if you got this far - no news is good news
SP_Upload_from_2007 = ""
With Application
.DisplayAlerts = True
.StatusBar = False
If QuitWhenDone = True And IsShiftKeyDown = False Then
Dim wb As Workbook, w As Byte 'v4.05
For Each wb In Workbooks
If UCase(wb.Name) <> "PERSONAL.XLSB" Then w = w + 1
Next wb
If w = 1 Then Application.Quit Else ThisWorkbook.Close False
End If
.EnableEvents = blnAEE
End With
Exit Function
ErrorHandler:
SP_Upload_from_2007 = "SP_Upload_from_2007: failed" '!! very blunt
GoTo CleanUp
ErrorHandlerNothingToDo:
SP_Upload_from_2007 = "SP_Upload_from_2007: nothing to do! Must specify at least one output option"
GoTo CleanUp
ErrorHandlerTempFailed:
SP_Upload_from_2007 = "SP_Upload_from_2007: couldn't save to temp folder"
GoTo CleanUp
ErrorHandlerSaveCopyAsFailed:
SP_Upload_from_2007 = "SP_Upload_from_2007: SaveCopyAs failed"
GoTo CleanUp
ErrorHandlerCSVFailed:
SP_Upload_from_2007 = "SP_Upload_from_2007: CSV failed"
GoTo CleanUp
ErrorHandlerXLSFailed:
SP_Upload_from_2007 = "SP_Upload_from_2007: XLS failed"
GoTo CleanUp
ErrorHandlerXLSXFailed:
SP_Upload_from_2007 = "SP_Upload_from_2007: XLSX failed"
GoTo CleanUp
ErrorHandlerXLSMFailed:
SP_Upload_from_2007 = "SP_Upload_from_2007: XLSM failed"
GoTo CleanUp
ErrorHandlerZipXLSFailed:
SP_Upload_from_2007 = "SP_Upload_from_2007: zipped XLS failed"
GoTo CleanUp
ErrorHandlerZipXLSXFailed:
SP_Upload_from_2007 = "SP_Upload_from_2007: zipped XLSX failed"
GoTo CleanUp
ErrorHandlerZipXLSMFailed:
SP_Upload_from_2007 = "SP_Upload_from_2007: zipped XLSM failed"
GoTo CleanUp
ErrorHandlerXLSSharedPathCopyFailed:
SP_Upload_from_2007 = "SP_Upload_from_2007: XLS copy to shared drive path failed"
GoTo CleanUp
CleanUp:
If Not wbTemp Is Nothing Then wbTemp.Close False
If Not spXLapp Is Nothing Then spXLapp.Quit
End Function
Function SP_Upload_from_2003(ByVal spulPath As String, ByVal spulFileName As String _
, Optional spulSheetName As String) As Boolean
'v2.04 2013-07-25 08:59
'WARNING: if SharePoint is set to require CheckOut, this will NOT publish the file
'only works with UNC (can be converted to use URL)
'spulSheetName<>"" will copy that sheet to new WB and upload
'spulSheetName="" will hide "admin" sheet and upload entire workbook
With Application
If Val(.Version) >= v7 Then
MsgBox "Error: only for use with Excel 2003. Use SP_Upload_XLS_and_XLSM", vbCritical, "SP_Upload_XLS_and_XLSM"
Exit Function
End If
.DisplayAlerts = False
End With
Dim wb As Workbook, i As Integer, ipthfn As String, lnk As Variant
ipthfn = cBsl & Replace(spulPath & cBsl, cBsl & cBsl, cBsl) & spulFileName
With ThisWorkbook
On Error Resume Next
.Sheets(spulSheetName).Copy 'creates new WB only if spulSheetName specified
On Error GoTo 0
End With
Set wb = ActiveWorkbook 'either ThisWorkbook or single-sheet file
With wb
If wb.Name = ThisWorkbook.Name And spulSheetName <> "" Then
MsgBox spulSheetName & " did not copy to new WB.", vbCritical, "error in SP_UPload"
End
ElseIf spulSheetName <> "" Then
'break links in new one-sheet file
On Error Resume Next
Set lnk = wb.LinkSources(xlLinkTypeExcelLinks)
For i = 1 To UBound(lnk)
wb.BreakLink lnk(i), xlLinkTypeExcelLinks
Next i
'save WB to SharePoint
On Error GoTo SaveFailed
.SaveCopyAs ipthfn 'will overwrite existing
On Error GoTo 0
'now close extra WB, not required
.Close False
'save copy of Master to SharePoint (i.e. alongside single sheet report)
With ThisWorkbook
On Error Resume Next
.Sheets(wsA).Visible = False
On Error GoTo SaveFailed
'overwrite existing, this works for xxls and xxlm (xxlm = xxls & "m")
'!! doesn't work for .xlb
.SaveCopyAs Replace(ipthfn, xxls, " (master)" & xxls)
On Error Resume Next
.Sheets(wsA).Visible = True
On Error GoTo 0
End With
Else
'save copy of Master to SharePoint as WB
With ThisWorkbook 'WB is ThisWorkbook
On Error Resume Next
.Sheets(wsA).Visible = False
On Error GoTo SaveFailed
.SaveCopyAs ipthfn 'will overwrite existing
On Error Resume Next
.Sheets(wsA).Visible = True
On Error GoTo 0
End With
End If
End With
SP_Upload_from_2003 = True
Exit Function
SaveFailed:
SP_Upload_from_2003 = False
If InStr(Application.Name, "Excel") > 0 Then Application.StatusBar = "ERROR in SP_Upload_from_2003: save failed"
End 'leaves this workbook AND unsaved report open in Excel (theoretically)
End Function
Function SP_Open_and_CheckIn(ByVal PathAndFileName As String, Optional ByVal AllowEvents As Boolean = False) As Byte
'**** BETA VERSION ****
'v4.07b 2013-09-26 16:00
'forces CheckIn
'!! untested with folders that force CheckOut
'ErrorCodes as Byte:
' 0 = no need to CheckIn / successfully CheckedIn
' 1 = couldn't Open
' 2 = couldn't CheckOut
' 3 = couldn't CheckIn
' 8 = pathfile doesn't exist / pathfile access error
PathAndFileName = Replace(PathAndFileName, "/", "\")
PathAndFileName = Replace(PathAndFileName, "http:", "")
'try to CheckOut file and then CheckInWithVersion
Application.DisplayAlerts = False
Set spXLapp = modAppsOffice.XLlaunch '(True, False)
With spXLapp
'.DisplayAlerts = False 'bypasses any warnings, not advisable for testing
.EnableEvents = AllowEvents
If Dir(PathAndFileName) = "" Then
SP_Open_and_CheckIn = 8 'file not found
Else
If .Workbooks.CanCheckOut(PathAndFileName) = True Then GoTo FinishOff 'SP_Open_and_CheckIn = 0
'[CheckOut then] CheckInWithVersion
'!! untested, try to just CheckInWithVersion first
If .Workbooks(PathAndFileName).CanCheckIn = True Then .Workbooks(PathAndFileName).CheckInWithVersion False, "Published " & Now(), True
On Error GoTo OpenFailed
.Workbooks.Open FileName:=PathAndFileName
On Error GoTo 0
On Error GoTo CheckOutFailed
.Workbooks.CheckOut PathAndFileName
On Error GoTo 0
On Error GoTo CheckInFailed
.Workbooks(PathAndFileName).CheckInWithVersion False, "Published " & Now(), True
On Error GoTo 0
End If
End With
'implied success!
GoTo FinishOff
OpenFailed:
SP_Open_and_CheckIn = 1
GoTo FinishOff
CheckOutFailed:
SP_Open_and_CheckIn = 2
GoTo FinishOff
CheckInFailed:
SP_Open_and_CheckIn = 3
GoTo FinishOff
FinishOff:
spXLapp.Quit
Set spXLapp = Nothing
End Function
Function SPsetsl() As String
'v1.05 2013-03-04 16:04
If Left(fn_SPpth, 5) = cURL Then SPsetsl = cFsl Else SPsetsl = cBsl
End Function
Function SP_Check_Special(ByVal str As String) As Boolean
'v2.05 2013-07-25 18:57
'checks string for invalid special characters (True=valid or False=invalid)
'~ " # % & * < > ? { | } .. \ or : and /
SP_Check_Special = True 'unless it fails
Const p As String = "."
If Right(str, 1) = p Then SP_Check_Special = False
Const bmax As Byte = 14
Dim sc() As String
ReDim sc(bmax) As String
sc(0) = "~"
sc(1) = Chr(34) ' Chr(34) = "
sc(2) = "#"
sc(3) = "%"
sc(4) = "&"
sc(5) = "*"
sc(6) = ".."
sc(7) = "<"
sc(8) = ">"
sc(9) = "?"
sc(10) = "{"
sc(11) = "|"
sc(12) = "}"
If SPsetsl = cFsl Then
sc(bmax - 1) = ""
sc(bmax) = cBsl
Else:
sc(bmax - 1) = ":"
sc(bmax) = cFsl
End If
'sc(15) = cbsl 'disabled to allow checking of pth names
Dim b As Byte
For b = 0 To bmax
If sc(b) <> "" And InStr(str, sc(b)) > 0 Then SP_Check_Special = False
Next b
End Function
Function fn_SPpth(Optional ByVal TestURLPath As String) As String
'v1.15 2013-05-22 11:18
'determines SPpth (set top of module) as either UNC or URL for this user
'URL uploads won't work if UNC is working
'use this function instead of SPpth in code
'test with Left,1 = cBsl
'also forces SharePoint connection (refresh user and password)
If TestURLPath = "" Then TestURLPath = SPpth
'Const cPrd As String = "."
Dim v As String
'test for UNC first, more reliable
fn_SPpth = Replace(Replace(TestURLPath, cURL, ""), cFsl, cBsl)
On Error Resume Next
v = Dir(fn_SPpth, vbDirectory)
On Error GoTo 0
If v = cPrd Then
'UNC works, use UNC for SPpth (already set)
'fn_SPpth = Replace(Replace(SPpth, cURL, ""), cFsl, cBsl)
Else
'UNC doesn't work, must use URL for SPpth (change it back)
fn_SPpth = TestURLPath
End If
End Function
Function SPDelFile(ByVal pthfn_to_delete As String) As Boolean
'v2.00 2013-07-10 13:01
'deletes file
'UNC reports True if deleted, False if not
'URL always reports True even if delete failed
Dim isUNC As Boolean
Bludgeon:
'try to force deletion by all available methods
On Error Resume Next
Select Case xlSharePoint.SPsetsl 'v2.00
Case cBsl 'UNC - just delete it
isUNC = True
Kill Replace(Replace(pthfn_to_delete, cURL, ""), cFsl, cBsl)
Case cFsl 'URL - force deletion via URL and UNC
isUNC = False
Kill pthfn_to_delete
Kill Replace(Replace(pthfn_to_delete, cURL, ""), cFsl, cBsl)
End Select
On Error GoTo 0
'check UNC address for deletion
If isUNC = True Then
'UNC - check file exists
If Dir(pthfn_to_delete) = "" Then
'success!
SPDelFile = True
Else
'failure!
SPDelFile = False
End If
Else
'if URL - always assume successful delete and pray it worked
SPDelFile = True
End If
End Function
Function SP_pth_sl(ByVal PathToAddSlash As String, Optional DoURL As Boolean) As String
'v3.00b 2013-07-29 22:40
'adds a slash to end of path as required
'DoURL tries to force URL but will be overridden if URL is 'detected'
'commented v1.15, consts are set public
'Const cFsl As String = "/" 'URL
'Const cBsl As String = "\" 'UNC
'Const cURL As String = "http://"
'!! can only specify URL if DoURL=True
If DoURL = True And Left(PathToAddSlash, Len(cURL)) <> cURL Then _
MsgBox "a URL must be specified if DoURL=True", vbCritical, "error in zSP_pth_sl"
'if Path includes http then force DoURL (NB: fn_SPpth will determine UNC or URL)
If DoURL = False And Left(PathToAddSlash, Len(cURL)) = cURL Then _
DoURL = True
If DoURL = True And Right(PathToAddSlash, 1) <> cFsl Then
SP_pth_sl = PathToAddSlash & cFsl
Exit Function
ElseIf Right(PathToAddSlash, 1) <> cBsl Then
SP_pth_sl = PathToAddSlash & cBsl
Exit Function
Else
SP_pth_sl = PathToAddSlash
End If
End Function
Function SP_fn_val(sFileName As String, Optional sReplaceInvalidWith As String = "_") As String
'v3.00b 2013-07-29 22:40
'Purpose : Removes invalid characters from a filename
'Inputs : sFileName The file name to clean the invalid characters from.
' [sReplaceInvalidWith] The text to replace any invalid characters with.
'Outputs : Returns a valid filename.
'Author : Andrew Baker
'Date : 25/03/2001
'Notes : http://www.vbusers.com/code/codeget.asp?ThreadID=578&PostID=1
Const csInvalidChars As String = ":\/?*<>|"""
Dim lThisChar As Long
SP_fn_val = sFileName
'Loop over each invalid character, removing any instances found
For lThisChar = 1 To Len(csInvalidChars)
SP_fn_val = Replace$(SP_fn_val, Mid(csInvalidChars, lThisChar, 1), sReplaceInvalidWith)
Next
End Function
Function v_MM() As String
'v1.00 2012-11-29 14:37
'converts to 2 digit month
v_MM = Month(Now())
If Len(v_MM) = 1 Then v_MM = "0" & v_MM
End Function
Function v_DD() As String
'v1.00 2012-11-29 14:37
'converts to 2 digit date
v_DD = Day(Now())
If Len(v_DD) = 1 Then v_DD = "0" & v_DD
End Function
Function SPUseCheckOut(docCheckOut As String, Optional TestFirst As Boolean _
, Optional ForceUNC As Boolean) As Workbook
'v2.00 2013-07-10 13:01
'Source:
'http://social.msdn.microsoft.com/Forums/hu-HU/isvvba/thread/25609303-dc29-4cf4-a526-977bf6129e78
'Sub test_SPUseCheckOut()
'Dim wb As Workbook
'Workbooks.Open src
'Set wb = ActiveWorkbook
'Dim docCheckOut As String
'docCheckOut = wb.FullName
'Call xlSharePoint.SPUseCheckOut(docCheckOut)
' **********************
' * now work with file *
' * when finished: *
' **********************
'wb.CheckInWithVersion True 'also closes wb
'End Sub
Dim wb As Workbook
Dim UPathName As String, UCheckOut As String
For Each wb In Workbooks
If ForceUNC = True Then
'represent both paths as UNC address
UPathName = UCase(Replace(Replace(wb.Name, cURL, ""), cFsl, cBsl))
UCheckOut = UCase(Replace(Replace(wb.Name, cURL, ""), cFsl, cBsl))
Else
'represent both paths as URL address
UPathName = UCase(Replace(Replace(wb.Name, cBsl & cBsl, cURL & cFsl & cFsl), cBsl, cFsl))
UCheckOut = UCase(Replace(Replace(wb.Name, cBsl & cBsl, cURL & cFsl & cFsl), cBsl, cFsl))
End If
If UPathName = UCheckOut Then
'already open
'determine if workbook can be checked in
'only works if already Checked Out to you
If wb.CanCheckIn = True Then wb.CheckInWithVersion True 'close & save then reopen later
Exit For
End If
Next wb
If TestFirst = True Then
' Determine if workbook can be checked out first
If Workbooks.CanCheckOut(docCheckOut) = True Then
Workbooks.CheckOut docCheckOut
Set SPUseCheckOut = Workbooks(docCheckOut)
Else
'MsgBox "Unable to check out " & docCheckOut & " at this time."
End If
Else
' just try to check it out anyway
Application.Wait Now() + TimeSerial(0, 0, 2) 'prevents time delay errors after uploading / CheckIn
Workbooks.CheckOut docCheckOut
Set SPUseCheckOut = Workbooks(docCheckOut)
End If
End Function
Sub SP_OfferToCheckInAllWorkbooks()
'v5.02 2013-12-18 10:24 - added underscore to macro name
'v1.15 2013-05-22 11:23
'check if ThisWorkbook opened from SharePoint then offer to close all
Dim pp As String, tt As String
'check if ThisWorkbook opened from SharePoint
tt = ThisWorkbook.FullName
If InStr(tt, SPdom) > 0 Then
'offer to close all
tt = ThisWorkbook.Name
pp = "Yes to close, save and CheckIn THIS workbook only," & vbLf _
& "No to close, save and CheckIn ALL open workbooks (use with caution)"
If MsgBox(pp, vbExclamation Or vbYesNo, tt) = vbNo Then
Dim wb As Workbook
For Each wb In Workbooks
On Error Resume Next
If wb.Name <> tt Then
wb.CheckIn
wb.Close True
End If
On Error GoTo 0
Next wb
End If
End If
End Sub
Function SP_Force_Connection(Optional ByVal UNCPathAndOrFilename As String = "defaultUNCpath") As Boolean
'v5.05 2014-01-10 14:27 - bugfix for zips (remove "" from ends)
'v5.03 2014-01-08 10:24 - now accepts filenames at end of path
'v5.02 2013-12-18 10:28 - added option for default UNCpath
'v5.00 2013-12-02 16:17
'!! NB: not totally suitable for end user processes, may close ALL instances of Explorer (file browser)
' 1. launches UNC in Explorer window
' 2. tries to close Explorer window
' 3. if 2 unsuccessful, kills all open instances of Explorer then relaunches Taskbar (!! messy)
If UNCPathAndOrFilename = "defaultUNCpath" Then UNCPathAndOrFilename = fn_SPpth(SPpth)
'v5.03 remove file name from UNCpath and extract last folder name for Windows Explorer title bar
Dim p As String, f As String, b As Integer, s() As Integer, c As Byte
p = Replace(UNCPathAndOrFilename, Chr(34), "")
b = InStr(p, "\")
While b > 0
c = c + 1 'count slashes
ReDim Preserve s(1 To c) As Integer 'add another slash character count
s(c) = b
b = InStr(s(c) + 1, p, "\")
Wend
If c > 0 Then
p = Left(p, s(c)) 'full 'root' path without last filename (or folder name) so "C:\Folder\Filename.txt" > "C:\Folder\"
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:\"
End If
SP_Force_Connection = True
'easy option first, see if UNC already connected
On Error Resume Next
Dim testfn As String
testfn = Dir(p, vbDirectory)
If testfn = "." Then Exit Function
On Error GoTo 0
'open UNC in Explorer, try to close specific Explorer window
ShellAndWait "explorer " & p, 10000, vbHide, AbandonWait
If SP_CloseExplorerWindow(f) = False Then 'v5.00
'use brute force, close all Explorer windows, reopen Taskbar
ShellAndWait "TaskKill /F /IM ""explorer.exe""", 1000, vbHide, AbandonWait
Shell "C:\Windows\explorer.exe"
End If
'test UNC connection
On Error Resume Next
testfn = Dir(p, vbDirectory)
If testfn <> "." Then SP_Force_Connection = False
On Error GoTo 0
End Function
Function SP_CloseExplorerWindow(ByVal sCurrentFolderName As String) As Boolean
'v5.05 2014-01-10 14:27 - bugfix
'v5.04 2014-01-09 17:11 - bugfix
'v5.00 2013-12-02 16:12
'Function returns "True" if successful, otherwise "False"
'Amended from Source:
' http://gallery.technet.microsoft.com/scriptcenter/3879dd1b-09a1-4a9f-95ca-529351a7e2ac
If sCurrentFolderName = "" Then Exit Function
Dim bTest, wndw
bTest = False
With CreateObject("shell.application")
For Each wndw In .Windows
If wndw.Document.Folder = sCurrentFolderName Then
On Error Resume Next
wndw.Quit
bTest = Err.Number = 0
On Error GoTo 0
End If
Next
End With ' shell.application
SP_CloseExplorerWindow = CStr(bTest)
End Function
'=================================================================================
' TYPICAL CODE FOR THISWORKBOOK MODULE:
'=================================================================================
'Option Explicit
'
'Private Const MasterUserID As String = "bpmgb" 'admin user ID, all other userIDs won't process
''Private Const MasterUserIDList As String = "Sales Admin" 'admin user list
'Private Const MasterIdent As String = " (master)" 'identifier that this is the master file, not a published file
'Private Const ipth As String = "\\ishare.dhl.com\sites\DGFUK\GBOFR\OFR Management\" 'SharePoint location
'Private Const xpth As String = "" 'XLS to shared drive, set "" if not required
'Private Const spth As String = "\\ishare.dhl.com\sites\DGFUK\Sales\TLM\Logis Reports\" 'SaveCopyAs to secondary location, set "" if not required
'Private Const ofn As String = "(Logis Ocean) LCL Customers by Trade Lane" 'output filename must not include MasterIdent
'Private Const cVBAfilename As String = "VBA UPDATE WEEKLY REPORTS.XLSM" 'this wb open means automatic updates in process
'Private bStopLoop As Boolean
'Public bAutoVBA As Boolean
'
'Private Sub Workbook_BeforeClose(Cancel As Boolean)
'
'If bStopLoop = True Then Exit Sub
'If InStr(ThisWorkbook.Name, MasterIdent) = 0 Then Exit Sub
'
''choose one
'If CU_userID(MasterUserID) = False Then Exit Sub
''If CU_Controlled(MasterUserIDList) = False Then Exit Sub
'
'bStopLoop = True
'
'bAutoVBA = chkAutoVBA
'
'Dim tt As String, pp As String, mbxr As VbMsgBoxResult
'tt = "doPublish"
'pp = "Save and publish files to SharePoint?"
'If bAutoVBA Then mbxr = vbYes Else mbxr = MsgBox(pp, vbYesNo Or vbQuestion, tt)
'If mbxr = vbYes Then
' Application.StatusBar = "Publishing files to SharePoint..."
' tt = "doPublish failed"
' pp = doPublish(True) 'this will save then quit when done
' If bAutoVBA = False And pp <> "" Then MsgBox pp, vbCritical, tt
' Application.StatusBar = False
'Else
' pp = "Just save?"
' If bAutoVBA Then mbxr = vbYes Else mbxr = MsgBox(pp, vbYesNo, "")
' If mbxr = vbYes Then ThisWorkbook.Save
' Dim wb As Workbook, w As Byte
' For Each wb In Workbooks
' If UCase(wb.Name) <> "PERSONAL.XLSB" Then w = w + 1
' Next wb
' If w = 1 Then Application.Quit Else ThisWorkbook.Close False
'End If
'
'End Sub
'
'Private Function chkAutoVBA() As Boolean
'
'Dim wb As Workbook
'If InStr(Application.Caption, "Read-Only") > 0 Then
' chkAutoVBA = True
'Else
' For Each wb In Workbooks
' If UCase(wb.Name) = UCase(cVBAfilename) Then
' chkAutoVBA = True
' Exit Function
' End If
' Next wb
'End If
'
'End Function
'
'Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'
'If bStopLoop = True Then Exit Sub
'If InStr(ThisWorkbook.Name, MasterIdent) = 0 Then Exit Sub
'
''choose one
'If CU_userID(MasterUserID) = False Then Exit Sub
''If CU_Controlled(MasterUserIDList) = False Then Exit Sub
'
'bAutoVBA = chkAutoVBA
'
'bStopLoop = True
'
'Dim tt As String, pp As String, mbxr As VbMsgBoxResult
'tt = "doPublish"
'pp = "Save and publish files to SharePoint?"
'If bAutoVBA Then mbxr = vbYes Else mbxr = MsgBox(pp, vbYesNo Or vbQuestion, tt)
'If mbxr = vbYes Then
'Application.StatusBar = "Publishing files to SharePoint..."
' tt = "doPublish failed"
' pp = doPublish(False)
' If pp <> "" And bAutoVBA = False Then MsgBox pp, vbCritical, tt
'Application.StatusBar = False
'End If
'
'bStopLoop = False
'
'End Sub
'
'Function doPublish(ByVal QuitWhenDone As Boolean) As String
'
''choose one
'If CU_userID(MasterUserID) = False Then Exit Function
''If CU_Controlled(MasterUserIDList) = False Then Exit Function
'
''If ThisWorkbook.Sheets.Count > 1 Then xlUtils.xlU_Export_Single_Sheets xpth, False, True, True
'
''NB: outputs are optional, but must specify at least one
'doPublish = xlSharePoint.SP_Upload_from_2007(WBToUpload:=ThisWorkbook _
' , UploadPath:=ipth _
' , OutputFilename:=ofn _
' , spUploadZipXLSM:=True _
' , AllowEvents:=False, QuitWhenDone:=QuitWhenDone _
' , AlsoCopyXLSToSharedPath:=xpth _
' , AlsoSaveCopyToSecondaryPath:=spth _
' , AlsoBreakLinks:=True)
'
'End Function
'
'Private Sub Workbook_Open()
'
'If CU_userID(MasterUserID) = False Then Exit Sub
'
'bAutoVBA = chkAutoVBA
'
''run invisible to fully automate
'If Application.Visible = False Then
' Application.Visible = True
' ThisWorkbook.RefreshAll
' bStopLoop = True
' ThisWorkbook.Save
' doPublish True
'End If
'
'End Sub
No comments:
Post a Comment