请问，能否用VBA返回Windows系统中某类文件的默认打开程序的目录地址？

mansohu · 发表于 2013-7-15 11:40

比如返回后缀为 .xls 的文件默认打开程序的目录（应该就是application的目录吧）
再比如返回后缀为 .JPG 的文件默认打开程序的目录
等等吧
谢谢！

老谭酸菜 · 发表于 2013-7-15 13:30

感觉有点难度！恐怕要用VBA读取系统注册表才能实现。

mansohu · 发表于 2013-7-15 13:38

老谭酸菜发表于 2013-7-15 13:30
感觉有点难度！恐怕要用VBA读取系统注册表才能实现。

好像我特弱智是的，不过确实呆了。我是想通过一个文件的后缀，返回打开该文件的默认软件的安装路径，不知道说清楚没有啊？谢谢了

lsdongjh · 发表于 2013-7-15 16:18

其实很简单，就是读取注册表的内容，呵，要分两步，第一步，读取文件对应的键值，第二步，根据键值读出对应的程序

Option Explicit
Public Const REG_SZ As Long = 1
Public Const REG_DWORD As Long = 4
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 ERROR_NONE = 0
Public Const ERROR_BADDB = 1
Public Const ERROR_BADKEY = 2
Public Const ERROR_CANTOPEN = 3
Public Const ERROR_CANTREAD = 4
Public Const ERROR_CANTWRITE = 5
Public Const ERROR_OUTOFMEMORY = 6
Public Const ERROR_ARENA_TRASHED = 7
Public Const ERROR_ACCESS_DENIED = 8
Public Const ERROR_INVALID_PARAMETERS = 87
Public Const ERROR_NO_MORE_ITEMS = 259
Public Const KEY_QUERY_VALUE = &H1
Public Const KEY_SET_VALUE = &H2
Public Const KEY_ALL_ACCESS = &H3F
Public Const REG_OPTION_NON_VOLATILE = 0
Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long
Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias _
"RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, _
ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions _
As Long, ByVal samDesired As Long, ByVal lpSecurityAttributes _
As Long, phkResult As Long, lpdwDisposition As Long) As Long
Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias _
"RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, _
ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As _
Long) As Long
Declare Function RegQueryValueExString Lib "advapi32.dll" Alias _
"RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
String, ByVal lpReserved As Long, lpType As Long, ByVal lpData _
As String, lpcbData As Long) As Long
Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias _
"RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
String, ByVal lpReserved As Long, lpType As Long, lpData As _
Long, lpcbData As Long) As Long
Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias _
"RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
String, ByVal lpReserved As Long, lpType As Long, ByVal lpData _
As Long, lpcbData As Long) As Long
Declare Function RegSetValueExString Lib "advapi32.dll" Alias _
"RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As _
String, ByVal cbData As Long) As Long
Declare Function RegSetValueExLong Lib "advapi32.dll" Alias _
"RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, _
ByVal cbData As Long) As Long
''''''''''''''''''''
'主函数
Sub main()
MsgBox "XLS文件的默认打开程序为：" & vbCrLf & GetProNameByType("XLS")
End Sub
Function GetProNameByType(strFileType As String) As String
Dim strTemp As String
strFileType = "." & strFileType
strTemp = QueryValue(strFileType, "")
strTemp = strTemp & "\shell\Open\command"
strTemp = QueryValue(strTemp, "")
strTemp = Replace(strTemp, Chr(34), "")
strTemp = LCase(strTemp)
If InStr(strTemp, ".exe") > 0 Then
GetProNameByType = Split(strTemp, ".exe")(0) & ".exe"
Else
GetProNameByType = ""
End If
End Function
Private Function QueryValue(sKeyName As String, sValueName As String) As Variant
Dim lRetVal As Long 'API函数的结果
Dim hKey As Long '打开的键的句柄
Dim vValue As Variant '查询的值的设置
lRetVal = RegOpenKeyEx(HKEY_CLASSES_ROOT, sKeyName, 0, KEY_QUERY_VALUE, hKey)
lRetVal = QueryValueEx(hKey, sValueName, vValue)
QueryValue = vValue
RegCloseKey (hKey)
End Function
Function QueryValueEx(ByVal lhKey As Long, ByVal szValueName As _
String, vValue As Variant) As Long
Dim cch As Long
Dim lrc As Long
Dim lType As Long
Dim lValue As Long
Dim sValue As String
On Error GoTo QueryValueExError
' 确定读取的数据类型和大小
lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)
If lrc <> ERROR_NONE Then Error 5
Select Case lType
' 字符串
Case REG_SZ:
sValue = String(cch, 0)
lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, _
sValue, cch)
If lrc = ERROR_NONE Then
vValue = Left$(sValue, cch - 1)
Else
vValue = Empty
End If
' DWORDS
Case REG_DWORD:
lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, _
lValue, cch)
If lrc = ERROR_NONE Then vValue = lValue
Case Else
'所有不支持的其它数据类型
lrc = -1
End Select
QueryValueExExit:
QueryValueEx = lrc
Exit Function
QueryValueExError:
Resume QueryValueExExit
End Function

