Belgelerim'i Excelde Açmak

Nadir · 26 Kasım 2004

Merhaba,

Devamlı Excel açık olduğu için Exceldeki Yardım menüsünün yanına Belgelerim klasörünü açılır menü şeklinde gösterecek bir uygulama nasıl yapılabilir. Ã?rneğin, Excelin Yardım menüsünü tıkladığımızda aşağıya doğru açıldığı gibi, eklenecek olan Belgelerim klasörü de dosyaları ve klasörleri gösterecek şekilde aşağıya doğru açılsın ve ben ilgili dosyaya ya da klasöre tıkladığımda çalışsın. (Böyle bir uygulama Başlat çubuğundaki Ã?zelliklerde mevcut)

xxrt · 26 Kasım 2004

Ã?nce Modüle şu kodları yapıştırın.

Kod:

 Sub tt()
  Dim Dosya As Variant
  ChDrive ("c:\")
  ChDir "c:\Belgelerim\"
  Dosya = Application.GetOpenFilename("Açmak istediğiniz dosyayı seçin.,*.xls)")
  If Dosya = False Then Exit Sub
  Workbooks.Open (Dosya)
 End Sub

Sağ Tuşu Tıklayarak Ã?zelleştir Seçin.Sıra İle :
Komutlar>Yeni Menü Bu Yeni Menüyü istediğiniz yere koyun.Daha Sonra Yeni Menü Ã?zelleştir Penceresin Kapatmadan Yeni Menü Üzerinde sağ tuş ile tt Makrosunu atayın.Kolay Gelsin.

Nadir · 26 Kasım 2004

Teşekkür ederim xxrt,

Ama istediğim bu değil. Bu öneriniz zaten Standart araç çubuğundaki Aç komutu ile aynı sayılır. İlk mesajımda da belirttiğim gibi açılır menü şeklinde olmalıdır. Sizin önerdiğiniz kodda ise pencere şeklinde çıkmaktadır. Açılır menünün kullanımı daha kolaydır. Ã?nce menüye sonra istenilen dosyaya tıklanır ve işlem biter. Çabuk olması bakımından diyorum.

Haluk · 14 Aralık 2004

Merhaba;

Dün akşam bir ara siteye girdiğimde bu sorunun henüz net olarak cevaplanmadığını görmüştüm. Benim de işime yarayacağını düşündüğümden, bugün konuyla ilgili bir şeyler yaptım ama bu saate kadar sitedeki bir problemden dolayı cevabı ancak şimdi yollayabiliyorum.

Gerçi, geliştirilecek yönleri daha var tabii ama en azından Nadir'in istediğine yakın bir çözüm olması açısından kodları veriyorum.

Kod:

Const CSIDL_PERSONAL = &H5
Const MyExt = "*.*"
Const IncludeSubFolder = False

Private Type SHITEMID
    cb As Long
    abID As Byte
End Type

Private Type ITEMIDLIST
    mkid As SHITEMID
End Type

Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" _
    (ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As ITEMIDLIST) As Long
    
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
    (ByVal pidl As Long, ByVal pszPath As String) As Long
    
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

Dim MyDocPath As String
Public RetVal As String
Dim MyPath As String
'
Sub Auto_Open()
    Dim MyBar As CommandBar
    Dim MyMenu As CommandBarControl
    Set MyBar = Application.CommandBars("Worksheet Menu Bar")
    Set MyMenu = MyBar.Controls.Add(msoControlPopup, , , , True)
    MyDocPath = GetSpecialfolder(&H5)
    MyCap = StrReverse(MyDocPath)
    MyCap = StrReverse(Mid(MyCap, 1, InStr(1, MyCap, Application.PathSeparator) - 1))
    MyMenu.Caption = MyCap & " Â®"
    MyMenu.Tag = "MyDocTag"
    MyMenu.BeginGroup = True
    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
    FileNamesList = CreateFileList(MyDocPath, MyExt, IncludeSubFolder)
    For i = 1 To UBound(FileNamesList)
        Set MyItem = MyMenu.Controls.Add(msoControlButton, , , , True)
        MyItem.Caption = i - 1 & ") " & Dir(FileNamesList(i))
        MyItem.OnAction = "OpenFile"
        MyItem.Tag = "??" & FileNamesList(i)
        If Dir(FileNamesList(i)) = Empty Then MyItem.Delete
    Next
        Set MyItem = MyMenu.Controls.Add(msoControlButton, , , , True)
        MyItem.Caption = "Hakkında ...."
        MyItem.OnAction = "AboutBox"
        MyItem.BeginGroup = True
End Sub
'
Sub DelMenu()
    Application.CommandBars.FindControl(Tag:="MyDocTag").Delete
End Sub
'
Private Function GetSpecialfolder(CSIDL As Long) As String
    Dim r As Long
    Dim Path$
    Dim IDL As ITEMIDLIST
    r = SHGetSpecialFolderLocation(100, CSIDL, IDL)
    If r = 0 Then
        Path$ = Space$(512)
        r = SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal Path$)
        GetSpecialfolder = Left$(Path$, InStr(Path$, Chr$(0)) - 1)
        Exit Function
    End If
    GetSpecialfolder = ""
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, IncludeSubFolder)
    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 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, 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
