Sayfada Düzeni özelleştirilmiş Renkler

[hamitalper]

diğer bilgisayarlarda bu şekilde yolubende bu şekilde hocam ilgisi olabilir mi

 

[Muzaffer Ali]

Hata veren bilgisayarda 123.xml dosyasını arayıp buldunuz mu? Var mı? Varsa bulunduğu klasörün adresini benimle paylaşın.

 

[hamitalper]

bu şekilde var var hocam 123 dosyası, adresi resimdeki gibi karalanmış yerde "y.fatih.tekin" yazıyor

 

[Muzaffer Ali]

"Templates" klasörünün adı o bilgisayarda "Şablonlar" yazıyor.

 

[hamitalper]

aynen hocam bende şablonlar olarak denedim diğer bilgisayarda ilginç bir şekilde kendi bilgisayarımda çalışıyor başka bir bilgisayarda çalışmıyor

 

[Muzaffer Ali]

Aşağıdaki kodu deneyin.

Sub FormulsuzSayfa()
    Dim RaporYolAd As String
    Dim Adres As String
   
    RaporYolAd = ActiveWorkbook.Path & "\DOSYA.xlsx"
   
    Application.ScreenUpdating = False
    ActiveSheet.Copy
    ActiveSheet.Cells.Copy
    If Dir(Environ("USERPROFILE") & "\AppData\Roaming\Microsoft\Templates\Document Themes\Theme Colors\123.xml") = "" Then
        Adres = Dir(Environ("USERPROFILE") & "\AppData\Roaming\Microsoft\Şablonlar\Document Themes\Theme Colors\123.xml")
    Else
        Adres = Dir(Environ("USERPROFILE") & "\AppData\Roaming\Microsoft\Templates\Document Themes\Theme Colors\123.xml")
    End If
    ActiveWorkbook.Theme.ThemeColorScheme.Load (adres)
   
    ActiveSheet.Cells.PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    Range("A1").Select
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:=RaporYolAd, FileFormat:=xlOpenXMLWorkbook
    Application.DisplayAlerts = True
    ActiveWorkbook.Close SaveChanges:=False
    Application.ScreenUpdating = True

    Dim objOutlook As Object
    Dim objMail As Object

    ' Outlook mail oluşturma
    Set objOutlook = CreateObject("Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)

    ' Mail oluşturup dosya ekleniyor
    With objMail
        .To = "test@gmail.com" ' mail gönderilecek kişi
        .Subject = "DOSYA" ' mail konusu
        .Body = "İyi Günler Dileriz." ' mail içeriği
        .Attachments.Add RaporYolAd ' Rapor ek olarak gönderilebilir
        .Display ' E-postayı görüntüle (veya .Send ile gönder)
    End With

    ' Temizlik
    Set objMail = Nothing
    Set objOutlook = Nothing


    MsgBox "Rapor .", vbInformation, "Rapor OK"
End Sub

 

[hamitalper]

End If
ActiveWorkbook.Theme.ThemeColorScheme.Load (Environ("USERPROFILE") & "\AppData\Roaming\Microsoft\Templates\Document Themes\Theme Colors\123.xml")

bu kodda hata verdi hocam, hocam daha fazla yormak istemem sizi alakanız için çok teşekkürler hakkınızı helal edin

 

[hamitalper]

hocam sayfa düzeni - temalar - geçerli temayı kaydetsek Tema1.thmx olarak kaydedilen dosyayı bu koda işleme şansımız varmı peki alternatif çözüm olarak

If Dir(Environ("USERPROFILE") & "\AppData\Roaming\Microsoft\Templates\Document Themes\Theme Colors\123.xml") = "" Then
Adres = Dir(Environ("USERPROFILE") & "\AppData\Roaming\Microsoft\Şablonlar\Document Themes\Theme Colors\123.xml")
Else
Adres = Dir(Environ("USERPROFILE") & "\AppData\Roaming\Microsoft\Templates\Document Themes\Theme Colors\123.xml")
End If
ActiveWorkbook.Theme.ThemeColorScheme.Load (Environ("USERPROFILE") & "\AppData\Roaming\Microsoft\Templates\Document Themes\Theme Colors\123.xml")

bunun yerine

 

[Muzaffer Ali]

26 numaralı mesajdaki kodu hatalı yazmışım, düzelttim şimdi tekrar deneyin.