复制代码

附件：

注册表.rar (14.13 KB, 下载次数: 2)

boy8199 · 发表于 2013-7-15 16:18

有点超出了 excel 的范畴

lsdongjh · 发表于 2013-7-15 16:24

郁闷，发了贴，被移动到了回收站，只好再发
分二步，全部是注册表操作：
1.读取后缀名对应的键值
2.根据键值，读取打开的程序名
附件：

注册表.rar (14.13 KB, 下载次数: 2)

代码：

Option Explicit
Public Const REG_SZ As Long = 1
Public Const REG_DWORD As Long = 4
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 ERROR_NONE = 0
Public Const ERROR_BADDB = 1
Public Const ERROR_BADKEY = 2
Public Const ERROR_CANTOPEN = 3
Public Const ERROR_CANTREAD = 4
Public Const ERROR_CANTWRITE = 5
Public Const ERROR_OUTOFMEMORY = 6
Public Const ERROR_ARENA_TRASHED = 7
Public Const ERROR_ACCESS_DENIED = 8
Public Const ERROR_INVALID_PARAMETERS = 87
Public Const ERROR_NO_MORE_ITEMS = 259
Public Const KEY_QUERY_VALUE = &H1
Public Const KEY_SET_VALUE = &H2
Public Const KEY_ALL_ACCESS = &H3F
Public Const REG_OPTION_NON_VOLATILE = 0
Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long
Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias _
"RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, _
ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions _
As Long, ByVal samDesired As Long, ByVal lpSecurityAttributes _
As Long, phkResult As Long, lpdwDisposition As Long) As Long
Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias _
"RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, _
ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As _
Long) As Long
Declare Function RegQueryValueExString Lib "advapi32.dll" Alias _
"RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
String, ByVal lpReserved As Long, lpType As Long, ByVal lpData _
As String, lpcbData As Long) As Long
Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias _
"RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
String, ByVal lpReserved As Long, lpType As Long, lpData As _
Long, lpcbData As Long) As Long
Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias _
"RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
String, ByVal lpReserved As Long, lpType As Long, ByVal lpData _
As Long, lpcbData As Long) As Long
Declare Function RegSetValueExString Lib "advapi32.dll" Alias _
"RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As _
String, ByVal cbData As Long) As Long
Declare Function RegSetValueExLong Lib "advapi32.dll" Alias _
"RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, _
ByVal cbData As Long) As Long
''''''''''''''''''''
'主函数
Sub main()
MsgBox "XLS文件的默认打开程序为：" & vbCrLf & GetProNameByType("XLS")
End Sub
Function GetProNameByType(strFileType As String) As String
Dim strTemp As String
strFileType = "." & strFileType
strTemp = QueryValue(strFileType, "")
strTemp = strTemp & "\shell\Open\command"
strTemp = QueryValue(strTemp, "")
strTemp = Replace(strTemp, Chr(34), "")
strTemp = LCase(strTemp)
If InStr(strTemp, ".exe") > 0 Then
GetProNameByType = Split(strTemp, ".exe")(0) & ".exe"
Else
GetProNameByType = ""
End If
End Function
Private Function QueryValue(sKeyName As String, sValueName As String) As Variant
Dim lRetVal As Long 'API函数的结果
Dim hKey As Long '打开的键的句柄
Dim vValue As Variant '查询的值的设置
lRetVal = RegOpenKeyEx(HKEY_CLASSES_ROOT, sKeyName, 0, KEY_QUERY_VALUE, hKey)
lRetVal = QueryValueEx(hKey, sValueName, vValue)
QueryValue = vValue
RegCloseKey (hKey)
End Function
Function QueryValueEx(ByVal lhKey As Long, ByVal szValueName As _
String, vValue As Variant) As Long
Dim cch As Long
Dim lrc As Long
Dim lType As Long
Dim lValue As Long
Dim sValue As String
On Error GoTo QueryValueExError
' 确定读取的数据类型和大小
lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)
If lrc <> ERROR_NONE Then Error 5
Select Case lType
' 字符串
Case REG_SZ:
sValue = String(cch, 0)
lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, _
sValue, cch)
If lrc = ERROR_NONE Then
vValue = Left$(sValue, cch - 1)
Else
vValue = Empty
End If
' DWORDS
Case REG_DWORD:
lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, _
lValue, cch)
If lrc = ERROR_NONE Then vValue = lValue
Case Else
'所有不支持的其它数据类型
lrc = -1
End Select
QueryValueExExit:
QueryValueEx = lrc
Exit Function
QueryValueExError:
Resume QueryValueExExit
End Function

