OfficeReadOnlyOpen.vbs - office read only open written by vb script. for microsoft excel, microsoft powerpoint, microsoft word.

WHAT IS THIS?
office read only open written by vb script. for microsoft excel, microsoft powerpoint, microsoft word.

HOW TO USE?
copy this file to "SendTo" folder, etc.
ex: C:\Users\<YourAccount>\AppData\Roaming\Microsoft\Windows\SendTo


'--------------------------------
Rem
Rem OfficeReadOnlyOpen.vbs
Rem


'--------------------------------
'----------------
'Check Argument
'----------------
'Check argument.
If WScript.Arguments.Count <> 1 Then WScript.Quit

'Get file name.
Dim strFileName
strFileName = WScript.Arguments(0)


'----------------
'Check Extension
'----------------
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")

Dim extName
extName = fso.GetExtensionName(strFileName)

Dim strRegularFileName
If extName <> "lnk" Then
    strRegularFileName = strFileName
Else
    'Get Shortcut TargetPath.
    If Not fso.FileExists(strFileName) Then
        strRegularFileName = strFileName
    Else
        Dim oWshShell
        Set oWshShell = CreateObject("WScript.Shell")
     
        Dim oShellLink
        Set oShellLink = oWshShell.CreateShortcut(strFileName)
     
        strRegularFileName = oShellLink.TargetPath
     
        extName = fso.GetExtensionName(strRegularFileName)
    End If
End If


'----------------
'Execute
'----------------
Dim objOfficeApp
If extName = "ppt" Or extName = "pptx" Then

    Set objOfficeApp = GetOrCreateObject("Powerpoint.Application")
    objOfficeApp.Visible = True
    'Open As ReadOnly.
    Call objOfficeApp.Presentations.Open(strRegularFileName, True)
 
ElseIf extName = "doc" Or extName = "docx" Then
 
    Set objOfficeApp = GetOrCreateObject("Word.Application")
    objOfficeApp.Visible = True
    'Open As ReadOnly.
    Call objOfficeApp.Documents.Open(strRegularFileName, , True)
 
ElseIf extName = "xls" Or extName = "xlsx" Or extName = "xlsm" Or extName = "xlsb" Then

    Set objOfficeApp = GetOrCreateObject("Excel.Application")
    objOfficeApp.Visible = True
    'Open As ReadOnly.
    Call objOfficeApp.Workbooks.Open(strRegularFileName, , True)
 
End If


'----------------
'Ending
'----------------
Set objOfficeApp = Nothing
WScript.Quit



'--------------------------------
Function GetOrCreateObject(ClassName)
    Dim objOfficeApp
    Dim isGetObjectError
 
    '----------------
    ' VBScript version GetObject(, class): return Existing instance. but occur ERROR if no instance is.
    ' WScript.GetObject(ProgID)          : return always NEW instance.
 
    '----------------
    'Get Existing application instance.
    On Error Resume Next
    Set objOfficeApp = GetObject(, ClassName)
    If Err.Number <> 0 Then
        isGetObjectError = True
    ElseIf objOfficeApp Is Nothing Then
        isGetObjectError = True
    End If
    On Error GoTo 0
 
    '----------------
    'Get New application instance.
    If isGetObjectError Then
        Set objOfficeApp = CreateObject(ClassName)
    End If
 
    '----------------
    'return instance.
    Set GetOrCreateObject = objOfficeApp
End Function
'--------------------------------