Browsefolder Diyalog Sorunu

[excelokyanus500]

Merhaba,

Browsefolder fonksiyonlarında klasörün kendisi olması halinde klasör yolu kolaylıkla bulunabiliyor.
Ancak kısayol seçerek bu kısayolun path'ini almak istediğimde bu mümkün olmuyor.

Yaptığım program vbscript dilinde.Dolayısıyla kısmen vba ya yakın.Yardımcı olabilecek kimseler olduğunu düşünüyorum.

Bu işlemi yapabilecek bir fonksiyon önermek isteyen arkadaşlara teşekkür ederim.

 

[Korhan Ayhan]

Biraz araştırdım ve aşağıdaki kodu buldum. Deneyiniz.

Link; http://www.vbforums.com/showthread.php?625141-RESOLVED-Excel-Using-VBA-to-open-a-file-shortcut

Sub GetLinkPath()
    MsgBox Getlnkpath("C:\Your Path to Short Cut\Shortcut Name.lnk")
 End Sub
 
 Function Getlnkpath(ByVal Lnk As String)
    On Error Resume Next
    With CreateObject("Wscript.Shell").CreateShortcut(Lnk)
        Getlnkpath = .TargetPath
        .Close
    End With
 End Function

 

[excelokyanus500]

strComputer = "."

 Const ALL_OPTIONS = &H4000

Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")

Set objShell = CreateObject("Shell.Application")

Set objFolder = objShell.BrowseForFolder (0, "Klasörü Seçin:",ALL_OPTIONS,(16))

If objFolder Is Nothing Then

Wscript.Quit

Else

Set objFolderItem = objFolder.Self

objPath = objFolderItem.Path

End If


objStartFolder = objFolder.Self

Sizin verdiğiniz kodu bu kod ile birleştirebilir miyiz ?
Ancak program vbscript olduğu için verdiğiniz kodun vbscripte uyarlanması gerekiyor.

Örneğin(Sadece örnektir, çalışmıyor);

strComputer = "."
Const ALL_OPTIONS = &H4000

Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")

Set objShell = CreateObject("Shell.Application")

Set objFolder = objShell.BrowseForFolder (0, "Klasörü Seçin:",ALL_OPTIONS,(16))


   Set fso = CreateObject("Scripting.FileSystemObject")
Set sh  = CreateObject("WScript.Shell")

shortcut = objFolder

Set lnk = sh.CreateShortcut(shortcut)
If fso.FolderExists(lnk.TargetPath) Then
  'target doesn't exist or is not a folder
  Set objFolderItem= lnk.TargetPath
End If


If objFolder Is Nothing Then

Wscript.Quit

Else

Set objFolderItem = objFolder.Self



End If


objPath = objFolderItem.Path