'
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 AboutBox()
    MsgBox "  Burası Excel Vadisi...." & vbCrLf & vbCrLf & _
           "Raider Â® ---- Aralık 2004", , "Hakkında..."
End Sub
'
Sub Auto_Close()
    On Error Resume Next
    Call DelMenu
End Sub

Yukarıdaki kodlar, aşağıdaki resimde görüldüğü gibi My Documents (Belgelerim) klasörünün simulasyonunu, Excel'in menü çubuğuna ekler.

(Kodlar, Win2000 + Office2000 ile hazırlanmıştır.)

Kodların olduğu dosya ektedir.

belgelerim menü menu popup

Levent Menteşoğlu · 15 Aralık 2004

Sn Raider

Ekteki dosyanızı inceledim. Çok güzel bir çalışma olmuş elinize sağlık. Kodları daha detaylı incelemek için eğer çok vaktinizi almayacaksa her bir sub ve function'un ne işlem yaptığını kısa notlar halinde verebilirmisiniz. Ã?zellikle aşağıdaki kodların ne işlem gördüğü ile ilgili bilgi verirseniz çok memnun olurum.

Saygılarımla

Const CSIDL_PERSONAL = &H5
Const MyExt = "*.*"
Const IncludeSubFolder = False

Private Type SHITEMID
cb As Long
abID As Byte
End Type

Private Type ITEMIDLIST
mkid As SHITEMID
End Type

Haluk · 16 Aralık 2004

Merhaba leventm;

Dilim döndüğü kadarıyla kısaca anlatmaya çalışayım:

1) GetSpecialfolder isimli kullanıcı tanımlı fonksiyon, bilgisayarda o anda Windows oturumu açan kişinin profilindeki My Documents - Belgelerim klasörünün dosya yolunu geriye döndürür. Bu kullanıcı tanımlı fonksiyonda SHGetPathFromIDList adlı API'yi kullanıyoruz. BU API'nin gereği olarak da sorunuzda belirtilen IDL tanımlamasını modül seviyesinde yapmak zorundayız.

2) SubFolders isimli kullanıcı tanımlı fonksiyon, Autpen ve MySub prosedurleri içinde çağrılarak, kendisine bildirilen dosya yolu altındaki alt klasörleri bulmaya yarar, yani menüye eklediğimiz alt menüleri.

3) CreateFileList isimli kullanıcı tanımlı fonksiyon ise, kendisine bildirilen parametreler (dosya yolu, dosya uzantısı, alt klsörlerin de araştırılıp-araştırılmayacağı) doğrultusunda istenilen dosya yolundaki mevcut dosyaları bulur.

4) Bu kullanıcı tanımlı fonksiyonlar aracılığıyla yapılan iş ise;

4.1) Dosya açıldığında devreye giren Autpen proseduru ile ilk önce kullanıcının My Documents / Belgelerim klasörünün dosya yolu belirlenir ve bu klasörün adı, menü çubuğuna ilave edilen bir ControlPopup düğmesine etiket olarak atanır. Daha sonra, My Documents / Belgelerim dosya yolundaki 1.seviye klasörler SubFolders isimli kullanıcı tanımlı fonksiyon ile bu menüye ControlPopup özelliğinde alt menü elemanları olarak atanır. Benzer şekilde, bu kez My Documents / Belgelerim dosya yolundaki dosya isimleri bu kez ControlButton özelliğindeki alt menüler olarak atanır.

