• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

UserForm boyutlandırma yada kaydırma hk.

K

kadirdaylight

Katılım
15 Ağustos 2009
Mesajlar
127
Excel Vers. ve Dili
Office 2010 Tr
Herkese kolaylıklar diliyorum.. Bulunduğum iş yerinde genelde herkes aynı tip pc ve monitör kullanıyor. Bende buna göre bir veri dosyası hazırladım (oldukça kapsamlı) fakat sonradan fark ettim ki bazı kişilerin monitörleri diktörtgen olduğu için kare monitörde hazırlanan formların boyutları büyük geliyor.

Ekteki örnek dosya boyutunda birkaç userform'a sahibim. Bunları farklı çözünürlükteki pc lerde açtığımızda en alttaki butonlar görünmüyor dolayısı ile program ne kapanıyor ne ilerletilebiliyor. Bunu otomatik boyutlandırabileceğim yada kaydırma çubuğu ile nasıl yapabileceğimi söyleyebilirseniz çok sevinirim. Şimdiden teşekkürler
 

Ekli dosyalar

Bununla Tam Ekran Yapabilirsin...

Kod: 
Private Sub UserForm_Initialize()
    With UserForm1
        .Height = Application.Height
        .Width = Application.Width
    End With
End Sub
 
İlginiz için teşekkürler ancak sorunu çözümlemiyor.. Farklı bir öneri olan var mı?
 
Kardeşim bu kodu userform Initialize olayına ekle. kesin çözüm :)) benim evdeki pc dikdötgen işyerindeki ise kare. tüm userformdaki görüntüleri orantılı olarak büyütüyor veya ufaltıyor.. selametle


Kod: 
Private Sub UserForm_Initialize()
Dim X1 As Long, Y1 As Long, Y2 As Long, X2 As Long
Dim CX As Double, CY As Double
Dim MyCtrl As Control
X1 = Application.Width
Y1 = Application.Height
X2 = Me.Width
Y2 = Me.Height
CX = X1 / X2
CY = Y1 / Y2
Me.Width = X1
Me.Height = Y1
For Each MyCtrl In Me.Controls
MyCtrl.Top = MyCtrl.Top * CY
MyCtrl.Left = MyCtrl.Left * CX
MyCtrl.Width = MyCtrl.Width * CX
MyCtrl.Height = MyCtrl.Height * CY
On Error Resume Next
MyCtrl.Font.Size = MyCtrl.Font.Size * CY
On Error GoTo 0
Next
End Sub
 
forma 1 adet Frame9 ekledim ve bütün nesneleri de unun içine koydum ve Frame9 un zom ayarını da 82 yaptım
UserForm1.Width = 553 bunu yaptım
UserForm1.Height = 480 bunu yaptım

userform1 kodları

Kod: 
#If Win64 Then
Private Declare PtrSafe Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function SetWindowLong Lib "User32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare PtrSafe Function SetWindowPos Lib "User32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal CX As Long, ByVal CY As Long, ByVal wFlags As Long) As Long
Private Declare PtrSafe Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function GetActiveWindow Lib "user32.dll" () As Long
Private Declare PtrSafe Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare PtrSafe Function DrawMenuBar Lib "User32" (ByVal hWnd As Long) As Long
#Else
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal CX As Long, ByVal CY As Long, ByVal wFlags As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetActiveWindow Lib "user32.dll" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
#End If

#If VBA7 Then

#Else

#End If


Private gen As Single
Private yuk As Single
Dim kolon1(5000)
Dim kolon2(5000)
Dim kolon3(5000)
Dim kolon4(5000)
Dim kolon5(5000)
Dim kolon6(5000)
Dim kolon7(5000)


Private Sub UserForm_Resize()
Dim i As Integer
Dim genis As Single
Dim yuksek As Single

genis = Me.Width / gen
yuksek = Me.Height / yuk

Dim Kontrol As Control
For Each Kontrol In Me.Controls
i = i + 1

Kontrol.Height = yuksek * kolon1(i)
Kontrol.Width = genis * kolon2(i)
Kontrol.Top = yuksek * kolon3(i)
Kontrol.Left = genis * kolon4(i)
On Error Resume Next
Kontrol.Font.Size = yuksek * kolon5(i)


If TypeName(Kontrol) = "ListBox" Then
If Controls(Kontrol.Name).ColumnCount > 0 Then
For j = 1 To Worksheets(ActiveSheet.Name).Cells(1, 256).End(xlToLeft).Column
k = k + 1
yer = genis * kolon6(k)
deg = deg & CLng(yer) & ";"
Next
Controls(Kontrol.Name).ColumnWidths = deg
End If
End If

If TypeName(Kontrol) = "ListView" Then
If Controls(Kontrol.Name).ColumnHeaders.Count > 0 Then
For r = 1 To Controls(Kontrol.Name).ColumnHeaders.Count + 1
j = j + 1
Controls(Kontrol.Name).ColumnHeaders(r - 1).Width = genis * kolon7(r)
Next
End If
End If


Next
End Sub


Private Sub UserForm_Activate()

Dim Kontrol As Control
For Each Kontrol In Me.Controls
i = i + 1
kolon1(i) = Kontrol.Height
kolon2(i) = Kontrol.Width
kolon3(i) = Kontrol.Top
kolon4(i) = Kontrol.Left
On Error Resume Next
kolon5(i) = Kontrol.Font.Size

If TypeName(Kontrol) = "ListBox" Then
If Controls(Kontrol.Name).ColumnCount > 0 Then
For a = 1 To Worksheets(ActiveSheet.Name).Cells(1, 256).End(xlToLeft).Column
k = k + 1
kolon6(k) = Sheets(ActiveSheet.Name).Columns(a).Width
Next
End If
End If

If TypeName(Kontrol) = "ListView" Then
If Controls(Kontrol.Name).ColumnHeaders.Count > 0 Then
For r = 1 To Controls(Kontrol.Name).ColumnHeaders.Count + 1
j = j + 1
kolon7(j) = Controls(Kontrol.Name).ColumnHeaders(r - 1).Width
Next
End If
End If

Next

gen = Me.Width
yuk = Me.Height
Dim hWnd As Long
hWnd = FindWindow(vbNullString, Me.Caption)
SetWindowLong hWnd, -16, GetWindowLong(hWnd, -16) Or &H10000 _
Or &H20000 Or &H40000

With Application
Me.Top = .Top
Me.Left = .Left
Me.Height = .Height
Me.Width = .Width
End With
End Sub


Private Sub CommandButton1_Click()
Unload UserForm1
End Sub

Private Sub CommandButton2_Click()
Unload UserForm1
Application.Visible = True
End Sub
 

Ekli dosyalar

kodu bulamadıkları için sanırım bu paylalımı yapmak zorunda kaldım haluk hocam :) amaç vana yardımcı olunduğu gibi başkalarınada yardımcı olmak saygılar :)
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst