רזולוציה
- פותח הנושא xtaza2
- פורסם בתאריך
הנה הקוד המושלם
גדי שהתוכנית תהיה ברזולוציה של 600X800 אתה משתמש בקוד הבא: בהתחלה תיצור מודול ותכניס אלי את הקוד הזה:
גדי שהתוכנית תהיה ברזולוציה של 600X800 אתה משתמש בקוד הבא: בהתחלה תיצור מודול ותכניס אלי את הקוד הזה:
'øæåìöéä îùúðéí Private Type Resolution Width As Long Height As Long End Type Public Rwidth As Integer, Rheight As Integer 'îùúðéí ÷áåòéí áùáéì äúåëðéú Private Const HORZRES = 8 Private Const VERTRES = 10 'ôåð÷öéä ùðåúðú âéùä ìîàôééðé äîñê Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long 'ôåð÷öéä ìîöéàú äøæåìåöéä ùì äîùúîù Private Function DeviceResolution(hdc As Long) As Resolution DeviceResolution.Height = GetDeviceCaps(hdc, VERTRES) DeviceResolution.Width = GetDeviceCaps(hdc, HORZRES) End Function 'ñáøåúéðä ùîáöòú àú ùéðåé äøæåìåöéä òì äôåøåí Public Sub FitResolution(FormToFit As Object) Dim Control As Object Dim DisplayResolutin As Resolution DisplayResolutin = DeviceResolution(FormToFit.hdc) Dim W, H, MW, MH As Integer Dim I As Double, T As Double W = DisplayResolutin.Width 'äëðñú äøæåìåöéä (øåçá) ìîùúðä w H = DisplayResolutin.Height 'äëðñú äøæåìåöéä (àåøê) ìîùúðä h MW = Rwidth 'äøæåìåöéä (øåçá) ùàéúå ðáðúä äúåëðéú MH = Rheight 'äøæåìåöéä (àåøê) ùàéúå ðáðúä äúåëðéú I = (W / MW) 'äéçñ áéï øåçá äøæåìöéä ìøåçá äøæåìöéä ìäúàîä T = (H / MH) 'äéçñ áéï àåøê äøæåìåöéä ìàåøê äøæåìåöéä ìäúàîä On Error Resume Next 'ìî÷øä ùäîàôééï àéðå ÷ééí àå ìà ðéúï ìùéðåé äîùê äìàä For Each Control In FormToFit.Controls 'ìåìàä äîùðä àú äâåãì åäîé÷åí òì ëì äô÷ãéí Control.Left = Control.Left * I 'îé÷åí Control.Top = Control.Top * T 'îé÷åí Control.Width = Control.Width * I 'øåçá Control.Height = Control.Height * T 'âåáä Control.FontSize = Control.FontSize * (T) 'âåãì ôåðè 'èéôåì á÷ååéí Control.X1 = Control.X1 * I Control.X2 = Control.X2 * I Control.Y1 = Control.Y1 * T Control.Y2 = Control.Y2 * T Next Control 'çæøä òì äìåìàä 'èéôåì áèåôñ òöîå FormToFit.Left = FormToFit.Left * I 'îé÷åí äèåôñ FormToFit.Top = FormToFit.Top * T 'îé÷åí äèåôñ FormToFit.Width = FormToFit.Width * I 'øåçá äèåôñ FormToFit.Height = FormToFit.Height * T 'âåáä äèåôñ On Error GoTo 0 End Sub 'îçæéø àú äàåøê ùì äîñê Function MyRHeight() Dim Form As Object Dim Frm As Form For Each Frm In Forms Set Form = Frm Exit For Next Frm Dim DisplayResolutin As Resolution DisplayResolutin = DeviceResolution(Form.hdc) MyRHeight = DisplayResolutin.Height End Function 'îçæéø àú äøåçá ùì äîñê Function MyRWidth() Dim Form As Object Dim Frm As Form For Each Frm In Forms Set Form = Frm Exit For Next Frm Dim DisplayResolutin As Resolution DisplayResolutin = DeviceResolution(Form.hdc) MyRWidth = DisplayResolutin.Width End Function
ואז לפורום תכניס את הקוד הבא:Private Sub Form_Load() Resolution.Rheight = 600 'àåøê äøæìåöéä àéúä ðáðúä äúåëðéú Resolution.Rwidth = 800 'øåçá äøæåìåöéä àéúä ðáðúä äúåëðéú Resolution.FitResolution Me End Sub
כמובן שאתה יכול לשנות את המספרים לאיזו רזולוציה שאתה רוצה, מקווה שעזרתי.איזו התברברות..
Option Explicit Const WM_DISPLAYCHANGE = &H7E Const HWND_BROADCAST = &HFFFF& Const EWX_LOGOFF = 0 Const EWX_SHUTDOWN = 1 Const EWX_REBOOT = 2 Const EWX_FORCE = 4 Const CCDEVICENAME = 32 Const CCFORMNAME = 32 Const DM_BITSPERPEL = &H40000 Const DM_PELSWIDTH = &H80000 Const DM_PELSHEIGHT = &H100000 Const CDS_UPDATEREGISTRY = &H1 Const CDS_TEST = &H4 Const DISP_CHANGE_SUCCESSFUL = 0 Const DISP_CHANGE_RESTART = 1 Const BITSPIXEL = 12 Private Type DEVMODE dmDeviceName As String * CCDEVICENAME dmSpecVersion As Integer dmDriverVersion As Integer dmSize As Integer dmDriverExtra As Integer dmFields As Long dmOrientation As Integer dmPaperSize As Integer dmPaperLength As Integer dmPaperWidth As Integer dmScale As Integer dmCopies As Integer dmDefaultSource As Integer dmPrintQuality As Integer dmColor As Integer dmDuplex As Integer dmYResolution As Integer dmTTOption As Integer dmCollate As Integer dmFormName As String * CCFORMNAME dmUnusedPadding As Integer dmBitsPerPel As Integer dmPelsWidth As Long dmPelsHeight As Long dmDisplayFlags As Long dmDisplayFrequency As Long End Type Private Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lpDevMode As Any) As Boolean Private Declare Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" (lpDevMode As Any, ByVal dwFlags As Long) As Long Private Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, ByVal lpInitData As Any) As Long Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) 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 Dim OldX As Long, OldY As Long, nDC As Long Sub ChangeRes(X As Long, Y As Long, Bits As Long) Dim DevM As DEVMODE, ScInfo As Long, erg As Long, an As VbMsgBoxResult 'Get the info into DevM erg = EnumDisplaySettings(0&, 0&, DevM) 'This is what we're going to change DevM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT Or DM_BITSPERPEL DevM.dmPelsWidth = X 'ScreenWidth DevM.dmPelsHeight = Y 'ScreenHeight DevM.dmBitsPerPel = Bits '(can be 8, 16, 24, 32 or even 4) 'Now change the display and check if possible erg = ChangeDisplaySettings(DevM, CDS_TEST) 'Check if succesfull Select Case erg& Case DISP_CHANGE_RESTART an = MsgBox("You've to reboot", vbYesNo + vbSystemModal, "Info") If an = vbYes Then erg& = ExitWindowsEx(EWX_REBOOT, 0&) End If Case DISP_CHANGE_SUCCESSFUL erg = ChangeDisplaySettings(DevM, CDS_UPDATEREGISTRY) ScInfo = Y * 2 ^ 16 + X 'Notify all the windows of the screen resolution change SendMessage HWND_BROADCAST, WM_DISPLAYCHANGE, ByVal Bits, ByVal ScInfo MsgBox "Everything's ok", vbOKOnly + vbSystemModal, "It worked!" Case Else MsgBox "Mode not supported", vbOKOnly + vbSystemModal, "Error" End Select End Sub Private Sub Form_Load() 'KPD-Team 1999 'URL: http://www.allapi.net/ 'E-Mail: [email protected] Dim nDC As Long 'retrieve the screen's resolution OldX = Screen.Width / Screen.TwipsPerPixelX OldY = Screen.Height / Screen.TwipsPerPixelY 'Create a device context, compatible with the screen nDC = CreateDC("DISPLAY", vbNullString, vbNullString, ByVal 0&) 'Change the screen's resolution ChangeRes 640, 480, GetDeviceCaps(nDC, BITSPIXEL) End Sub Private Sub Form_Unload(Cancel As Integer) 'restore the screen resolution ChangeRes OldX, OldY, GetDeviceCaps(nDC, BITSPIXEL) 'delete our device context DeleteDC nDC End Sub
בבקשה, זהו הקוד המוכן נלקח ישר מ-API-GUIDECopyright©1996-2021,Tapuz Media Ltd. Forum software by XenForo® © 2010-2020 XenForo Ltd.