4.2) Yukarıya kadar olan kısım kolay, işin gıcık kısmını burada yapıyoruz. Yani, 1.seviye menülere 2., 3., 4........ nereye kadar kadar gideceğini bilemediğimiz sayıdaki alt menüleri ilave etmeye başlıyoruz. Bunun için, yukarıdaki adımda, 1.seviye menüleri hazırlarken bunların herbirinin OnAction yani, "çalıştırılması halinde" özelliğine MySub prosedürünü çalıştırmak olarak belirtmiştik. 1.Seviye menüler çalıştırıldığında, bu MySub prosedürü devreye girerek, bu kez yukarıdaki adımda belirtilen işlerin bir benzerini bu kez seçilen menünün yani diğer bir deyişle, seçilen alt klasörün kendisinin alt klasörlerini araştırıp, bunların isimlerini 2., 3., veya 5. artık kaçıncı alt menü ise oraya ControlPopup özelliğinde alt menü elemanları olarak atar ve benzer şekilde buradaki dosya isimlerini de ControlButton özelliğindeki alt menüler olarak atar.

Burada esas amacımız, bir klasörün alt klasörlerini de keşfetmek olduğu için işin esprisi FolderPath isimli prosedurün yine kendisini ama bu kez değişik argümanlarla Call FolderPath(xx, SubFolder) satırı ile çağırmasıdır. Belki de, kodların en can alıcı noktası burasıdır. Eğer bu şekilde olmasaydı, her alt menü için bu kadar kodu değişik değişken tanımlamalarıyla tekrar tekrar yazacak, üstelik kaç adet alt menü olduğunu da bilmediğimiz için, hiç bir zaman gerçek menü düzenini ortaya çıkartamayacaktık. Bana göre, işin esprisi ve can alıcı noktası burada.

4.3) Eveeet.... buraya kadar olan kısımda, menüleri hazırladık. Eğer çalıştırırsak, ekranda menüleri ve alt menüleri görebiliriz. Ama, alt menülerde seçilen dosyaları henüz açamayız. Bunun için de, dosya isimlerinin yer aldığı alt menülerin herbirinin OnAction yani, "çalıştırılması halinde" özelliğine "OpenFile" isimli prosedürü atamıştık. Bu prosedürün ana fikri, dosya yolu bilinen bir dosyanın ShellExecute API' nin kullanılarak açılmasıdır. Bu dosya, herhangibir uzantıya sahip olabilir. Yeterki, bilgisayarda o dosyayı açacak ve o dosya uzantısıyla ilişkilendirilmiş bir program olsun. Bu şekilde ilişkilendirilmiş bir program olup, olmadığını da FindExecutable API'ni kullanarak buluyoruz ve API' den geriye dönen sonuca göre, menüden seçilen dosyayı açıyoruz veya kullanıcıyı uyarıyoruz.

Bahsettiğimiz, OpenFile prosedüründe önemli olan menülerde seçilen dosyanın gerçek dosya yolunu tam olarak bilmemiz gerekmektedir. İşte bu da, kodlardaki 2nci can alıcı nokta. Eğer, bir şekilde bu dosya yolunu bilebilirsek, daha doğrusu her dosyanın dosya yolunu bir şekilde Excel'in hatırlamasını becerebilirsek, bu iş de yapabiliriz demektir. Bu konuyu da, geliştirdiğim şöyle bir teknikle hallediyoruz. Ãöyle ki; Autpen ve MySub prosedürlerinde dosya isimlerinin yer aldığı menülerin Tag özelliklerine sözkonusu dosyaların gerçek ve tam dosya yollarını değer olarak atayıp, daha sonra, OpenFile prosedüründe, seçilen menünün Tag özelliğini okuyarak, bu bilgiye ulaşıyoruz ve işimizi tamamlıyoruz. Eğer, seçilen dosya *.xls dosyası ise, ShellExecute API'ni kullanmadan direkt VBA kodu ile dosyayı açıyoruz.

4.4) DelMenu prosedurü ile, Excel'in menü çubuğuna ilave ettiğimiz bu yeni menüyü Tag özelliğini kullanarak bulduktan sonra, silmek için kullanıyoruz. Bu prosedürü, dosyanın Auto_Close prosedürü içinde çağırıyoruz.

5) Bu menünün her Excel dosyası açıldığında veya Excel uygulaması başlatıldığında devreye otomatik olarak girmesi için tabii ki yapılması gereken, dosyayı bir AddIn olarak hazırlamak ve bu eklentiyi Excel'in kendisine tanıtmak olacaktır.

Umarım, konuyu anlatırken kafanızı fazla karıştırmadım. Kodlar belki daha da kısalatılabilir bilemiyorum...... ben aklıma geldiği şekilde hazırladım. Ama pek de kolay olmadı doğrusu :mrgreen:

ALPEN · 16 Aralık 2004

