有时候会用到使用vb打开word文档、ppt文档等,可能需要获取office安装路径,分享别个写的代码
Option Explicit
Dim pt As String
Private 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
Private Declare Function RegQueryValueEx 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
Private Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long
Private Const REG_SZ As Long = 1
Private Const KEY_ALL_ACCESS = &H3F
Private Const HKEY_LOCAL_MACHINE = &H80000002
Public Function GetWordPath() As String
GetWordPath = GetOfficeAppPath("Word.Application")
End Function
Public Function GetExcelPath() As String
GetExcelPath = GetOfficeAppPath("Excel.Application")
End Function
Public Function GetAccessPath() As String
GetAccessPath = GetOfficeAppPath("Access.Application")
End Function
Public Function GetOutlookPath() As String
GetOutlookPath = GetOfficeAppPath("Outlook.Application")
End Function
Public Function GetPowerPointPath() As String
GetPowerPointPath = _
GetOfficeAppPath("PowerPoint.Application")
End Function
Public Function GetFrontPagePath() As String
GetFrontPagePath = GetOfficeAppPath("FrontPage.Application")
End Function
Private Function GetOfficeAppPath(ByVal ProgID As String) _
As String
Dim lKey As Long
Dim lRet As Long
Dim sClassID As String
Dim sAns As String
Dim lngBuffer As Long
Dim lPos As Long
'GetClassID
lRet = RegOpenKeyEx(HKEY_LOCAL_MACHINE, _
"Software\Classes\" & ProgID & "\CLSID", 0&, _
KEY_ALL_ACCESS, lKey)
If lRet = 0 Then
lRet = RegQueryValueEx(lKey, "", 0&, REG_SZ, "", lngBuffer)
sClassID = Space(lngBuffer)
lRet = RegQueryValueEx(lKey, "", 0&, REG_SZ, sClassID, _
lngBuffer)
'drop null-terminator
sClassID = Left(sClassID, lngBuffer - 1)
RegCloseKey lKey
End If
'Get AppPath
lRet = RegOpenKeyEx(HKEY_LOCAL_MACHINE, _
"Software\Classes\CLSID\" & sClassID & _
"\LocalServer32", 0&, KEY_ALL_ACCESS, lKey)
If lRet = 0 Then
lRet = RegQueryValueEx(lKey, "", 0&, REG_SZ, "", lngBuffer)
sAns = Space(lngBuffer)
lRet = RegQueryValueEx(lKey, "", 0&, REG_SZ, sAns, _
lngBuffer)
sAns = Left(sAns, lngBuffer - 1)
RegCloseKey lKey
End If
lPos = InStr(sAns, "/")
If lPos > 0 Then
sAns = Trim(Left(sAns, lPos - 1))
End If
GetOfficeAppPath = sAns
End Function
Private Sub Command1_Click()
Text1.Text = GetPowerPointPath()
pt = Text1.Text
End Sub
Private Sub Command2_Click()
Shell pt & " " & App.Path & "\PPT\刀架原理.pptx", vbNormalFocus
End Sub
Option Explicit
Dim pt As String
Private 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
Private Declare Function RegQueryValueEx 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
Private Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long
Private Const REG_SZ As Long = 1
Private Const KEY_ALL_ACCESS = &H3F
Private Const HKEY_LOCAL_MACHINE = &H80000002
Public Function GetWordPath() As String
GetWordPath = GetOfficeAppPath("Word.Application")
End Function
Public Function GetExcelPath() As String
GetExcelPath = GetOfficeAppPath("Excel.Application")
End Function
Public Function GetAccessPath() As String
GetAccessPath = GetOfficeAppPath("Access.Application")
End Function
Public Function GetOutlookPath() As String
GetOutlookPath = GetOfficeAppPath("Outlook.Application")
End Function
Public Function GetPowerPointPath() As String
GetPowerPointPath = _
GetOfficeAppPath("PowerPoint.Application")
End Function
Public Function GetFrontPagePath() As String
GetFrontPagePath = GetOfficeAppPath("FrontPage.Application")
End Function
Private Function GetOfficeAppPath(ByVal ProgID As String) _
As String
Dim lKey As Long
Dim lRet As Long
Dim sClassID As String
Dim sAns As String
Dim lngBuffer As Long
Dim lPos As Long
'GetClassID
lRet = RegOpenKeyEx(HKEY_LOCAL_MACHINE, _
"Software\Classes\" & ProgID & "\CLSID", 0&, _
KEY_ALL_ACCESS, lKey)
If lRet = 0 Then
lRet = RegQueryValueEx(lKey, "", 0&, REG_SZ, "", lngBuffer)
sClassID = Space(lngBuffer)
lRet = RegQueryValueEx(lKey, "", 0&, REG_SZ, sClassID, _
lngBuffer)
'drop null-terminator
sClassID = Left(sClassID, lngBuffer - 1)
RegCloseKey lKey
End If
'Get AppPath
lRet = RegOpenKeyEx(HKEY_LOCAL_MACHINE, _
"Software\Classes\CLSID\" & sClassID & _
"\LocalServer32", 0&, KEY_ALL_ACCESS, lKey)
If lRet = 0 Then
lRet = RegQueryValueEx(lKey, "", 0&, REG_SZ, "", lngBuffer)
sAns = Space(lngBuffer)
lRet = RegQueryValueEx(lKey, "", 0&, REG_SZ, sAns, _
lngBuffer)
sAns = Left(sAns, lngBuffer - 1)
RegCloseKey lKey
End If
lPos = InStr(sAns, "/")
If lPos > 0 Then
sAns = Trim(Left(sAns, lPos - 1))
End If
GetOfficeAppPath = sAns
End Function
Private Sub Command1_Click()
Text1.Text = GetPowerPointPath()
pt = Text1.Text
End Sub
Private Sub Command2_Click()
Shell pt & " " & App.Path & "\PPT\刀架原理.pptx", vbNormalFocus
End Sub