Kısayol Oluşturma

[m.ensar]

Hocalarım ağda bir bilgisayar üzerinde klasör ve excell kitaplarını paylaşıma aldığımızda diğer bilgisayarlar bu klasör veya excel kitabını paylaşım klasörü üzerinde çek bırak yöntemi ile kendi bilgisayarlarına alıyorlar ve maalesef bazı arkadaşlar bunun kısayol olduğunu düşünerek bu dosya üzerinde işlem yapıyorlar anlatıp göstermemize rağmen bu konu da ısrarcılar. Meramım paylaşım yapılan bilgisayardaki excel veya klasörü kendi masaüstlerine veya bilgisayarlarına çektiklerinde otomatik olarak kısayol yapılabilir mi?
bunun bir yöntemi var mı?

 

[ccuneyt13]

Merhaba,
Teknik olarak imkan varmı bilmiyorum ama aynı dert bizde de oluyor ben şöyle yapıyorum,
Diyelim ortak alanda ana dosyanız Paylaşım isimli bir klasörde, diğer kişiler bu ortak klasöre girip dosyayı açıyorlar yada masaüstüne kısayol diye gerçek dosyanın kopyasını yada tamamını alıyorlar, siz diğer kişilerin alacağı ortak klasörün içine dosyanızın kısayolunu koyun.
Ana dosyanız başka bir alanda ama yine diğerlerinin ağdan erişim yetkisi olacağı ama bulamayacağı bir yerde olsun.
Siz onların görsel olarak ulaşabileceği ortak klasör içine dosyanın kısayolunu koyun.
Açacaklarsa kısayoldan açsınlar masaüstüne alacaklarsa da zaten kısayolu almış olsunlar.

 

[RBozkurt]

Herkesin aynı dizine aynı şekilde bağlandığını varsayarak; dosyayı paylaşım olan dizinde sabit bir yere atın, kendi bilgisayarınıza kısayol oluşturun ve bu kısayolu paylaşıma koyun. Sürükle bırak yapanlar kısayolu alacak ve ana dosya çalışacaktır.

 

[m.ensar]

Cüneyt üstadım ve Bozkurt üstadım önerileriniz için teşekkür ederim o yoluda denedim o kısayol üzerine sağ tıklayıp dosya konumunu aç diyerek asıl dosyanın yerini bulan arkadaş ne hikmetse dosyayı kendi bilgisayarına alırken kısayol olarak almayı başaramıyor yada işine gelmiyor yine de en sağlıklısı şimdilik bu şekil görünüyor çok teşekkürler

 

[Biolightant]

Merhaba,
Olası kurgu,
BuÇalışmaKitabı(ThisWorkbook) da Private Sub Workbook_Open()

    ' OLMASI GEREKEN KONUM (UNC formatında)
    targetPath = "\\ServerName...\SharedFolder...\SubFolder...\file.xlsm"
 
    ' Aktif çalışma kitabının yolu
    currentPath = ActiveWorkbook.FullName

karşılaştırma yapılıp aynı değilse .................... ( nokta noktalar ) yapılıp sonda da Excel kapatılır.

 

[m.ensar]

Biolightant üstadım hayırlı günler unc formatını araştırdım biraz, bilgimin olmadığı bir konu kodlarınızı da dolayısıyla deneyemedim. çok teşekkür ediyorum ilginiz için. Standart şekil excel açtım çalışma kitabının kod sayfasına kodları ekledim dediğiniz şekil yolu da belirttim ancak unc mevzusuna yabancı olduğum için bir şey farketmedi

 

[Biolightant]

Merhaba @m.ensar
targetPath ve currentPath karşılaştırma ve excel kapatma hallettim,
zaman buldukca ......... ları doldurmaya çalışıyorum gelişme olunca buradan iletirim.
mesela dosya başka yerde çalıştırınca(zamanı) hangi bilgisayar, Dosya nerede, dosyayı kopyaladı mı yoksa Taşıdı mı
bunları rapor oluşturup bir txt dosyasına kaydediyorum
başka ne gibi işlemler yapılacak sizin de aklınıza fikir gelirse yazınız.

 

[Biolightant]

Merhaba yeniden,

Kodlar
BuÇalışmaKitabı (ThisWorkbook) a yazılacak

Dosya açılışta - Private Sub Workbook_Open()

1. Herhangi bir hata oluşacak olursa Dosya ve Excel KAPATILIR.
2. Dosyanın çalışması gereken konum (targetPath) ile çalıştığı konum (currentPath) aynı ise DOSYA NORMAL ÇALIŞIR.
3. targetPath ile currentPath AYNI DEĞİLSE
3.A. inputFilePath konumu bulunamazsa hata oluşacak Dosya ve Excel KAPATILIR.
3.B. targetPath Dosya YOK (taşınmış) veriler Hatalar.txt dosyasına KAYDEDİLİR, dosya olması gereken konuma KOPYALANIR, hatalı olan konuma Kısayol EKLENİR, Dosya ve Excel KAPATILIR.
3.C. targetPath Dosya VAR (kopyalanmış) veriler Hatalar.txt dosyasına KAYDEDİLİR, hatalı olan konuma Kısayol EKLENİR, Dosya ve Excel KAPATILIR.