çok zekice ve tutumlu teknikler, özellikle bahsettiğin gibi FolderPath'in esnek yapısı bütün işi kotarmış.

wallahi tebrikler, çok hoş düşünce tarzı.

Haluk · 16 Aralık 2004

@ALPEN;

Senin gibi değerli bir kod yazarından bu yorumları duymak çok hoştu, teşekkürler... :keyif:

Haluk · 17 Aralık 2004

Tekrar merhaba;

Yukarıdaki ilk mesajımda, kodların biraz daha geliştirilebileceğinden bahsetmiştim. Bunlardan bir tanesi, menüyü çalıştırdıktan sonra herhangibir klasör-alt klasördeki dosya isimlerini menüden okuduktan sonra, manuel olarak o klasöre gidip, herhangibir dosyayı sildiğinizde veya yeni bir dosya ilave ettikten sonra tekrar menüyü çalıştırdığınızda, yapılan değişikliğin menüye yansıtılamaması idi.

Ekteki dosyada bu problem de çözülmüştür. Yani, menüler dinamik olarak çalışmaktadır.

Nadir · 19 Aralık 2004

Merhaba,
Sayın Raider, gerçekten çok güzel olmuş, fevkalade bir çalışma... "alt klasorleri ile dosyalarini harf sirasine gore menuler halinde listeleyen..." çalışma yaparak, ince düşünülmüş ve kullanıcının rahatlıkla kullanabileceği şekilde olmuş. Teşekkür ederim.

Levent Menteşoğlu · 19 Aralık 2004

Sn Raider

Zaman ayırarak yapmış olduğunuz detaylı açıklamalar nedeniyle çok teşekkür ederim. Birde merak ettiğim konulardan biri olan API ler ile ilgili detaylı bilgiye nasıl ulaşırım. Tavsiye edeceğiniz bir kitap veya web sitesi varmıdır. Yada ara sıra zamanınız oldukça burada bize API ler konusunda kısa notlar sunabilirmisiniz. Umarım sizden çok şey istemiyorum. Sizler gibi bilgisinden istifade edebileceğimiz kişilere rastlamak oldukça zor. Zamanınızı ayırarak vermiş olduğunuz bilgiler nedeniyle bir kez daha teşekkür ederim.

saygılarımla

Haluk · 19 Aralık 2004

@Nadir;

Nazik düşünceleriniz için ben de size teşekkür ederim, beğendiğinize gerçekten çok sevindim.

@leventm;

API'ler hakkında en iyi kaynak (benim bildiğim kadarıyla) www.allapi.net sitesidir. Başka siteler de var ama, ben en çok burayı kullanırım. Hemen hemen her türlü API ve her birinin kullanımıyla ilgili en az 1 adet örnek kod mevcuttur.

Yalnız göz önünde bulundurmanız gereken önemli bir nokta şudur ki; API'ler genel olarak VB için hazırlanmıştır. Bahsettiğim sitedeki örnek kodlar da VB içindir, VBA için değil. API'lerin bir kısmını VBA de direkt olarak kullanabilirsiniz, bir kısmını kullanmak için ise ufak-tefek ilaveler yapmak gerekir.

Nazik düşünceleriniz için size de teşekkür ederim.

Benden de sizlere saygılar.....

ALPEN · 20 Aralık 2004

belki sn. Raider'in önerdiği api ile ilgili benim şimdiye kadar gördüğüm en iyi siteye gittiğinizde aşağıdaki program gözünüzden kaçar deyu.

http://www.mentalis.org/agnet/apiguide.shtml
sayfasındaki

http://www.allapi.net/agnet/appdown.shtml linkiden içinde her apinin ne işe yaradığını, deklerasyonunun nasıl yapıldığını, kod içinde nasıl çalıştığını ek olarak bir örneği barındıran programı indirebilirsiniz.

Haluk · 15 Şubat 2005

Tekrar merhaba arkadaşlar;

Yukarıdaki konuyla ilgili çalışmamı revize ederek, biraz daha esnek bir hale getirmeye çalıştım.

Bu kez, oluşturulan menüye bir de "Secenekler..." etiketli bir alt menü ilave ettim ve böylece aşağıdaki resimlerden de görüleceği gibi, kullanıcı eğer isterse bilgisayarındaki My Documents - Belgelerim haricinde istediği herhangibir klasorü de yine yukarıdaki mesajlarda bahsedildiği gibi kullanabilecektir.

Aşağıdaki resimlerden görüleceği gibi, eklenti ilk olarak yüklendiğinde varsayılan olarak My Documents - Belgelerim menüsü, daha sonra bilgisayardaki G:\DataFolders olarak özelleştirilmiştir.

