Solved: default program for a file type

[philfer]

Hello,

Is it possible in VBA to examine the registry and determine the default program for a file type and then get VBA to start that program for you

Thanks
Phil

[Bob Phillips]

Surely, if you just Shell a file, it will start with its default?

[philfer]

Hi,

Thanks for your reply.

I tried this :-

Sub trial()


Dim retval
retval = Shell("C:\Documents and Settings\ADMIN\MyDocumentsstmnt.doc", vbNormalFocus)


End Sub


And it didnt work. Is this what you meant?

Thanks
Phil

[GTO]

"You can tune-a-piano, but you can't tuna fish", or was it the other way around?

Anyways, I'll be happy to be proven wrong, but AFAIK, you can shell an executable, but you can't shell a file... or at least Shell seems to require knowing the app. After that, I thought that the app would need to have a switch that could be used.

Anyways, using a .doc example, you might be able to get Shell to open the file in Explorer, something like:
Sub Exa1()
Dim strFName As String

strFName = ThisWorkbook.Path & "\Junk.doc"
VBA.Shell "Explorer.exe , """ & strFName & """", vbNormalFocus
End Sub

That said and assuming your example code is just that, and its not actually a word doc, have you tried ShellExecute?

Option Explicit

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, _
ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Sub CallIt()
MsgBox RetVal(ThisWorkbook.Path & "\Junk.doc")
End Sub

Function RetVal(FPath As String) As Long
RetVal = ShellExecute(0, "Open", FPath, vbNullString, vbNullString, vbNormalFocus)
End Function


For whatever reason, I have a harder time finding stuff at msdn than in the older design (no doubt my thick head) but I was able to find this descript...

http://support.microsoft.com/kb/238245

In closing, cat-killin' curiousity is getting the best of me. The files you are looking to open are not .docs, right?

Hope this helps,

Mark

PS - please note that ShellExecute doesn't return a task ID, but the instance handle. The msgbox was just an example to show that it returns something...

[Paul_Hossler]

This seems to work, at least for the test cases I tried, under Vista SP2 and Offile 2007

Takes a file name, reads the registry a couple of times to finally get the Open key for that extension, constructs a command line, and then shells out to the cmd line

Could use more polish and error checking.

I'm going to add this to a 'tool box' module, so I'm open if anyone has coments/suggestions



Option Explicit
Private Declare Function RegOpenKeyA Lib "advapi32.dll" _
(ByVal HKEY As Long, _
ByVal sKey As String, _
ByRef plKeyReturn As Long) As Long
Private Declare Function RegQueryValueExA Lib "advapi32.dll" _
(ByVal HKEY As Long, _
ByVal sValueName As String, _
ByVal dwReserved As Long, _
ByRef lValueType As Long, _
ByVal sValue As String, _
ByRef lResultLen As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal HKEY As Long) As Long
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003
Public Const HKEY_PERFORMANCE_DATA = &H80000004
Public Const HKEY_CURRENT_CONFIG = &H80000005
Public Const HKEY_DYN_DATA = &H80000006

Const sFileName As String = "C:\test.docx"

Sub drv()
MsgBox "About to start word and open " & sFileName

ShellToFile (sFileName)
MsgBox "Word should be running now with " & sFileName & " open"
End Sub


Sub ShellToFile(sFileName As String)
Dim s As String
Dim i As Long
Dim sRegClassID As String, sOpenCommand As String

'"C:\test.docx"
s = sFileName

i = Len(s)
While Mid(s, i, 1) <> "." And i > 0
i = i - 1
Wend
'".docx"

If i = 0 Then Exit Sub

s = Right(s, Len(s) - i + 1)

sRegClassID = GetRegistryValue("", s, HKEY_CLASSES_ROOT)
If Len(sRegClassID) = 0 Then Exit Sub

'"C:\Program Files\Microsoft Office\Office12\WINWORD.EXE" /n /dde
sOpenCommand = GetRegistryValue("", sRegClassID & "\Shell\Open\Command", HKEY_CLASSES_ROOT)
If Len(sOpenCommand) = 0 Then Exit Sub
'get rid of and registy parameters
While Right(sOpenCommand, 1) <> Chr(34) And Len(s) > 0
sOpenCommand = Left(sOpenCommand, Len(sOpenCommand) - 1)
Wend

'get rid of beginning and ending quotes
sOpenCommand = Mid(sOpenCommand, 2, Len(sOpenCommand) - 2)
'shell to the application with the file name on the command line passed
Call Shell(sOpenCommand & " " & Chr(34) & sFileName & Chr(34))

End Sub

'ValueName = "" to get default
Function GetRegistryValue(ValueName As String, _
Optional SubKey As String = "Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders", _
Optional Key As String = "HKEY_CURRENT_USER") As Variant

Const MAX_STRING As Long = 128
'Error values - From WIN32API.TXT except for BADKEY which I
' changed to 2 because that's what the function returns when
' the key doesn't exist. Not sure these are right.
Const ERROR_SUCCESS = 0&
Const ERROR_BADDB = 1009&
Const ERROR_BADKEY = 2&
Const ERROR_CANTOPEN = 1011&
Const ERROR_CANTREAD = 1012&
Const ERROR_CANTWRITE = 1013&
Const ERROR_REGISTRY_RECOVERED = 1014&
Const ERROR_REGISTRY_CORRUPT = 1015&
Const ERROR_REGISTRY_IO_FAILED = 1016&
Const ERROR_NOT_REGISTRY_FILE = 1017&
Const ERROR_KEY_DELETED = 1018&
Const ERROR_NO_LOG_SPACE = 1019&
Const ERROR_KEY_HAS_CHILDREN = 1020&
Const ERROR_CHILD_MUST_BE_VOLATILE = 1021&

'Register Value data types
Const REG_NONE = 0&
Const REG_SZ = 1&
Const REG_EXPAND_SZ = 2&
Const REG_BINARY = 3&
Const REG_DWORD = 4&
Const REG_DWORD_LITTLE_ENDIAN = 4&
Const REG_DWORD_BIG_ENDIAN = 5&
Const REG_LINK = 6&
Const REG_MULTI_SZ = 7&
Const REG_RESOURCE_LIST = 8&
Const REG_FULL_RESOURCE_DESCRIPTOR = 9&
Const REG_RESOURCE_REQUIREMENTS_LIST = 10&

Dim Buffer As String * MAX_STRING, ReturnCode As Long
Dim KeyHdlAddr As Long, ValueType As Long, ValueLen As Long, HKEY As Long
Dim TempBuffer As String, Counter As Integer
Dim s As String

ValueLen = MAX_STRING

Select Case UCase(Key)
Case "HKEY_CLASSES_ROOT", "ROOT"
Key = &H80000000
Case "HKEY_CURRENT_USER", "USER"
Key = &H80000001
Case "HKEY_LOCAL_MACHINE", "MACHINE"
Key = &H80000002
Case "HKEY_USERS", "USERS"
Key = &H80000003
Case "HKEY_PERFORMANCE_DATA", "PERF"
Key = &H80000004
Case "HKEY_CURRENT_CONFIG", "CONFIG"
Key = &H80000005
Case "HKEY_DYN_DATA", "DATA"
Key = &H80000006
End Select

ReturnCode = RegOpenKeyA(Key, SubKey, KeyHdlAddr)

If ReturnCode = ERROR_SUCCESS Then

ReturnCode = RegQueryValueExA(KeyHdlAddr, ValueName, 0&, ValueType, Buffer, ValueLen)
RegCloseKey KeyHdlAddr

Select Case ReturnCode

'If successful ValueType contains data type of value and ValueLen its length
Case ERROR_SUCCESS
Select Case ValueType
Case REG_BINARY
For Counter = 1 To ValueLen
TempBuffer = TempBuffer & Stretch(Hex(Asc(Mid(Buffer, Counter, 1)))) & " "
Next
GetRegistryValue = TempBuffer

Case REG_DWORD
TempBuffer = "0x"
For Counter = 4 To 1 Step -1
TempBuffer = TempBuffer & Stretch(Hex(Asc(Mid(Buffer, Counter, 1))))
Next
GetRegistryValue = TempBuffer


Case REG_SZ
GetRegistryValue = Left(Buffer, ValueLen - 1)

Case Else
If IsNumeric(Buffer) Then
GetRegistryValue = CDbl(Buffer)
Else
GetRegistryValue = Buffer
End If

End Select

Case ERROR_BADKEY
GetRegistryValue = ""

Case ERROR_BADDB
GetRegistryValue = "Error - Corrupt Registry"

Case ERROR_BADKEY
GetRegistryValue = "Error - Bad Key"

Case ERROR_CANTOPEN
GetRegistryValue = "Error - Can't Open"

Case ERROR_CANTREAD
GetRegistryValue = "Error - Can't Read "

Case ERROR_CANTWRITE
GetRegistryValue = "Error - Can't Write"

Case ERROR_REGISTRY_RECOVERED
GetRegistryValue = "Error - Registry File Recovered"

Case ERROR_REGISTRY_CORRUPT
GetRegistryValue = "Error - Corrupt Registry"

Case ERROR_REGISTRY_IO_FAILED
GetRegistryValue = "Error - File I/O Failed"

Case ERROR_NOT_REGISTRY_FILE
GetRegistryValue = "Error - File Not in Registry Format"

Case ERROR_KEY_DELETED
GetRegistryValue = "Error - Key Marked for Deletion"

Case ERROR_NO_LOG_SPACE
GetRegistryValue = "Error - No Log Space"

Case ERROR_KEY_HAS_CHILDREN
GetRegistryValue = "Error - Key Has Children"

Case ERROR_CHILD_MUST_BE_VOLATILE
GetRegistryValue = "Error - Child Must Be Volatile"

Case Else
GetRegistryValue = "Error - Unknown Type"

End Select
End If
End Function

'Pads a leading 0 if needed to make a byte string an even number of characters in length
Private Function Stretch(ByteStr As String) As String
If Len(ByteStr) = 1 Then ByteStr = "0" & ByteStr
Stretch = ByteStr
End Function



Paul

[GTO]

This seems to work, at least for the test cases I tried, under Vista SP2 and Offile 2007...

"Holy toledos Batman!"

Gosh Paul, that is nice! I only tested against a .doc thus far, but in both stepping and at speed in XP with excel2000, worked flawlessly:thumb. Trust me when I say that if it doesn't fall down in my 'on life supprt' laptop, it would probably run if plugged into a stone tablet...

BTW and I am only asking for my own education, are there issues with the ShellExecute?

Thank you and again, awfully nice.

Mark

[Paul_Hossler]

I really don't have extensive testing capabilty - different Office versions, different OS's, Mac/PC - so it's always "Buyer Beware". I'm glad it works on other versions.

I'm not aware of any issues with ShellExecute

The Registry code I got from somewhere on the internet, but don't remember where. Same for the Shell call. I put all those useful snippets into my 'Toolbox' modules workbook after I 'generalize' them the way I want. That way I can just add a module from my Toolbox WB to the current project. Sort of a poor man's "Link Library".

I copied from my Registry and Shell toolbox modules, so that's why there a lot unused Const and variables in the Sub's that can be removed if you want to tidy up :)

I'll be adding "Sub ShellToFile(sFileName As String)" to the tool box now, since I'll probalby find an use for it myself at some point in time.


Paul