复制代码

lsdongjh · 发表于 2013-7-15 16:25

郁闷，发了二次贴，都被移动到了回收站，只好再发
分二步，全部是注册表操作：
1.读取后缀名对应的键值
2.根据键值，读取打开的程序名
附件：

注册表.rar (14.13 KB, 下载次数: 3)

lsdongjh · 发表于 2013-7-15 16:29

越想越郁闷，哈，被防火墙乱杀了，代码分两部分，看看能不能发：
一、ＡＰＩ声明

Option Explicit
Public Const REG_SZ As Long = 1
Public Const REG_DWORD As Long = 4
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 ERROR_NONE = 0
Public Const ERROR_BADDB = 1
Public Const ERROR_BADKEY = 2
Public Const ERROR_CANTOPEN = 3
Public Const ERROR_CANTREAD = 4
Public Const ERROR_CANTWRITE = 5
Public Const ERROR_OUTOFMEMORY = 6
Public Const ERROR_ARENA_TRASHED = 7
Public Const ERROR_ACCESS_DENIED = 8
Public Const ERROR_INVALID_PARAMETERS = 87
Public Const ERROR_NO_MORE_ITEMS = 259
Public Const KEY_QUERY_VALUE = &H1
Public Const KEY_SET_VALUE = &H2
Public Const KEY_ALL_ACCESS = &H3F
Public Const REG_OPTION_NON_VOLATILE = 0
Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long
Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias _
"RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, _
ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions _
As Long, ByVal samDesired As Long, ByVal lpSecurityAttributes _
As Long, phkResult As Long, lpdwDisposition As Long) As Long
Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias _
"RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, _
ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As _
Long) As Long
Declare Function RegQueryValueExString Lib "advapi32.dll" Alias _
"RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
String, ByVal lpReserved As Long, lpType As Long, ByVal lpData _
As String, lpcbData As Long) As Long
Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias _
"RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
String, ByVal lpReserved As Long, lpType As Long, lpData As _
Long, lpcbData As Long) As Long
Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias _
"RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
String, ByVal lpReserved As Long, lpType As Long, ByVal lpData _
As Long, lpcbData As Long) As Long
Declare Function RegSetValueExString Lib "advapi32.dll" Alias _
"RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As _
String, ByVal cbData As Long) As Long
Declare Function RegSetValueExLong Lib "advapi32.dll" Alias _
"RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, _
ByVal cbData As Long) As Long

复制代码

liucqa · 发表于 2013-7-15 23:30

FindExecutableW

用这个API可以获得执行程序的全路径

mansohu · 发表于 2013-7-16 14:43

liucqa 发表于 2013-7-15 23:30
FindExecutableW

用这个API可以获得执行程序的全路径

能否给个用法的例子啊？谢谢了

		自动登录	找回密码
密码			免费注册

[求助] 请问，能否用VBA返回Windows系统中某类文件的默认打开程序的目录地址？

评分

点评