Sürücü Kontrolü

[cevatyildiz]

Merhaba,

Eger kaydedilecek sürücü yok ise masaüstünde raporlar adlı bir klasörün içine kaydedilebilir mi? Klasör yoksa yaratsın lütfen. Sanırım sürücünün varlığını kontrol edebilecegimiz özel bir kod vardı?

Sub SaveWithVariableFromCell()
    Dim SaveName As String
    Dim Dosya As String
    SaveName = ActiveSheet.Range("AZ18").Text
Start:
    Dosya = "O:\Technician_Reports\" & Date & "-" & SaveName & ".xlsm"
    If Not Dir(Dosya) = "" Then
        If MsgBox(Dosya & " bu dosya zaten var üzerine kaydetmek istiyor musunuz?", vbYesNo + vbQuestion) = vbNo Then Exit Sub
    End If
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:=Dosya
    Application.DisplayAlerts = True

    Dim s As Variant
    s = Format(Date) & Range("AZ18").Value
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="O:\Technician_Reports\" & s & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties _
    :=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
End Sub

 

[cevatyildiz]

Fikri olan var mıdır?

 

[muratboz06]

Kodunuzdaki Dosya = "O:\Technician_Reports\" & Date & "-" & SaveName & ".xlsm" satırından sonra aşağıdaki kodları ekleyiniz.

Dim Klasor As String  'bunu kodun başına eklersiniz.
Klasor = "O:\Technician_Reports\"
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.DriveExists("O") = False Then
Dim oWSHShell As Object
Set oWSHShell = CreateObject("WScript.Shell")
GetDesktop = oWSHShell.SpecialFolders("Desktop") & "\Raporlar"
  
  If fso.FolderExists(GetDesktop) = False Then
  fso.CreateFolder GetDesktop
  End If
Dosya = GetDesktop & "\" & Date & "-" & SaveName & ".xlsm"
Klasor = GetDesktop & "\"
End If

Kodunuzadki ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="O:\Technician_Reports\" & s & ".pdf", ifadesini
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= Klasor & s & ".pdf", olarak değiştiriniz.

 

[Korhan Ayhan]

Bende yazmıştım. Alternatif olsun.

Sub SaveWithVariableFromCell()
    Dim SaveName As String, Yol As String
    Dim Dosya As String, Surucu As String
    
    SaveName = ActiveSheet.Range("AZ18").Text
    Surucu = "O:\"
    
Start:
    If Not CreateObject("Scripting.FileSystemObject").DriveExists(Surucu) Then
        MsgBox Surucu & " isimli sürücü bulunamadı!" & Chr(10) & Chr(10) & _
               "Dosyanız masaüstündeki ""Raporlar"" klasörüne kaydedilecektir.", vbCritical
        
        Yol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & Application.PathSeparator & "Raporlar"
        If Dir(Yol, vbDirectory) = "" Then MkDir (Yol)
        Yol = Yol & Application.PathSeparator
        Dosya = Yol & Date & "-" & SaveName & ".xlsm"
        GoTo 10
    Else
        Yol = "O:\Technician_Reports\"
        Dosya = Yol & Date & "-" & SaveName & ".xlsm"
10      If Not Dir(Dosya) = "" Then
            If MsgBox(Dosya & " bu dosya zaten var üzerine kaydetmek istiyor musunuz?", vbYesNo + vbQuestion) = vbNo Then Exit Sub
        End If
        Application.DisplayAlerts = False
        ActiveWorkbook.SaveAs Filename:=Dosya
        Application.DisplayAlerts = True
    
        Dim s As Variant
        s = Format(Date) & Range("AZ18").Value
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Yol & s & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties _
        :=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
    End If
End Sub

 

[cevatyildiz]

Tek kelime ile Mükemmel!
Ellerinize saglik diyorum. Tesekkur ederim...