Bununla ilgili kodlar aşağıdadır:

[vb:1:ac3b743855]'***********************************************************************
'* 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 *
'* Raider Â® *
'* Burası Excel vadisi .... *
'***********************************************************************
' '
'***********************************************************************
'* Ilave edilen bir menu ile, istenilen herhangibir klasor ve altindaki*
'* kalsorler ile dosyalarini harf sirasine gore menuler halinde *
'* listelemek uzere ilgili revizyonlar yapilmistir *
'* Subat 2005 *
'* Raider Â® *
'* Burası Excel vadisi .... *
'***********************************************************************
'

Const CSIDL_PERSONAL = &H5
Const MyExt = "*.*"
Const IncludeSubFolder = False

Private Type SHITEMID
cb As Long
abID As Byte
End Type

Private Type ITEMIDLIST
mkid As SHITEMID
End Type

Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" _
(ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As ITEMIDLIST) As Long

Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, ByVal pszPath As String) As Long

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 Aut

pen()
strPath = ThisWorkbook.Sheets(1).Range("A1")
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 = GetSpecialfolder(CSIDL_PERSONAL)
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, IncludeSubFolder)
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 Dir(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 = "AboutBox2"
MyItem.BeginGroup = True
End Sub
'
Sub OpenMyDocFolder()
ShellExecute hWnd, "Open", MyDocPath, vbNullString, "C:\", 1
End Sub
'
Sub DelMenu()
Application.CommandBars.FindControl(Tag:="MyDocTag").Delete
End Sub
'
Private Function GetSpecialfolder(CSIDL As Long) As String
Dim r As Long
Dim Path$
Dim IDL As ITEMIDLIST
r = SHGetSpecialFolderLocation(100, CSIDL, IDL)
If r = 0 Then
Path$ = Space$(512)
r = SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal Path$)
GetSpecialfolder = Left$(Path$, InStr(Path$, Chr$(0)) - 1)
Exit Function
End If
GetSpecialfolder = ""
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, IncludeSubFolder)
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, 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
'
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 AboutBox2()
MsgBox " Burası Excel Vadisi...." & vbCrLf & vbCrLf & _
" Raider Â®" & vbCrLf & vbCrLf & "Revizyon: Subat 2005", , "Hakkında..."
End Sub
'
Sub Auto_Close()
On Error Resume Next
ThisWorkbook.Save
Call DelMenu
End Sub
[/vb:1:ac3b743855]

İlgili resimler :

Haluk · 15 Şubat 2005

Yukarıdaki kodların yer aldığı eklentiyi, mesajdan çıkarttım.

İsteyen arkadaşlar, yukarıdaki kodları yeni bir Excel dosyasında bir module yerleştirdikten sonra, dosyayı *.xla olarak kaydedip, daha sonra bunu eklenti olarak Excel'e tanıtarak kullanabilirler....

hüseyin balcı · 17 Şubat 2005

Sayın Raider, her revizeniz daha da güzel, harikasınız, teşekkürler...

spilavci · 27 Şubat 2005

raider gerçekten çok güzel tebrikler

muygun · 28 Şubat 2005

tek kelime ile mükemmel ...
katkıda bulunanların eline sağlık
ve soruyu sorana da...

)

hsayar · 21 Kasım 2007

http://www.excel.web.tr/showpost.php?p=9204&postcount=14
hocam 14. mesajdaki kodda bazı sorunlar var xls kapanınca menü kaybolmuyor.....
birde dosya adına sağ tıklayınca
silme ve
gönder olsa ama klasik gönder yanında klasör seçiniz olacak)
mümkünmü

ayrıca bu menüyü Benim menüm veya dosya menüsüne alt menü olarak taşaımak için neler gerelidir.
resimdeki winzip menüsündede gözüm kaldı.
onuda eklerseniz sevinirim.

Haluk · 7 Kasım 2008

Dosya yenilendi...

.

Belgelerim'i Excelde Açmak

Nadir

xxrt

Misafir

Nadir

Haluk

Özel Üye

Levent Menteşoğlu

Administrator

Haluk

Özel Üye

ALPEN

Haluk

Özel Üye

Haluk

Özel Üye

Nadir

Levent Menteşoğlu

Administrator

Haluk

Özel Üye

ALPEN

Haluk

Özel Üye

Haluk

Özel Üye

hüseyin balcı

spilavci

muygun

Özel Üye

hsayar

Haluk

Özel Üye

Ekli dosyalar