Belgelerim'i Excelde Açmak

[hsayar]

Haluk hocam tekrar teşekkür ederim, ofis 2007 ye tarfi etmem nedeni ile aşağıdaki yordam bende çalışmamakta nasıl bir düzenleme yapılabilir?

Function CreateFileList(MenuPath As String, FileFilter As String, IncludeSubFolder As Boolean) As Variant
    Dim FileList() As String, FileCount As Long
    CreateFileList = ""
    Erase FileList
    With Application.FileSearch
        .NewSearch
        .LookIn = MenuPath
        .Filename = FileFilter
        .LastModified = msoLastModifiedAnyTime
        .SearchSubFolders = IncludeSubFolder
        If .Execute(SortBy:=msoSortByFileName, SortOrder:=msoSortOrderAscending) = 0 Then Exit Function
        ReDim FileList(.FoundFiles.Count)
            For FileCount = 1 To .FoundFiles.Count
                FileList(FileCount) = .FoundFiles(FileCount)
            Next
    End With
    CreateFileList = FileList
    Erase FileList
End Function

 

[Haluk]

2007 FileSearch metodunu desteklemiyor demek.... tuhaf doğrusu.

Bir üst versiyonunun alt versiyonu desteklemediği durumlarla sıkça karşılaşmıyoruz aslında.

Şu anda net olarak bilemiyorum ama, o fonksiyonun yerine oturup daha uzun uzadıya bir fonksiyon hazırlamak lazım. Ama madem ki böyle bir problem var, bence birileri bunun yolunu bulmuştur.... internetten araştırdınız mı ?

.

 

[Ferhat Pazarçevirdi]

Bence; dosya listesini almak için; FSO-File System Object'i kullanın ve kodlarınızı buna göre yeniden tasarlayın. Her durumda işe yarar...

 

[Zeki Gürsoy]

2007 versiyonunda bu eksiklik var. Ancak, biraz işi uzatarak alternatif üretmek de mümkün.

 

[Haluk]

Sözkonusu eklenti Ofis2007 için sorun çıkarmayacak şekilde düzenlendi... (umarım öyledir çünkü bende Ofis2007 yok ... :mrgreen: )

Not: Eklentinin kodları bir sonraki mesajda yer almaktadır.
.

 

[Haluk]

Eklentide yapılan revizyon sonucunda, kodlar aşağıdaki gibidir...

'***********************************************************************
'* My Documents - Belgelerim sistem klasorunu ve alt klasorleri        *
'* ile dosyalarini harf sirasine gore menuler halinde listeleyen,      *
'* ve menulerden secilen dosyalari acan yeni bir menu olusturulmasi    *
'* ile ilgili bir calismadir.                                          *
'*                        Aralik 2004                                  *
'*                          Haluk ®                                    *
'*                   Burası Excel vadisi ....                          *
'***********************************************************************
'                                                                      '
'***********************************************************************
'* Ilave edilen bir menu ile, istenilen herhangibir klasor ve altindaki*
'* klasorler ile dosyalarini harf sirasine gore menuler halinde        *
'* listelemek uzere ilgili revizyonlar yapilmistir                     *
'*                         Subat 2005                                  *
'*                           Haluk ®                                   *
'*                   Burası Excel vadisi ....                          *
'***********************************************************************
'
'***********************************************************************
'* Office 2007 versiyonu FileSearch metodunu desteklemedigi icin kodda *
'* revizyon yapildi                                                    *
'*                                                                     *
'*                         Kasim 2008                                  *
'*                           Haluk ®                                   *
'*                   Burası Excel vadisi ....                          *
'***********************************************************************

Const MyExt = "*.*"
    
