Ekran çözünürlüğünü sayfalara göre otomatik ayarlama

klop01

Altın Üye
Katılım
19 Aralık 2016
Mesajlar
638
Excel Vers. ve Dili
2021 Türkçe 64 Bit
Altın Üyelik Bitiş Tarihi
07-02-2028
Değerli arkadaşlar,
Ekteki belgede açıklamasını yaptığım konuda yardıma ihtiyacım var.
Konu kısaca şöyle: Bir excel sayfasındaki sayfaların ekran çözünürlüğüne göre istenilen yakınlaştırma oranı ile açılması konusu.

http://s7.dosya.tc/server5/v7xg2x/ekran_cozunurlugu.rar.html

DOSYADAKİ KODLAR:
Bu Çalışma Sayfasında
Kod:
Private Sub Workbook_Open()
ekrancozunurlugu
End Sub
Modülde
Kod:
Option Explicit
Type RECT
x1 As Long
y1 As Long
x2 As Long
y2 As Long
End Type

#If VBA7 And Win64 Then
Declare PtrSafe Function GetDesktopWindow Lib "User32" () As Long
Declare PtrSafe Function GetWindowRect Lib "User32" (ByVal hWnd As Long, rectangle As RECT) As Long
#Else
Declare Function GetDesktopWindow Lib "User32" () As Long
Declare Function GetWindowRect Lib "User32" (ByVal hWnd As Long, rectangle As RECT) As Long
#End If


Function ekrancozunurlugu() As String
Dim R As RECT
Dim hWnd As Long
Dim RetVal As Long
hWnd = GetDesktopWindow()
RetVal = GetWindowRect(hWnd, R)
ekrancozunurlugu = (R.x2 - R.x1) & "x" & (R.y2 - R.y1)
If ekrancozunurlugu = "3840x2160" Then ActiveWindow.Zoom = 330
If ekrancozunurlugu = "3440x1440" Then ActiveWindow.Zoom = 276
If ekrancozunurlugu = "2560x1440" Then ActiveWindow.Zoom = 216
If ekrancozunurlugu = "2560x1080" Then ActiveWindow.Zoom = 216
If ekrancozunurlugu = "1920x1080" Then ActiveWindow.Zoom = 169
If ekrancozunurlugu = "1680x1050" Then ActiveWindow.Zoom = 146
If ekrancozunurlugu = "1600x1200" Then ActiveWindow.Zoom = 140
If ekrancozunurlugu = "1600x900" Then ActiveWindow.Zoom = 140
If ekrancozunurlugu = "1440x900" Then ActiveWindow.Zoom = 126
If ekrancozunurlugu = "1400x1050" Then ActiveWindow.Zoom = 122
If ekrancozunurlugu = "1366x768" Then ActiveWindow.Zoom = 119
If ekrancozunurlugu = "1360x768" Then ActiveWindow.Zoom = 119
If ekrancozunurlugu = "1280x1024" Then ActiveWindow.Zoom = 112
If ekrancozunurlugu = "1280x960" Then ActiveWindow.Zoom = 112
If ekrancozunurlugu = "1280x800" Then ActiveWindow.Zoom = 112
If ekrancozunurlugu = "1280x768" Then ActiveWindow.Zoom = 112
If ekrancozunurlugu = "1280x720" Then ActiveWindow.Zoom = 112
If ekrancozunurlugu = "1280x600" Then ActiveWindow.Zoom = 112
If ekrancozunurlugu = "1152x864" Then ActiveWindow.Zoom = 101
If ekrancozunurlugu = "1024x768" Then ActiveWindow.Zoom = 90
If ekrancozunurlugu = "800x600" Then ActiveWindow.Zoom = 71
End Function
 

Ekli dosyalar

Zeki Gürsoy

Uzman
Uzman
Katılım
31 Aralık 2005
Mesajlar
4,349
Excel Vers. ve Dili
Office 365 (64 bit) - Türkçe
Açılışta sayfaları teker teker aktif yaparak zom kodunu çalıştırın. Örnek:

Kod:
Sub Test()
    Dim sh As Worksheet, sh2 As Worksheet
    
    Set sh2 = ActiveSheet
    
    Application.ScreenUpdating = False
    
    For Each sh In ThisWorkbook.Worksheets
        sh.Activate
        ThisWorkbook.Windows(1).Zoom = 120
    Next
    
    sh2.Activate
    
    Application.ScreenUpdating = False
    
End Sub
.
 

klop01

Altın Üye
Katılım
19 Aralık 2016
Mesajlar
638
Excel Vers. ve Dili
2021 Türkçe 64 Bit
Altın Üyelik Bitiş Tarihi
07-02-2028
Zeki Hoca'm,
Bu kodları nere yazmalıyım?
"Açılışta sayfaları teker teker aktif yaparak zom kodunu çalıştırın." derken bir butona mı bağlanmalı?

