我这里双击文件夹快捷方式会进入这个文件夹,程序快捷方式会运行程序。
天津网站建设 http://www./
我改了一下,可以了,后退可能是有点小问题,你自己改一下吧。 我录制了一段屏幕,你看看吧,http://www.popoyu.net/test.avi 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 Private Declare Function GetDesktopWindow Lib "user32" () As Long Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
Private Const SE_ERR_NOASSOC = 31
Dim PathHistory() As String, CurrentHistoryStep As Long Dim LastPath As String, OptFlag As Boolean Dim FSO As Object
Public Sub ShellDoc(strFile As String) Dim lngRet As Long Dim strDir As String
Set FSO = CreateObject("Scripting.FileSystemObject") If LCase(Right(strFile, 4)) = ".lnk" Then strFile = GetLinkTarget(strFile) If FSO.FolderExists(strFile) Then ShellView1.Path = strFile Exit Sub End If End If lngRet = ShellExecute(GetDesktopWindow, "open", strFile, vbNullString, vbNullString, vbNormalFocus) If lngRet = SE_ERR_NOASSOC Then strDir = Space(260) lngRet = GetSystemDirectory(strDir, Len(strDir)) strDir = Left(strDir, lngRet) Call ShellExecute(GetDesktopWindow, vbNullString, "RUNDLL32.EXE", "shell32.dll,OpenAs_RunDLL " & strFile, strDir, vbNormalFocus) End If
End Sub
Private Sub Form_Load() CurrentHistoryStep = 0 ReDim PathHistory(0) As String PathHistory(0) = ShellView1.Path LastPath = PathHistory(0) End Sub
Private Sub ShellView1_Changed(ByVal RemoveID As Boolean) On Error GoTo ErrHandler Dim i As Long If LastPath <> ShellView1.Path And OptFlag = False Then i = UBound(PathHistory) + 1 ReDim Preserve PathHistory(i) As String PathHistory(i) = ShellView1.Path CurrentHistoryStep = CurrentHistoryStep + 1 Call SetToolBar LastPath = ShellView1.Path
End If Exit Sub ErrHandler: Err.Clear End Sub
Private Sub ShellView1_ItemDblClick() ShellDoc ShellView1.SelectedPath End Sub
Private Function GetLinkTarget(strFileName As String) As String Dim iwSH As New IWshRuntimeLibrary.IWshShell_Class Dim iwSC As IWshRuntimeLibrary.IWshShortcut_Class Set iwSC = iwSH.CreateShortcut(strFileName) GetLinkTarget = iwSC.TargetPath End Function
Private Sub SetToolBar() If CurrentHistoryStep > 0 Then Toolbar1.Buttons("Back").Enabled = True End If If ShellView1.Path = "" Then Toolbar1.Buttons("Up").Enabled = False Else Toolbar1.Buttons("Up").Enabled = True End If End Sub
Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button) Dim pos As Integer Dim Temp As String
Select Case Button.Key Case "Back" OptFlag = True CurrentHistoryStep = CurrentHistoryStep - 1 ShellView1.Path = PathHistory(CurrentHistoryStep) If CurrentHistoryStep = 0 Then Toolbar1.Buttons("Back").Enabled = False End If Toolbar1.Buttons("Forword").Enabled = True OptFlag = False Case "Forword" OptFlag = True CurrentHistoryStep = CurrentHistoryStep + 1 ShellView1.Path = PathHistory(CurrentHistoryStep) If CurrentHistoryStep = UBound(PathHistory) Then Toolbar1.Buttons("Forword").Enabled = False End If Toolbar1.Buttons("Back").Enabled = True OptFlag = False Case "Up" Debug.Print ShellView1.Path If Len(ShellView1.Path) = 3 Then ShellView1.Path = "::{20D04FE0-3AEA-1069-A2D8-08002B30309D}" ElseIf ShellView1.Path = "::{20D04FE0-3AEA-1069-A2D8-08002B30309D}" Then ShellView1.Path = "" Else pos = InStrRev(ShellView1.Path, "\") If pos > 0 Then Temp = Left(ShellView1.Path, pos - 1) If Len(Temp) = 2 Then Temp = Temp & "\" End If ShellView1.Path = Temp End If End If End Select Call SetToolBar End Sub
[此贴子已经被作者于2005-4-8 10:44:00编辑过]