vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
Erstellen von dynamischen Kontextmen?s - wann immer Sie sie brauchen!  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   Impressum  | Datenschutz  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2024
 
zurück

 Sie sind aktuell nicht angemeldet.Funktionen: Einloggen  |  Neu registrieren  |  Suchen

VB.NET - Ein- und Umsteiger
Re: CopyFromScreen bringt falschen Ausschnitt 
Autor: Bazi
Datum: 27.01.23 14:40

Hier nun die bisherige Lösung.
Aufgrund statischer Umrechnungsfaktoren noch unsauber, evtl. hat jemand etwas besseres.
Siehe auch: https://dotnet-snippets.de/snippet/bildschirmskalierung-bestimmen/5950

in einem Modul:
Imports System
Imports System.Drawing
Imports System.Runtime.InteropServices
Imports System.Runtime.CompilerServices
 
Module ScreenExtensions
    Const S_OK As Integer = 0
    Const MONITOR_DEFAULTTONEAREST As Integer = 2
    Const E_INVALIDARG As Integer = -2147024809
 
    Private Declare Function MonitorFromPoint Lib "user32.dll" (<[In]()> _
      ByVal pt As Point, <[In]()> ByVal dwFlags As UInteger) As IntPtr
    Private Declare Function GetDpiForMonitor Lib "Shcore.dll" (<[In]()> _
    ByVal hmonitor As IntPtr, <[In]()> ByVal dpiType As DpiType, <Out()> _
    ByRef dpiX As UInteger, <Out()> ByRef dpiY As UInteger) As IntPtr
 
    <Extension()> _
    Sub GetDpi(ByVal screen As Screen, ByVal dpiType As DpiType, <Out()> _
    ByRef dpiX As UInteger, <Out()> ByRef dpiY As UInteger)
        Dim point = New Point(screen.Bounds.Left + 1, screen.Bounds.Top + 1)
        Dim hmonitor = MonitorFromPoint(point, MONITOR_DEFAULTTONEAREST)
 
        Select Case GetDpiForMonitor(hmonitor, dpiType, dpiX, dpiY).ToInt32()
            Case S_OK
                Return
            Case E_INVALIDARG
                Throw New ArgumentException("Unknown error. See" & _
                  "https://msdn.microsoft.com/en-us/library/windows/desktop/dn" & _
                  "80510.aspx for more information.")
            Case Else
                Throw New COMException("Unknown error. See" & _
                  "https://msdn.microsoft.com/en-us/library/windows/desktop/dn" & _
                  "80510.aspx for more information.")
        End Select
    End Sub
End Module
 
Public Enum DpiType
    Effective = 0
    Angular = 1
    Raw = 2
End Enum
in meinem Formular:
    Private Function BildschirmFotoInClipBoard(ByVal rct As Rectangle) As _
      Boolean
        Try
            Dim sc = GetScreenAtPoint(rct.Location)
 
            Dim dpiX As UInteger
            Dim dpiY As UInteger
            GetDpi(sc, DpiType.Angular, dpiX, dpiY)
            'Debug.Print("GetDpi bringt bei  DpiType.Angular : dpiX = " & 
            ' dpiX.ToString & " ; dpiY = " & dpiY.ToString)
 
            Dim dpiXe As UInteger
            Dim dpiYe As UInteger
            GetDpi(sc, DpiType.Effective, dpiXe, dpiYe)
            'Debug.Print("GetDpi bringt bei  DpiType.Effective : dpiX = " & 
            ' dpiXe.ToString & " ; dpiY = " & dpiYe.ToString)
 
            If dpiX = 110 AndAlso dpiXe = 96 Then ' bei mir alles gut, 
            ' Skalierung auf 100%
            ElseIf dpiX = 88 AndAlso dpiXe = 96 Then ' auf dem Laptop 
            ' Skalierung 125%
                With rct
                    .Location = New Point(CInt(rct.X * 1.25), CInt(rct.Y * _
                      1.25))
                    .Width = .Width * 1.25
                    .Height = .Height * 1.25
                End With
            ElseIf dpiX = 73 AndAlso dpiXe = 96 Then ' auf dem Laptop 
            ' Skalierung 150%
                With rct
                    .Location = New Point(CInt(rct.X * 1.5), CInt(rct.Y * 1.5))
                    .Width = .Width * 1.5
                    .Height = .Height * 1.5
                End With
            ElseIf dpiX = 63 AndAlso dpiXe = 96 Then ' auf dem Laptop 
            ' Skalierung 175%
                With rct
                    .Location = New Point(CInt(rct.X * 1.75), CInt(rct.Y * _
                      1.75))
                    .Width = .Width * 1.75
                    .Height = .Height * 1.75
                End With
            Else
                MessageBox.Show("Der Bildausschnitt wird vermutlich nicht" & _
                  "stimmen," _
                                 & Environment.NewLine & _
                                 "da die Skalierung der Anzeige nicht auf einen" & _
                                 "Standardwert eingestellt ist." & _
                                 Environment.NewLine & _
                                 "Sie können das in der Systemsteuerung unter" & _
                                 "Anzeigeeinstellungen ändern", ProgrammName, _
                                 MessageBoxButtons.OK)
            End If
 
            Using b As New Bitmap(rct.Width, rct.Height)
                Using g As Graphics = Graphics.FromImage(b)
                    g.CopyFromScreen(rct.Location, New Point(0, 0), New Size( _
                      rct.Width, rct.Height))
                End Using
                Clipboard.SetImage(b)
            End Using
            Return True
        Catch ex As Exception
            Debug.Print(ex.Message)
            DebugToFile(ex.Message)
            Return False
        End Try
    End Function

Danke für die Hilfe

Gruß Christian

alle Nachrichten anzeigenGesamtübersicht  |  Zum Thema  |  Suchen

 ThemaViews  AutorDatum
CopyFromScreen bringt falschen Ausschnitt320Bazi25.01.23 17:10
Re: CopyFromScreen bringt falschen Ausschnitt132Bazi26.01.23 12:00
Re: CopyFromScreen bringt falschen Ausschnitt145Bazi27.01.23 14:40
Re: CopyFromScreen bringt falschen Ausschnitt146Schudi27.01.23 07:47
Re: CopyFromScreen bringt falschen Ausschnitt151Bazi27.01.23 11:52
Re: CopyFromScreen bringt falschen Ausschnitt145Schudi27.01.23 16:36

Sie sind nicht angemeldet!
Um auf diesen Beitrag zu antworten oder neue Beiträge schreiben zu können, müssen Sie sich zunächst anmelden.

Einloggen  |  Neu registrieren

Funktionen:  Zum Thema  |  GesamtübersichtSuchen 

nach obenzurück
 
   

Copyright ©2000-2024 vb@rchiv Dieter Otter
Alle Rechte vorbehalten.
Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein.

Diese Seiten wurden optimiert für eine Bildschirmauflösung von mind. 1280x1024 Pixel