Birinci mesajımda verdiğim kodları internetten bulmuştum. Kodlama konusunda bilgim pek yok.
Konuyu tam olarak anlayamadım.
 

Zeki Gürsoy

Uzman
Uzman
Katılım
31 Aralık 2005
Mesajlar
4,349
Excel Vers. ve Dili
Office 365 (64 bit) - Türkçe
"Workbook_Open" olayını değiştirerek şöyle kullanabilirsiniz mesela...

Kod:
Private Sub Workbook_Open()
    Dim sh As Worksheet, sh2 As Worksheet
    
    Set sh2 = ActiveSheet
    
    Application.ScreenUpdating = False
    
    For Each sh In ThisWorkbook.Worksheets
        sh.Activate
        [COLOR=Blue][B]ekrancozunurlugu[/B][/COLOR]
    Next
    
    sh2.Activate
    
    Application.ScreenUpdating = False
    
End Sub
.
 

klop01

Altın Üye
Katılım
19 Aralık 2016
Mesajlar
638
Excel Vers. ve Dili
2021 Türkçe 64 Bit
Altın Üyelik Bitiş Tarihi
07-02-2028
Son kodla beraber tüm sayfalar ekran çözünürlüğüne göre açılabiliyor.
Ekteki belgedeki sorumda farklı birkaç türde sayfam var. Farklı yakınlaştırma oranlarında açılması gereken.
Tüm sayfalar aynı oranda değil
sayfa1, 2,, 3 aynı açılma oranı
sayfa4, 5 yukarıdakilerden faklı oran
sayfa 6, 7, 8 farklı oran gibi

Bu yapılabilir mi?
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,250
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Merhaba,

Eklediğiniz dosyada düzenleme yaptım. Sizin sadece fonksiyonun içinde hangi ekran çözünürlüğünde hangi sayfa zoom ayarını kullanmak istiyorsanız onu belirtmeniz yeterli olacaktır.
 

Ekli dosyalar

klop01

Altın Üye
Katılım
19 Aralık 2016
Mesajlar
638
Excel Vers. ve Dili
2021 Türkçe 64 Bit
Altın Üyelik Bitiş Tarihi
07-02-2028
Sayın Korhan AYHAN,
Çok teşekkür ederim; ellerinize, bilginize sağlık.
Emek verip uğraşmışsınız. İstediğim sonucu tam olarak alıyorum, sağ olunuz.

Dosyada şöyle bir şey oluyor.
İnternet'ten indirilen dosyalar korumalı görünümde geliyor. “Düzenlemeyi Etkinleştir” deyince dosyada aşağıdaki hata mesajı oluşuyor.
Hataya "TAMAM" denince dosyadaki kodlar çalışıyor. Bu durum sadece “Düzenlemeyi Etkinleştir” deyince oluyor. Korumalı görünümü kaldırınca dosya normal çalışıyor, hata vermiyor.
Benim monitörüm 1920x1080 çözünürlükte. Hata mesajı da sadece bu çözünürlük için gözüküyor.

Bu konuda bir şey yapabilir miyiz?

 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,250
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Merhaba,

Eklediğim dosyayı yeniden indirip denedim. Bende de dosya korumalı görünümde açılıyor. Uyarıları etkinleştirerek açtığımda bahsettiğiniz hata bende oluşmadı.
 

klop01

Altın Üye
Katılım
19 Aralık 2016
Mesajlar
638
Excel Vers. ve Dili
2021 Türkçe 64 Bit
Altın Üyelik Bitiş Tarihi
07-02-2028
Cevabınız için tekrar teşekkürler.

Yarın bir okulda deneyeyim bakayım. Benim bilgisayarda veya ofiste mi bir şey var.

6. MESAJDAKİ DOSYAYA BAKAN ARKADAŞLAR HATA VERİP VERMEDİĞİNİ YAZABİLİRLERSE İYİ OLUR.
 

tahsinanarat

Altın Üye
Katılım
14 Mart 2005
Mesajlar
2,164
Excel Vers. ve Dili
Ofis 2019 Türkçe
Altın Üyelik Bitiş Tarihi
27-05-2028
Sn. klop01, Ben denedim herhangi bir hata almadım, bilginize.
 

klop01

Altın Üye
Katılım
19 Aralık 2016
Mesajlar
638
Excel Vers. ve Dili
2021 Türkçe 64 Bit
Altın Üyelik Bitiş Tarihi
07-02-2028
Sayın tahsinanarat,
Teşekkür ederim, sağ olun.
 
Üst