كيفية تغيير دقى الشاشة

رقم 1

ثبات حجم النموذج مع تغير دقة الشاشة

ضع هذا الكود في Moudel جديد

Public Xtwips As Integer, Ytwips As Integer 
Public Xpixels As Integer, Ypixels As Integer 


Type FRMSIZE 
   Height As Long 
   Width As Long 
End Type 

Public RePosForm As Boolean 
Public DoResize As Boolean 

Sub Resize_For_Resolution(ByVal SFX As Single, _ 
 ByVal SFY As Single, MyForm As Form) 
Dim I As Integer 
Dim SFFont As Single 

SFFont = (SFX + SFY) / 2  ' average scale 
' Size the Controls for the new resolution 
On Error Resume Next  ' for read-only or nonexistent properties 
With MyForm 
  For I = 0 To .Count - 1 
   If TypeOf .Controls(I) Is ComboBox Then   ' cannot change Height 
     .Controls(I).left = .Controls(I).left * SFX 
     .Controls(I).top = .Controls(I).top * SFY 
     .Controls(I).Width = .Controls(I).Width * SFX 
   Else 
     .Controls(I).Move .Controls(I).left * SFX, _ 
      .Controls(I).top * SFY, _ 
      .Controls(I).Width * SFX, _ 
      .Controls(I).Height * SFY 
   End If 
     .Controls(I).FontSize = .Controls(I).FontSize * SFFont 
  Next I 
  If RePosForm Then 
    ' Now size the Form 
    .Move .left * SFX, .top * SFY, .Width * SFX, .Height * SFY 
  End If 
End With 
End Sub 


ضع هذا الكود في النافذة مع وضع أداة Label أداة Command أي أدوات أخري تريد تجربتها 

' 4) Add a Module from the Project menu and paste in the following code: 

Public Xtwips As Integer, Ytwips As Integer 
Public Xpixels As Integer, Ypixels As Integer 


Type FRMSIZE 
   Height As Long 
   Width As Long 
End Type 

Public RePosForm As Boolean 
Public DoResize As Boolean 

Sub Resize_For_Resolution(ByVal SFX As Single, _ 
 ByVal SFY As Single, MyForm As Form) 
Dim I As Integer 
Dim SFFont As Single 

SFFont = (SFX + SFY) / 2  ' average scale 
' Size the Controls for the new resolution 
On Error Resume Next  ' for read-only or nonexistent properties 
With MyForm 
  For I = 0 To .Count - 1 
   If TypeOf .Controls(I) Is ComboBox Then   ' cannot change Height 
     .Controls(I).left = .Controls(I).left * SFX 
     .Controls(I).top = .Controls(I).top * SFY 
     .Controls(I).Width = .Controls(I).Width * SFX 
   Else 
     .Controls(I).Move .Controls(I).left * SFX, _ 
      .Controls(I).top * SFY, _ 
      .Controls(I).Width * SFX, _ 
      .Controls(I).Height * SFY 
   End If 
     .Controls(I).FontSize = .Controls(I).FontSize * SFFont 
  Next I 
  If RePosForm Then 
    ' Now size the Form 
    .Move .left * SFX, .top * SFY, .Width * SFX, .Height * SFY 
  End If 
End With 
End Sub

تغيير حجم النموذج بتغير دقة عرض الشاشة

Public Function ResizeForm() 
On Error Resume Next            ' O'God..  Do not terminate in case of error,  Pardon Me.. 
Dim nI As Integer 
Dim ctl As Object, frm As Object 
Dim nW As Long, nH As Long 
Dim nHRatio As Single, nWRatio As Single 

' ------ First Determine which form is Active now..  ------ 
' ------ I normaly Disabel all forms other than Current form in my Projects. ------ 
For Each frm In Forms 
       If frm.Enabled Then 
           Set frm = frm.Name 
           Exit For 
       End If 
Next 

' ------ Following ratios are based on assumption that U R Desigining forms at 800 X 600 Resolution 
nW = Screen.Width: nH = Screen.Height 
nWRatio = nW / 12000: nHRatio = nH / 9000 

If nWRatio = 1 Then 
    ' ------ No need to resize form if Ration is Unity. 
    frm.Left = 0: frm.Top = 0 
    frm.WindowState = 2     ' Max. Size. 
    GoTo EndResize 
Else 
    MsgBox "Resizing Form to Suit to Screen Size.. " & vbNewLine & "Please Press Any Key.." 
    frm.WindowState = vbNormal 
End If 

frm.Width = nW: frm.Height = nH 
frm.Left = -50: frm.Top = -50 

For nI = 0 To frm.Controls.Count - 1 
    Debug.Print frm.Controls(nI).Left 
    Debug.Print frm.Controls(nI).Name 
    Set ctl = frm.Controls(nI) 
    ' ------ Now Depending on control type, set its Top, left, Height and Width properties. 

     ctl.Left = ctl.Left * nWRatio: ctl.Top = ctl.Top * nHRatio 
     ctl.Width = ctl.Width * nWRatio: ctl.Height = ctl.Height * nHRatio 

    If TypeOf ctl Is TextBox Or TypeOf ctl Is ComboBox Or TypeOf ctl Is Label Or TypeOf ctl Is Frame Then 
        ctl.FontSize = ctl.FontSize * nWRatio 
    End If 
    If TypeOf ctl Is CommandButton Then 
        ctl.FontSize = ctl.FontSize * nWRatio 
    End If 
    If TypeOf ctl Is Line Then  ' Graphic Controls.. 
        ctl.X1 = ctl.X1 * nWRatio: ctl.Y1 = ctl.Y1 * nHRatio 
        ctl.X2 = ctl.X2 * nWRatio: ctl.Y2 = ctl.Y2 * nHRatio 
    End If 
Next 

frm.Refresh 
EndResize: 
End Function

تحديد دقة ألوان الشاشة

'Insert the following code to your form: 

Private Const PLANES& = 14 
Private Const BITSPIXEL& = 12 
Private Declare Function GetDeviceCaps& Lib "gdi32" (ByVal hdc As Long, _ 
ByVal nIndex As Long) 
Private Declare Function GetDC& Lib "user32" (ByVal hwnd As Long) 
Private Declare Function ReleaseDC& Lib "user32" (ByVal hwnd As Long, _ 
ByVal hdc As Long) 

Private Function ColorDepth() As Integer 
Dim nPlanes As Integer, BitsPerPixel As Integer, dc As Long 
dc = GetDC(0) 
nPlanes = GetDeviceCaps(dc, PLANES) 
BitsPerPixel = GetDeviceCaps(dc, BITSPIXEL) 
ReleaseDC 0, dc 
ColorDepth = nPlanes * BitsPerPixel 
End Function 

Private Sub Form_Load() 
MsgBox ColorDepth & " Bit" 
End Sub

اداه هامه جدا جدا تغيير دقة عرض الشاشة

اسم الأداة: MicroTech Labs - Change Screen Resolution .. حجمها: 38 ك ب.

وظيفتها: تغيير دقة عرض الشاشة.

طريقة الاستخدام:

للتحويل إلى 800 * 600

ChangeRes1.Xpixels = 800

ChangeRes1.Ypixels = 600

ChangeRes1.ChangeResolution = True

ChangeRes.rar

مشكوووووووووووووور اخي

مشكووور ويعطيك العافية

يعطيك العافيه أخي الفاضل walled_aall@hot

وجزيت كل الخير

هذا كود بسيط لتغيير دقة الشاشة و ذلك باستدعاء API

الملف مرفق

و السلام عليكم :)

Resolution.zip