Kullanıcının Kopyaladığı veya Taşıdığı Dosya artık çalışmayacak (ne zaman çalıştırmaya çalışsa kayıt edilecek)
zorunlu olarak - Kısayol yazan ı kullanacak ve bir süre sonra kopyaladığı veya taşıdığı dosyayı kendi silecektir diye düşünüyorum.

Kodların Düzgün çalışıp çalışmadığını Test edip sonucu yazarmısınız.

Private Sub Workbook_Open()
    Dim targetPath As String
    Dim inputFilePath As String
    Dim currentPath As String
    Dim uncPath As String

    On Error GoTo HataYakala
    
    ' DOSYANIN OLMASI GEREKEN KONUM (UNC formatında)
    targetPath = "\\ServerName...\SharedFolder...\SubFolder...\filename.xlsm"

    ' HATALI KULLANIMLARIN KAYDEDİLECEĞİ [ Hatalar.txt ] DOSYASI KONUMU
    inputFilePath = "\\ServerName...\SharedFolder...\SubFolder01\Hatalar.txt"

   ' VB editörü şifrelemeniz önerilir.


   ' Aktif çalışma kitabının yolu
    currentPath = ActiveWorkbook.FullName

    ' Haritalanmış sürücüyü UNC formatına çevir
    uncPath = GetUNCPath(currentPath)

    ' UNC yolu kontrol et
    If StrComp(uncPath, targetPath, vbTextCompare) <> 0 Then

        ' targetPath mevcut mu kontrol et
        If Not IsUNCPathAccessible(targetPath) Then
        
            ' inputFilePath konumu bulunamıyorsa error:76 HataYakala devreye girecek
            ' inputFilePath var, targetPath DOSYA YOK
            Call HataTXT(inputFilePath, "Dosya TAŞINMIŞ")
        
            ' TAŞINMIŞ dosyayı GERİ YERİNE KOY
            ActiveWorkbook.SaveAs Filename:=targetPath
        
            ' KısaYol oluştur
            Call ShortcutFile(currentPath, targetPath)
        
            ActiveWorkbook.Saved = True
            Application.Quit
            Exit Sub
        End If

        ' targetPath DOSYA VAR
        Call HataTXT(inputFilePath, "Dosya KOPYALANMIŞ")
    
        ' KısaYol oluştur
        Call ShortcutFile(currentPath, targetPath)

        ActiveWorkbook.Saved = True
        Application.Quit

    End If

    Exit Sub

HataYakala:
    ActiveWorkbook.Saved = True
    Application.Quit

End Sub

' Haritalanmış sürücüyü UNC yoluna dönüştüren fonksiyon
Private Function GetUNCPath(localPath As String) As String
    Dim objWMI As Object
    Dim objItem As Object
    Dim driveLetter As String
    Dim networkPath As String

    ' Haritalanmış sürücü harfini al (ör. Z:)
    driveLetter = Left(localPath, 2)

    ' WMI ile UNC yolunu al
    Set objWMI = GetObject("winmgmts:\\.\root\cimv2").ExecQuery("Select * From Win32_LogicalDisk Where DeviceID='" & driveLetter & "'")
    On Error Resume Next ' Hata durumunda işleme devam et
    For Each objItem In objWMI
        If Not IsNull(objItem.ProviderName) Then
            networkPath = objItem.ProviderName
        Else
            networkPath = ""
        End If
    Next objItem
    On Error GoTo 0 ' Hata yönetimini sıfırla

    ' UNC yolunu birleştir
    If Len(networkPath) > 0 Then
        GetUNCPath = Replace(localPath, driveLetter, networkPath)
    Else
        GetUNCPath = localPath ' Eğer UNC bulunamazsa orijinal yolu döndür
    End If
End Function

' UNC yolunun erişilebilir olup olmadığını kontrol eder
Private Function IsUNCPathAccessible(uncPath As String) As Boolean
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")

    On Error Resume Next
    ' UNC yolunun mevcut olup olmadığını kontrol eder
    If fso.FolderExists(uncPath) Or fso.FileExists(uncPath) Then
        IsUNCPathAccessible = True
    Else
        IsUNCPathAccessible = False
    End If
    On Error GoTo 0

    Set fso = Nothing
End Function