Private Declare Function FindExecutable Lib "shell32.dll" Alias "FindExecutableA" _
    (ByVal lpFile As String, ByVal lpDirectory As String, ByVal lpResult As String) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
    (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    
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
Public RetVal As String
Dim MyDocPath As String
Dim MyPath As String
Dim MyCap As String
Dim MyBar As CommandBar
Dim MyMenu As CommandBarControl
'
Sub Auto_Open()
    strPath = GetMyDocPath
    ThisWorkbook.Sheets(1).Range("A1") = strPath
    Call StartUp(strPath)
End Sub
'
Sub StartUp(strPath)
    Set MyBar = Application.CommandBars("Worksheet Menu Bar")
    Set MyMenu = MyBar.Controls.Add(msoControlPopup, , , , True)
    If strPath = "" Then
        MyDocPath = GetMyDocPath
    Else
        MyDocPath = ThisWorkbook.Sheets(1).Range("A1")
    End If
    MyCap = StrReverse(MyDocPath)
    MyCap = StrReverse(Mid(MyCap, 1, InStr(1, MyCap, Application.PathSeparator) - 1))
    MyMenu.Caption = MyCap & " ®"
    MyMenu.Tag = "MyDocTag"
    MyMenu.BeginGroup = True
    MyMenu.OnAction = "RunMyDoc"
    Call CreateMenu
End Sub
'
Sub RunMyDoc()
    Set MyMenu = CommandBars.ActionControl
    For i = MyMenu.Controls.Count To 1 Step -1
        MyMenu.Controls(i).Delete
    Next
    Call CreateMenu
End Sub
'
Sub CreateMenu()
    On Error GoTo ResumeSub:
    FolderList = SubFolders(MyDocPath)
    For i = LBound(FolderList) To UBound(FolderList)
        Set MyItem = MyMenu.Controls.Add(msoControlPopup, , , , True)
        MyItem.Caption = FolderList(i)
        MyItem.OnAction = "MySub"
    Next
ResumeSub:
    On Error GoTo 0
    Err.Clear
    On Error Resume Next
    FileNamesList = CreateFileList(MyDocPath, MyExt)
    For i = 1 To UBound(FileNamesList)
        Set MyItem = MyMenu.Controls.Add(msoControlButton, , , , True)
        MyItem.Caption = i & ") " & Dir(FileNamesList(i))
        MyItem.OnAction = "OpenFile"
        MyItem.Tag = "??" & FileNamesList(i)
        If i = 1 Then MyItem.BeginGroup = True
        If (FileNamesList(i)) = Empty Then MyItem.Delete
    Next
        Set MyItem = MyMenu.Controls.Add(msoControlButton, , , , True)
        MyItem.Caption = MyCap
        MyItem.OnAction = "OpenMyDocFolder"
        Application.CommandBars.FindControl(ID:=23).CopyFace
        MyItem.PasteFace
        MyItem.BeginGroup = True
        
        Set MyItem = MyMenu.Controls.Add(msoControlButton, , , , True)
        MyItem.Caption = "Secenekler..."
        MyItem.OnAction = "ChangeFolder"
        
        Set MyItem = MyMenu.Controls.Add(msoControlButton, , , , True)
        MyItem.Caption = "Hakkında ...."
        MyItem.OnAction = "AboutBox"
        MyItem.BeginGroup = True
End Sub
'
Sub OpenMyDocFolder()
    ShellExecute 0&, "Open", MyDocPath, vbNullString, "C:\", 1
End Sub
'
Sub DelMenu()
    Application.CommandBars.FindControl(Tag:="MyDocTag").Delete
End Sub
'
Private Function GetMyDocPath() As String
    Dim WshShell As Object
    Set WshShell = CreateObject("WScript.Shell")
    GetMyDocPath = WshShell.SpecialFolders("MyDocuments")
    Set WshShell = Nothing
End Function
'
Sub MySub()
    On Error Resume Next
    Dim MyFolder As String, MenuFolder As String
    Set MyMenu = CommandBars.ActionControl
    MenuFolder = MyMenu.Caption
    If MenuFolder = Empty Then Exit Sub
    For i = MyMenu.Controls.Count To 1 Step -1
        MyMenu.Controls(i).Delete
    Next
    Call FolderPath(MyDocPath, MenuFolder)
    MyPath = RetVal
    FolderList = SubFolders(MyPath)
    For i = LBound(FolderList) To UBound(FolderList)
        Set MyItem = MyMenu.Controls.Add(msoControlPopup, , , , True)
        MyItem.Caption = FolderList(i)
        If MyItem.Caption = Empty Then MyItem.Delete
        MyItem.OnAction = "MySub"
    Next
    FileNamesList = CreateFileList(MyPath, MyExt)
    For i = 1 To UBound(FileNamesList)
        Set MyItem = MyMenu.Controls.Add(msoControlButton, , , , True)
        MyItem.Caption = i & ") " & Dir(FileNamesList(i))
        MyItem.Tag = "??" & FileNamesList(i)
        MyItem.OnAction = "OpenFile"
        If i = 1 Then MyItem.BeginGroup = True
        If MyItem.Caption = Empty Then MyItem.Delete
    Next
End Sub
'
Sub FolderPath(FolderSpec As String, SubFolder As String)
    Dim fs, f, f1, s, sf
    Dim xx As String
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(FolderSpec)
    Set sf = f.SubFolders
    For Each f1 In sf
        s = f1.Name
        xx = FolderSpec & Application.PathSeparator & f1.Name
        Call FolderPath(xx, SubFolder)
        If s = SubFolder Then
        RetVal = xx
        End If
    Next
End Sub
'
Function SubFolders(MenuPath)
    Dim fs, f, f1, s, sf
    Dim FolderList() As String, j As Long
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(MenuPath)
    Set sf = f.SubFolders
    j = 0
    For Each f1 In sf
        j = j + 1
        ReDim Preserve FolderList(1 To j)
        FolderList(j) = f1.Name
    Next
    SubFolders = FolderList
End Function
'
Function CreateFileList(MenuPath As String, FileFilter As String) As Variant
    Dim FileList() As String, aFile As String, z As Long
    CreateFileList = ""
    aFile = Dir(MenuPath & Application.PathSeparator & FileFilter, vbDirectory)
    Do While aFile <> ""
        If aFile <> "." And aFile <> ".." And aFile Like "*.*" Then
            z = z + 1
            ReDim Preserve FileList(1 To z)
            FileList(z) = MenuPath & Application.PathSeparator & aFile
        End If
        aFile = Dir
    Loop
    CreateFileList = FileList()
    Erase FileList
End Function
'
Sub OpenFile()
    Dim MyVal As Integer
    Dim Buff As String
    Dim hWnd As Long
    Dim MyFile As String
    DoEvents
    MyFile = CommandBars.ActionControl.Tag
    MyFile = Mid(MyFile, InStr(1, MyFile, "?") + 2, 98)
        If Right(MyFile, 4) = ".xls" Then
            Workbooks.Open MyFile
            Exit Sub
        End If
        If Dir(MyFile) = Empty Then
            MsgBox MyFile & " dosyası bulunamadı"
            Exit Sub
        End If
    Buff = String(260, 32)
    MyVal = FindExecutable(MyFile, vbNullString, Buff)
        If MyVal > 32 Then
                If Application.Version < 9 Then
                    hWnd = FindWindow("ThunderXFrame", "")
                Else
                    hWnd = FindWindow("ThunderDFrame", "")
                End If
            ShellExecute hWnd, "Open", MyFile, vbNullString, "C:\", 1
        Else
            MsgBox Dir(MyFile) & " dosyası ile ilişkili bir program bulunamadı !", vbExclamation
        End If
End Sub
'
Sub ChangeFolder()
    Dim ObjFolder As Object
    Set ObjFolder = CreateObject("Shell.Application").BrowseForFolder _
                    (0, "Klasor secin...", &H100, 0&)
    On Error GoTo ErrMsg:
    If Not TypeName(ObjFolder) = "Nothing" Then
        ObjPath = ObjFolder.Items.Item.Path
        If Left(ObjPath, 1) = ":" Then GoTo ErrMsg:
    End If
    ThisWorkbook.Sheets(1).Range("A1") = ObjPath
    Call DelMenu
    Call StartUp(ObjPath)
    Set ObjFolder = Nothing
    Exit Sub
ErrMsg:
    Err.Clear
    MsgBox "Lutfen gecerli bir klasor secin....", vbCritical, "Kullanicinin dikkatine !"
End Sub
'
Sub AboutBox()
    MsgBox "  Burası Excel Vadisi...." & vbCrLf & vbCrLf & _
           "  Orjinal kod : Aralik 2004" & vbCrLf & _
           "  Revizyon-1: Subat 2005" & vbCrLf & _
           "  Revizyon-2: Kasim 2008" & vbCrLf & vbCrLf & _
           "           Haluk ®", , "Hakkında..."
End Sub
'
Sub Auto_Close()
    On Error Resume Next
    Call DelMenu
End Sub

 

[hsayar]

haluk hocam teşekkür ederim.