Q:\Folder1\Project Register\RptAnalysis - CurrentWorkingFile.xlsm, password, WRPW
'Providing a password assumes that you want to open a workbook
'PWType = "PW" then Normal password to open
'PWType = "WRPW then WriteResPassword; WriteReserved = Read Only until Password is entered
'Parms = command line parameters passed through shell
' /r = open in Read Only
' /e = Prevents startup screen and new workbook
' /s = Safe Mode
' /x = Starts Excel in new thread
'PathFile can be url; any string with 'http'
'PathFile can be a folder; cannot contain file extension
'PathFile can be a non Excel file; Word, PDF ...
Sub OpenPathFile(PathFile As String, Optional PW As String, Optional PWType As String, Optional Parms As String)
Dim PF As Variant
Dim WBBool As Boolean
Dim Ext As String
Dim WB As Workbook
Dim LastPeriod As Long
Dim Q As String
Dim aStr As String
If PathFile = "" Then Exit Sub
LastPeriod = InStrRev(PathFile, ".")
If LastPeriod > 0 Then Ext = Mid(PathFile, LastPeriod, 100)
Application.StatusBar = "Opening: " & PathFile
DoEvents
On Error Resume Next
If PW <> "" Or Ext = ".xlsm" Or Ext = ".xlsx" Or Ext = ".xls" Or Ext = ".xlsb" Then 'Excel Workbook
If PW <> "" Then
Select Case UCase(PWType)
Case "PW"
Set WB = Workbooks.Open(PathFile, UpdateLinks:=True, Password:=PW)
Case "WRPW"
Set WB = Workbooks.Open(PathFile, UpdateLinks:=True, WriteResPassword:=PW)
End Select
ElseIf Parms = "" Then
Set WB = Workbooks.Open(PathFile)
ElseIf Parms <> "" Then 'Parms like /x /e /s cannot be used with passwords
Q = Chr(34)
aStr = " " & Q & PathFile & Q & " " & Parms
Application.DisplayAlerts = False
Call Shell("Excel.exe" & aStr, vbNormalFocus)
End If
'URL
ElseIf InStr(PathFile, "http") Then
ThisWorkbook.FollowHyperlink PathFile
'Non Excel File
ElseIf InStr(PathFile, ":") And Len(PathFile) - InStrRev(PathFile, ".") < 6 Then
PF = PathFile & vbNullString
CreateObject("Shell.Application").Open PF
'Normal Folder or network server folder; no file extension
ElseIf (InStr(PathFile, ":\") Or InStr(PathFile, "\\")) And Len(PathFile) - InStrRev(PathFile, ".") > 5 Then
Call Shell("Explorer.exe" & " " & PathFile, vbNormalFocus)
End If
On Error GoTo 0
Application.OnTime Now + TimeValue("00:00:03"), "TimerEnd", Schedule:=True
End Sub
Sub TimerEnd()
Application.StatusBar = False
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim i As Range
Dim R As Range
Dim Cel As Range
Dim HyperlinkStr As String
Dim Path As String
Dim FileName As String
Dim Pars As Variant
Dim PCnt As Long
Dim PW As String
Dim PWT As String
Dim Parms As String
Set R = Range("ChckLst_Tbl[Hyperlink]")
Set i = Intersect(R, Target)
If Not i Is Nothing Then 'Hyperlink column
HyperlinkStr = i.Value
If HyperlinkStr <> "" Then
Cancel = True
Pars = Split(HyperlinkStr, ",")
On Error Resume Next
HyperlinkStr = Trim(Pars(0))
PW = Trim(Pars(1))
PWT = Trim(Pars(2))
Parms = Trim(Pars(3))
On Error GoTo 0
OpenPathFile HyperlinkStr, PW, PWT, Parms
End If
End If
End Sub