Belgelerim'i Excelde Açmak

[Nadir]

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]

Ã?nce Modüle þu kodlarý yapýþtýrýn.
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]

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]

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.

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]

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]

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, Auto_Open 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 Auto_Open 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; Auto_Open 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]

ç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]

@ALPEN;

Senin gibi deðerli bir kod yazarýndan bu yorumlarý duymak çok hoþtu, teþekkürler... :keyif:

[Haluk]

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]

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]

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]

@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]

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]

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 Auto_Open()
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).CopyFa ce
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]

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ý]

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

[spilavci]

raider gerçekten çok güzel tebrikler

[muygun]

tek kelime ile mükemmel ...
katkýda bulunanlarýn eline saðlýk
ve soruyu sorana da... :))

[hsayar]

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]

Dosya yenilendi...

.

[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).CopyFa ce
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.