' Hatalar.txt dosyasına bilgi ekler
Private Sub HataTXT(inputFilePath As String, CopyOrCut As Variant)
    Dim fso As Object
    Dim outputFile As Object
    Dim yeniVeri As String
   
    ' Dosya sistemini ayarla
    Set fso = CreateObject("Scripting.FileSystemObject")
      
    ' Yeni veriyi hazırla (Zaman, Dosyanın Konumu, Yapılan İşlem)
    yeniVeri = Now() & ", Hatalı Dosya: " & ActiveWorkbook.FullName & ", Yapılan: " & CopyOrCut
   
    ' Dosyayı aç ve yeni veriyi ekle (Dosya yoksa oluştur ve ekle)
    Set outputFile = fso.OpenTextFile(inputFilePath, 8, True)
    outputFile.WriteLine yeniVeri
   
    ' Dosyayı kapat ve nesneleri temizle
    outputFile.Close
    Set outputFile = Nothing
    Set fso = Nothing
End Sub

' Kısayol oluştur
Private Sub ShortcutFile(KisayolYeri As String, KisayolDosya As String)
       
        Dim wsh As Object
        Dim shortcutPath As String
    
        ' Kısayolun oluşturulacağı yer
        shortcutPath = KisayolYeri & " - Kısayol.lnk"
    
        ' Windows Scripting Host nesnesi oluştur
        Set wsh = CreateObject("WScript.Shell")
    
        ' Kısayol oluştur
        With wsh.CreateShortcut(shortcutPath)
            .targetPath = KisayolDosya
            .Save
        End With
    
        ' Windows Scripting Host nesnesini serbest bırak
        Set wsh = Nothing
End Sub

 

[m.ensar]

Hocam merhaba;
"\\ServerName...\SharedFolder...\SubFolder...\filename.xlsm"
bu satırlara kendi dosya yolumu yazmam gerekir mi?
kodu olduğu gibi değişiklik yapmadan mı kullanayım

 

[m.ensar]

Dosya yolunu değiştirerek ve değiştirmeyerek her iki denemede exceli açmak istediğimde açılmadığı gibi açık excel dosyalarım varsa onları da kapatıyor hocam

 

[m.ensar]

ağ üzerinde bir bilgisayarda kısayolu yada dosyayı çekip bıraktığımda da hiç açılmıyor ve açık olan excel var ise kapatıyor

 

[Biolightant]

Sanırım 3.A. ya takıldınız, özel mesaj a bakarmısınız.

 

[m.ensar]

bu tarz sorunu olan arkadaşlar Biolightant üstadımın kodları gayet güzel çalışıyor çok teşekkür ederim hocam yukarıda yazdığım hatalar kendimden kaynaklı olduğunu da özelden teyit ederek düzeltti örnek bir çalışma ekliyorum. Kullanıcı dosyayı masaüstüne veya kendi bilgisayarında bir yere taşıdığında dosya açılacakmış gibi oluyor fakat açılmıyor ve kısayolunu oluşturuyor o kısayoldan çalışabiliyor kullanıcı.
Hocam tekrar çok teşekkür ederim

 

[m.ensar]

çek bırak yöntemi ile açıldığında kısayol oluştururken kes yapıştır yöntemiyle alınan dosya ise ilk açılışta kapanıp kendini ait olduğu yere gönderiyor ve yine kısayolunu atıyor hocam tekrar çok teşekkür ederim.

 

[Biolightant]

Rica ederim, kodların işe yaramasına sevindim

Başka test edecek arkadaşlar için,

Bir tane boş excel dosyası oluşturun ismi TEST.xlsm olsun
bu TEST.xlsm dosyasına aşağıdaki makroyu ekleyip

TEST.xlsm dosyasını paylaşımda bulunduğunuz ağ klasörün içine yerleştirip ve makroyu çalıştırın
A1 hücresine dosyanın adresini UNC formatına çevirip yazacaktır

Bu adrese göre targetPath ve inputFilePath klasör yollarını düzenleyiniz

Sub UNCAdres()
    Range("A1").Value = GetUNCPath(ActiveWorkbook.FullName)
End Sub

' Haritalanmış sürücüyü UNC formatına çevir
Private Function GetUNCPath(localPath As String) As String
    Dim objWMI As Object
    Dim objItem As Object
    Dim driveLetter As String
    Dim networkPath As String

    ' Haritalanmış sürücü harfini al (ör. Z:)
    driveLetter = Left(localPath, 2)
 
    ' WMI ile UNC yolunu al
    Set objWMI = GetObject("winmgmts:\\.\root\cimv2").ExecQuery("Select * From Win32_LogicalDisk Where DeviceID='" & driveLetter & "'")
    On Error Resume Next ' Hata durumunda işleme devam et
    For Each objItem In objWMI
        If Not IsNull(objItem.ProviderName) Then
            networkPath = objItem.ProviderName
        Else
            networkPath = ""
        End If
    Next objItem
    On Error GoTo 0 ' Hata yönetimini sıfırla

    ' UNC yolunu birleştir
    If Len(networkPath) > 0 Then
        GetUNCPath = Replace(localPath, driveLetter, networkPath)
    Else
        GetUNCPath = localPath ' Eğer UNC bulunamazsa orijinal yolu döndür
    End If
End Function