Kurve 1:1 auf dem Monitor darstellen? (Autodesk/Inventor)

unabhängig von Deiner Antwort, lade ich das Makro hier mal ab.

in ein Modul "Massstab_Modell" (oder anderem beliebigem Namen)

Code:
'
' 3d-Modell 1:1 am Monitor -> Ansicht1zu1
' ggf. auch anderer Massstab
'
'
' Idee dazu stammt aus diesem Forumsbeitrag
' https://ww3.cad.de/foren/ubb/Forum50/HTML/030949.shtml#000027
' und wurde hier als kleines Programm umgesetzt
' https://inventorfaq.blogspot.com/2012/08/mastablich-zoomen-im-inventor-tool.html
'
' Idee für Verbesserung:
' ->Funktion um den Monitor zu "kalibieren"
' Eingabe von Soll-Länge und Ist-Länge (vom User mit Lineal gemessen)
' über die Auflösung zurück rechnen auf eine (fiktive) DisplayGröße
' diese DisplayGröße speichern (ist ja schon vorgesehen)
' danach sollte bei weiteren Aufrufen das kalibrierte Ergebnis wiederholbar sein
Option Explicit
Public Sub Ansicht1zu1()
' skaliert die Ansicht so, dass das aktuelle Objekt (etwa) 1:1 am Monitor erscheint
'
' gewählte Kante wird als Größenreferenz verwendet, ggf. wird zur Auswahl aufgefordert
' es wird auch die aktuelle DisplayAuflösung zur berechnung benutzt -> vom PrimärMonitor
' ggf. führt das zu falschen Ergebnissen bei mehreren, unterschiedlichen Monitoren!
' es ist auch die Displaygröße nötig, diese lässt sich wohl aber nicht automatisch ermitteln
' -> lässt sich durch Drücken der STRG beim Start einstellen!
' beim Drücken von SHIFT -> wird der Maßstab abgefragt
'
' KraBBy 12.02.2019
'
' man könnte sich wohl die Auswahl einer Kante auch sparen
' und stattdessen die Eckpunkte der BoundingBox verwenden
' durch das Projizieren der Punkte auf die BildschirmEbene (Fkt. Distance3d_Cam)
' käme wohl was korrektes raus
' aus dem gleichen Grund könnte auch auf Fkt. getPointOnCircle verzichtet werden
' -> ABER jetzt ist es eben so, wie es ist

'Tastendrücke beim Aufruf erfassen
Dim bUserScale As Boolean, bSetDisplaySize As Boolean
bUserScale = TastaturIN_OUT.ShiftPressed()
bSetDisplaySize = TastaturIN_OUT.StrgPressed()
'gespeicherte Displaygröße abrufen, ggf. auch neu festlegen
Dim DispDiag As Single
DispDiag = ReadDispSizeSetting(bSetDisplaySize)

'gewünschten Masstab abfragen
Dim sScale As Single
If bUserScale Then
sScale = getUserInput_Scale()
Else: sScale = 1
End If

'prüfen ob DokTyp passt -> nur ipt + iam
Dim oDoc As Document
Set oDoc = ThisApplication.ActiveDocument
If Not korrDocOpened(kPartDocumentObject, kAssemblyDocumentObject, oDoc) Then Exit Sub

Dim oCam As Camera
Set oCam = ThisApplication.ActiveView.Camera

'aktuelle Auswahl prüfen
Dim oSel As SelectSet
Set oSel = oDoc.SelectSet
If 0 = oSel.Count Then
MsgBox "Bitte Kante wählen!", vbInformation, "Ansicht1zu1"
Dim oEdge
Set oEdge = ThisApplication.CommandManager.Pick(kPartEdgeFilter, "Pick a Edge!")
If oEdge Is Nothing Then Exit Sub 'Benutzer hat abgebrochen
oSel.Select oEdge 'markieren
End If

'erstes Element verwenden (auch falls mehrere gewählt sind)
Dim oObj As Object
Set oObj = oSel.Item(1)

'Punkte für Anfang u. Ende
Dim P1 As Point, P2 As Point
On Error Resume Next
If oObj.GeometryType = kCircleCurve Then 'Sonderfalls Kreis abfangen; hat kein Start/Ende
Call getPointOnCircle(oObj.Geometry, P1, P2)
'Set P1 = oObj.Geometry.Evaluator.RangeBox.MaxPoint 'liefert Quatsch, falls Kreis schräg im Raum liegt!!!
Else
Set P1 = oObj.Geometry.StartPoint
Set P2 = oObj.Geometry.EndPoint
End If

If Not 0 = Err.Number Then
MsgBox "Hoppla! vmtl. hat gewähltes Element keinen Start- u. EndPunkt", vbInformation, "Abgebrochen"
Exit Sub
End If
On Error GoTo 0

'Distanz im Modell
Dim D3d As Double
D3d = Distance3d(P1, P2) 'cm -> schlecht, wenn Punkte nicht in Ebene parallel zum Bildschirm liegen
D3d = Distance3d_Cam(P1, P2, oCam) 'cm, gemesssen senkrecht zur Blickrichtung der Camera

'Distanz in der Grafik
Dim D2d As Double 'Pixel
With oCam
D2d = Distance2d(.ModelToViewSpace(P1), .ModelToViewSpace(P2))
End With
If D2d < 1 Then MsgBox "Punkte liegen in der Ansicht aufeinander!", vbOKOnly, "Abgebrochen": Exit Sub

'PixelDichte der Anzeige ermitteln
Dim d As Double ' Einheit: px pro mm
'd = getPixelDichte() 'siehe Modul ..._API 'liefert ~schlechtes~ Ergebnis!
d = calc_PixelDichte(DispDiag) 'siehe Modul 'scheint zu funzen, jedoch Eingabe Displaygröße nötig!
d = d * 10 ' Einheit px pro cm (wegen cm als IV-Basis-LängenEinheit)

'Distanz der Grafik am Monitor -> px in Länge umrechnen
Dim l As Double
l = D2d / d 'Einheit: [px]/[px/cm] = [cm]

'Aktuelle Größe der Darstellung (Zoom)
Dim curW As Double, curH As Double
Call oCam.GetExtents(curW, curH) 'befüllt die Parameter

'künftigen Zoom berechnen
Dim f As Double 'Faktor
f = l / D3d / sScale 'Soll / Ist
curW = curW * f
curH = curH * f

'neue Werte anwenden
Call oCam.SetExtents(curW, curH)
Call oCam.Apply

'Aufräumen
Set oCam = Nothing
Set oDoc = Nothing
Set oSel = Nothing
Set oObj = Nothing
Set P1 = Nothing
Set P2 = Nothing
End Sub
Private Sub test_ReadDispSizeSetting()
Dim a As Single
a = ReadDispSizeSetting(True)
MsgBox a
End Sub
Private Function ReadDispSizeSetting(bReset As Boolean) As Single
'gespeicherten Wert aus Registry lesen
' sollte keiner hinterlegt sein, wird 24 verwendet
' wenn bReset = TRUE, dann wird eine Angabe vom Benutzer erfragt und gespeichert
'
' KraBBy 12.02.2019

'Wert lesen
Dim s As String
s = VBA.GetSetting("InventorVBA_KraBBy", "Ansicht1zu1", "DisplaySizeInch", "24")
'24 als Default, falls Wert nicht in Registry gesetzt ist

'gelesenen Wert in Zahl wandeln
Dim sI As Single
sI = CSng(s)

'Eingabe erforderlich?
If bReset Then 'Reset!
Dim s1 As String
s1 = InputBox("Displaygröße des (Primär)Monitors in Zoll eingeben!", "Einstellung DispSize [inch]", s)
If IsNumeric(s1) Then
sI = Abs(CSng(s1)) 'in Zahl wandeln (Scherze mit Vorzeichen abfangen)
' Bei Dezimaltrennzeichen wird es uU schwierig -> lokale Einst. entscheidend
' Sicherheitshalber nochmal die Frage an Benutzer:
If vbYes = MsgBox("Eingabe speichern?" & vbCrLf & sI, vbYesNo, "Reset DispSizeSetting") Then
Call VBA.SaveSetting("InventorVBA_KraBBy", "Ansicht1zu1", "DisplaySizeInch", sI)
Else
sI = CSng(s) 'doch wieder alten Wert verwenden
End If
Else
MsgBox "Eingabe konnte nicht als Zahl interpretiert werden." & vbCrLf & "Ggf. erneut ausführen!" _
& String(2, vbCrLf) & "eingegeben: '" & s1 & "'" _
& vbCrLf & "verwendet wird: " & sI, vbExclamation, "Reset DispSizeSetting"
'alter Wert wird verwendet
End If
Else 'kein Reset nötig
'nix zu tun -> alter Wert wird verw.
End If

'Rückgabewert der Fkt
ReadDispSizeSetting = sI
End Function
Private Function getUserInput_Scale() As Single
' gewünschter Maßstab wird vom Benutzer abgefragt
' Zahlenwert wird zurückgegeben
' 1, wenn der User Quatsch eingibt
'
' KraBBy 12.02.2019

Dim s As String, z As Single

z = 1 'Default-Rückgabewert

'Frage an Benutzer
s = InputBox("Gewünschten Maßstab eingeben!" & String(2, vbCrLf) _
& "als Faktor" & vbCrLf _
& vbTab & "2:1 -> 2" & vbCrLf _
& vbTab & "1:2 -> 0,5", "Benutzereingabe Maßstab", "0,5")
If IsNumeric(s) Then
z = Abs(CSng(s)) 'in Zahl wandeln (Scherze mit Vorzeichen abfangen)
Else 'keine Zahl
MsgBox "Eingabe konnte nicht als Zahl interpretiert werden." & vbCrLf & "Ggf. erneut ausführen!" _
& String(2, vbCrLf) & "eingegeben: '" & s & "'" _
& vbCrLf & "verwendet wird: " & z, vbExclamation, "Benutzereingabe Maßstab"
End If
If 0 = z Then z = 1 ' Fall "0" abfangen
getUserInput_Scale = z 'Rückgabewert
End Function
Private Function Distance2d(a As Point2d, b As Point2d) As Double
Distance2d = a.DistanceTo(b)
End Function
Private Function Distance3d(a As Point, b As Point) As Double
Distance3d = a.DistanceTo(b)
End Function
Private Function Distance3d_Cam(a As Point, b As Point, oCam As Camera) As Double
' Ebene parallel zur MontiorFläche bilden
' darauf die beiden Punkte a,b projizieren -> Punkte c,d
' Distanz zwischen den neuen Punkten zurückgeben
'
' KraBBy 12.02.2019
Dim oTG As TransientGeometry
Set oTG = ThisApplication.TransientGeometry

'Vektor von Target zu Eye (-> Blickrichtung der Camera bzw. entgegen dazu)
Dim oNorm As Vector
Set oNorm = oCam.Target.VectorTo(oCam.Eye)

' Target-Ebene (senkrecht zur Blickrichtung)
Dim oPl As Plane
Set oPl = oTG.CreatePlane(oCam.Target, oNorm)

'Linien in Blickrichtung durch die geg. Punkte
Dim oLa As Line, oLb
Set oLa = oTG.CreateLine(a, oNorm)
Set oLb = oTG.CreateLine(b, oNorm)

'Schnittpunkte der Linien mit der Target-Ebene
Dim C As Point, d As Point
Set C = oPl.IntersectWithLine(oLa)
Set d = oPl.IntersectWithLine(oLb)

'Rückgabewert: Distanz der neuen Punkte
Distance3d_Cam = C.DistanceTo(d)

'Aufräumen
Set oTG = Nothing
Set oNorm = Nothing
Set oPl = Nothing
Set oLa = Nothing
Set oLb = Nothing
Set C = Nothing
Set d = Nothing
End Function
Private Sub getPointOnCircle(oCircleGeo As Object, ByRef oCenter As Point, ByRef Pt As Point)
' für den Gegebenen Kreis wird das Zentrum und ein ~beliebiger Punkt auf dem Kreis zurückgegeben
' oCircleGeo : KreisKante.Geometry
' oCenter : Zentrum ->Rückgabewert
' Pt : Kreispunkt ->Rückgabewert
'
' basierend auf den Elementen des KreisNormalVektors wird ein Vektor gebildet der dazu senkrecht (?) steht
' damit wiederrum eine Ebene durch KreisZentrum bilden
' einer der beiden Schnittpunkte (Ebene und Kreis) wird als Rückgabewert verwendet
'
' KraBBy 12.02.2018

Dim oNormVec As UnitVector
Set oCenter = oCircleGeo.center '-> Rückgabewert
Set oNormVec = oCircleGeo.Normal

Dim oTG As TransientGeometry
Set oTG = ThisApplication.TransientGeometry

'Vektor bilden aus den Komponenten der KreisNormalen
Dim oTempVec As Vector
On Error Resume Next
Set oTempVec = oTG.CreateVector(oNormVec.z, 0, -oNormVec.x)
'falls oNormVec | | zur y-Achse verläuft kommt ein "NullVektor" zustande
If 0.01 > oTempVec.Length Then
'NullVektor erkennen, dann andere Richtung verwernden
Set oTempVec = oTG.CreateVector(0, oNormVec.z, -oNormVec.y)
End If
On Error GoTo 0

'Ebene bilden: Normal zu TempVec und durch KreisZentrum
Dim oPl As Plane
Set oPl = oTG.CreatePlane(oCenter, oTempVec)
'Schnittpunkte der Ebene und Kreis berechnen
Dim ret As ObjectsEnumerator 'Container für die Schnittpunkte
Set ret = oPl.IntersectWithCurve(oCircleGeo)

If 0 = ret.Count Then 'keine Schnittpunkte
' was jetzt?
MsgBox "Es ging was schief!" & vbCrLf & "Keinen Punkt auf dem Kreis erhalten.", vbCritical, "Fkt. getPointOnCircle"
Set Pt = oCircleGeo.Evaluator.RangeBox.MaxPoint 'pure willkür! kA ob da was passendes rauskommt
Else
Set Pt = ret.Item(1) 'ersten Schnittpunkt verwenden -> Rückgabewert
End If

'Aufräumen
Set oTG = Nothing
Set oPl = Nothing
Set oTempVec = Nothing
Set ret = Nothing
End Sub
Function korrDocOpened(oType1 As DocumentTypeEnum, Optional oType2 As DocumentTypeEnum, Optional oDoc As Document) As Boolean
' Prüft, ob das Dokument oDoc dem gewünschten Typ entspricht
' Rückgabe True/False
'
' wird oDoc nicht angegeben, wird das aktive Dokument geprüft
'
'oType1 -> der Dokument-Typ, angegeben als IV-Konstante
' kAssemblyDocumentObject
' kDrawingDocumentObject
' kPartDocumentObject
' kPresentationDocumentObject
' kNoDocument
' kSATFileDocumentObject '?
' kForeignModelDocumentObject '?
' kDesignElementDocumentObject '?
' kUnknownDocumentObject
'oType2 -> optional, ebenfalls gültiger Typ
'
' KraBBy 9.5.2018

If oDoc Is Nothing Then Set oDoc = ThisApplication.ActiveDocument
'weil optional

If oDoc Is Nothing Then 'wenn immer noch Nothing
'-> kein Dokument geöffnet
MsgBox "Was willst Du machen, wenn kein Dokument geöffnet ist!?!", vbQuestion, "Makro beendet"
korrDocOpened = False
Exit Function 'schon fertig
End If

Dim sPrompt As String

If oDoc.DocumentType = oType1 Then
korrDocOpened = True
ElseIf oDoc.DocumentType = oType2 Then
korrDocOpened = True
Else 'nicht das gewünschte Dokument
'Meldung
sPrompt = "Abgebrochen." & vbCrLf _
& "Makro ist für dieses Dokument nicht geeignet." & String(2, vbCrLf) _
& "funktioniert für: " & vbCrLf _
& DocTypeEnum2String(oType1)
If Not (0 = oType2) Then sPrompt = sPrompt & " , " & DocTypeEnum2String(oType2) 'wenn 2.Parameter angegeben..
MsgBox sPrompt, vbInformation, "Fkt. korrDocOpened"

korrDocOpened = False
End If

End Function

Private Function DocTypeEnum2String(oType As DocumentTypeEnum) As String
' gibt den DokumentTyp als String zurück
' angegeben wird eine IV-Konstante
' wird verwendet von obiger Function korrDocOpened
Dim sType As String
Select Case oType
Case kAssemblyDocumentObject
sType = "iam (Assembly)"
Case kDrawingDocumentObject
sType = "idw (Drawing)"
Case kPartDocumentObject
sType = "ipt (Part)"
Case kPresentationDocumentObject
sType = "ipn (Presentation)"
Case kNoDocument, kUnknownDocumentObject
sType = "No/Unknown Doc."
Case kSATFileDocumentObject, kForeignModelDocumentObject, kDesignElementDocumentObject
MsgBox "Function DocTypeEnum2String: " & vbCrLf _
& "Bisher unbehandelte Dokument-Type. Code überprüfen!", vbCritical, "oops"
sType = "!WTF!"
Case 0
'kein DocType angegeben (schon in der aufrufenden Prozedur)
sType = ""
Case Else
MsgBox "Case Else in Function DocTypeEnum2String!" & vbCrLf _
& "Sollte nicht passieren. Code überprüfen!", vbCritical, "oops"
sType = "!WTF!"
End Select

'Rückgabewert
DocTypeEnum2String = sType
End Function

in einem Modul "TastaturIN_OUT" (Name ist in dem Fall wichtig):

Code:

Declare PtrSafe Function GetKeyState Lib "user32" (ByVal vKey As Integer) As Integer
Public Function ShiftPressed() As Boolean
'Returns True if shift key is pressed
ShiftPressed = GetKeyState(vbKeyShift) < 0 ' 16 = vbKeyShift
End Function
Public Function StrgPressed() As Boolean
'Returns True if Ctrl/Strg key is pressed
StrgPressed = GetKeyState(vbKeyControl) < 0 ' 17 = vbKeyControl
End Function

in einem weiteren Modul "Massstab_Modell_API" (Name unwichtig):

Code:
'
'
' Informationen eines Gerätes (ua. Grafikkarte/Monitor) abrufen
'
' API-Referenz und Beispiel-Code
' https://www.vbarchiv.net/api/details.php?id=createdc
' KraBBy 11.02.2019
Option Explicit
Private Declare PtrSafe Function CreateDC Lib "gdi32.dll" _
Alias "CreateDCA" ( _
ByVal lpszDriver As String, _
ByVal lpszDevice As String, _
ByVal lpszOutput As Long, _
lpInitData As Any) As Long
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" ( _
ByVal hdc As Long, _
ByVal nIndex As Long) As Long
Private Declare PtrSafe Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long

' CreateDC nIndex - Konstanten
Private Const DRIVERVERSION = 0 ' Treiberversion
Private Const HORZSIZE = 4 ' Horizontale Breite in Millimeter
Private Const VERTSIZE = 6 ' Vertikale Höhe in Millimeter
Private Const HORZRES = 8 ' Horizontale Breite in Pixel
Private Const VERTRES = 10 ' Vertikale Höhe in Pixel
Private Const BITSPIXEL = 12 ' Anzahl der Bits pro Pixel
Private Const PLANES = 14 ' Anzahl der Planes
Private Const NUMBRUSHES = 16 ' Anzahl der Brushes die das Device besitzt
Private Const NUMPENS = 18 ' Anzahl der Pens die das Device besitzt
Private Const NUMFONTS = 22 ' Anzahl der Fonts die das Device besitzt
Private Const NUMCOLORS = 24 ' Anzahl der Farben die das Device unterstützt
Private Const ASPECTX = 40 ' Relative Länge fürs Zeichnen von Linien
Private Const ASPECTY = 42 ' Relative Höhe fürs Zeichnen von Linien
Private Const CLIPCAPS = 36 ' Unterstützung von Clipping, der Rückgabewert
' ist 1 wenn Clipping unterstützt wird, ansonsten 0
Private Const SIZEPALETTE = 104 ' Anzahl der Einträge in der Palette
Private Const NUMRESERVED = 106 ' Anzahl der Reservierten Einträge in der Palette
Private Const COLORRES = 108 ' Aktuelle Farbauflösung
Private Const PHYSICALWIDTH = 110 ' Physische Breite in der Devicemaßeinheit
Private Const PHYSICALHEIGHT = 111 ' Physische Höhe in der Devicemaßeinheit
Private Const PHYSICALOFFSETX = 112 ' Physischer druckbarer Bereich - X Rand
Private Const PHYSICALOFFSETY = 113 ' Physischer druckbarer Bereich - Y Rand
Private Const VREFRESH = 116 ' (Win NT) Vertikale Refreshrate, ist der
' Rückgabewert 0 oder 1 so ist die Refreshrate der Standardwert
Private Const DESKTOPHORZRES = 118 ' (Win NT) Breite des Desktops, dieser
' Wert kann auf Grund von mehreren Monitoren breiter sein als HORZRES
Private Const DESKTOPVERTRES = 117 ' (Win NT) Höhe des Desktops, dieser Wert
' kann auf Grund von mehreren Monitoren breiter sein als VERTRES
Private Const BLTALIGNMENT = 119 ' (Win NT) Die beste Pixelauflösung für
' einen Blittingvorgang, ist der Rückagebewert 0 so ist die Hardware
' beschleunigt und jede Pixelauflösung ist optimal
Private Const TECHNOLOGY = 2 ' Gibt eine TECHNOLOGY-Konstante zurück, die das
' Gerät beschreibt
Private Const RASTERCAPS = 38 ' Gibt eine / mehrere RASTERCAPS-Konstante(n)
' zurück, die Eigenschaften des Gerätes beschreiben
Private Const CURVECAPS = 28 ' Gibt eine / mehrere CURVECAPS-Konstante(n)
' zurück, die Eigenschaften über das Zeichnen von Kurven beschreiben
Private Const LINECAPS = 30 ' Gibt eine / mehrere LINECAPS-Konstante(n) zurück
' die Eigenschaften über das Zeichnen von Linien beschreiben

' CreateDC Rückgabe-Konstanten
Private Const DT_PLOTTER = 0 ' (TECHNOLOGY) Raster Plotter
Private Const DT_RASDISPLAY = 1 ' (TECHNOLOGY) Raster Anzeige
Private Const DT_RASPRINTER = 2 ' (TECHNOLOGY) Raster Drucker
Private Const DT_RASCAMERA = 3 ' (TECHNOLOGY) Raster Kamera
Private Const DT_METAFILE = 5 ' (TECHNOLOGY) Meta Datei
Private Const DT_DISPFILE = 6 ' (TECHNOLOGY) Anzeige Datei
Private Const RC_BANDING = 2 ' (RASTERCAPS) Device requires banding support
Private Const RC_BITBLT = 1 ' (RASTERCAPS) Standard blitten möglich
Private Const RC_BITMAP64 = 8 ' (RASTERCAPS) Das Gerät unterstützt 64-Bit Bitmaps
Private Const RC_DIBTODEV = &H200 ' (RASTERCAPS) Das Gerät unterstützt DIBitsToDevice
Private Const RC_FLOODFILL = &H1000 ' (RASTERCAPS) Das Gerät unterstützt FloodFill
Private Const RC_GDI20_OUTPUT = &H10 ' (RASTERCAPS) Das Gerät hat einen 2.0 Ausgang Aufruf
Private Const RC_PALETTE = &H100 ' (RASTERCAPS) Das Gerät unterstützt Paletten
Private Const RC_SCALING = 4 ' (RASTERCAPS) Das Gerät benötigt eine Skalierungsunterstützung
Private Const RC_STRETCHBLT = &H800 ' (RASTERCAPS) Das Gerät unterstützt das Blitten & Stretchen von Bitmaps
Private Const RC_STRETCHDIB = &H2000 ' (RASTERCAPS) Das Gerät unterstützt das Stretchen von DIB-Bitmaps
Private Const CC_NONE = 0 ' (CURVECAPS) Kurven werden nicht unterstützt
Private Const CC_CIRCLES = 1 ' (CURVECAPS) Kreise werden unterstützt
Private Const CC_PIE = 2 ' (CURVECAPS) Kreisausschnitte werden unterstützt
Private Const CC_CHORD = 4 ' (CURVECAPS) Chords werden unterstützt
Private Const CC_ELLIPSES = 8 ' (CURVECAPS) Ellipsen werden unterstützt
Private Const CC_WIDE = 16 ' (CURVECAPS) Weite Linien werden unterstützt
Private Const CC_STYLED = 32 ' (CURVECAPS) Stylische Linien werden unterstützt
Private Const CC_WIDESTYLED = 64 ' (CURVECAPS) Weite stylische Linien werden unterstützt
Private Const CC_INTERIORS = 128 ' (CURVECAPS) Innere Linien werden unterstützt
Private Const CC_ROUNDRECT = 256 ' (CURVECAPS) Abgerundete Rechtecke werden unterstützt
Private Const LC_NONE = 0 ' (LINECAPS) Linien werden nicht unterstützt
Private Const LC_POLYLINE = 2 ' (LINECAPS) Polylinien werden unterstützt
Private Const LC_MARKER = 4 ' (LINECAPS) Marker werden unterstützt
Private Const LC_POLYMARKER = 8 ' (LINECAPS) Polymarker werden unterstützt
Private Const LC_WIDE = 16 ' (LINECAPS) Weite Linien werden unterstützt
Private Const LC_STYLED = 32 ' (LINECAPS) Stylische Linien werden unterstützt
Private Const LC_WIDESTYLED = 64 ' (LINECAPS) Weite stylische Linien werden unterstützt
Private Const LC_INTERIORS = 128 ' (LINECAPS) Innere Linien werden unterstützt
' Devicekontext der Grafikkarte anlegen und Informationen ausgeben
Private Sub Test_DeviceContext()
Dim hdc As Long, RetVal As Long

' Device Kontext erstellen
hdc = CreateDC("DISPLAY", vbNullChar, 0&, ByVal 0&)
If hdc = 0 Then
MsgBox "Es konnte kein Devicekontext erstellt werden."
Exit Sub
End If

' Informationen auswerten
Select Case True
Case CBool(GetDeviceCaps(hdc, TECHNOLOGY) And DT_RASDISPLAY)
Debug.Print "Das Gerät ist ein Anzeige Gerät"
Case CBool(GetDeviceCaps(hdc, TECHNOLOGY) And DT_RASPRINTER)
Debug.Print "Das Gerät ist ein Drucker"
Case CBool(GetDeviceCaps(hdc, TECHNOLOGY) And DT_PLOTTER)
Debug.Print "Das Gerät ist ein Plotter"
Case CBool(GetDeviceCaps(hdc, TECHNOLOGY) And DT_RASCAMERA)
Debug.Print "Das Gerät ist ein Kamera"
End Select

Debug.Print "Horizontale Auflösung: " & GetDeviceCaps(hdc, HORZRES)
Debug.Print "Breite[mm]: " & GetDeviceCaps(hdc, HORZSIZE)
Debug.Print "Vertikale Auflösung: " & GetDeviceCaps(hdc, VERTRES)
Debug.Print "Höhe[mm]: " & GetDeviceCaps(hdc, VERTSIZE)
'!!! Abmessung sind jedoch FALSCH !!!

Debug.Print "Anzahl der Farben: " & GetDeviceCaps(hdc, BITSPIXEL) & "-Bit"

' Device Kontext zerstören
DeleteDC hdc
End Sub
Public Function getPixelDichte() As Single
' Einheit: Pixel pro mm
' KraBBy 11.02.2019
'
' -> läuft soweit durch; Ergebnis ist aber falsch, weil die ausgegebenen DisplayGröße nicht passt
' dafür gibts (laut inet recherche) auch keine gute Lösung
getPixelDichte = 96 / 25.4 'Default Rückgabewert (falls Fehler...); 96 dpi

' Device Kontext erstellen
Dim hdc As Long
hdc = CreateDC("DISPLAY", vbNullChar, 0&, ByVal 0&)
If 0 = hdc Then
MsgBox "Es konnte kein Devicekontext erstellt werden."
Exit Function
End If

'Informationen lesen (Auflösung und Abmessungen)
Dim resHor As Long, resVer As Long
Dim szHor As Long, szVer As Long
resHor = GetDeviceCaps(hdc, HORZRES)
resVer = GetDeviceCaps(hdc, VERTRES)
szHor = GetDeviceCaps(hdc, HORZSIZE) 'DisplayGröße in mm, horizontal
szVer = GetDeviceCaps(hdc, VERTSIZE) 'dito , vertikal
'!!! Abmessung sind jedoch FALSCH !!!

'Auflösung berechnen: Pixel pro mm
Dim h As Single, v As Single
h = resHor / szHor
v = resVer / szVer
If Abs(h - v) > 0.01 Then MsgBox "Problemchen: Pixeldichte [px/mm] in x und y 'stark' unterschiedlich!" & vbCrLf _
& "hor:" & vbTab & h & vbCrLf _
& "vert:" & vbTab & v, vbInformation, "hahaha"

'Mittelwert bestimmen -> Rückgabewert
getPixelDichte = (h + v) / 2

' Device Kontext zerstören
DeleteDC hdc

End Function
Private Sub Test_getPixelDichte()
Dim a As Single
a = getPixelDichte() * 25.4
MsgBox getPixelDichte, , "Pixel pro mm"
MsgBox a, , "Pixel pro inch - dpi"
End Sub
Private Sub Test_CalcPixelDichte()
Dim a As Single
a = calc_PixelDichte(24)
MsgBox a, , "Pixel pro mm"
End Sub
Public Function calc_PixelDichte(MonitorSizeInch As Single) As Single
' Einheit: Pixel pro mm
' basierend auf der Auflösung des Monitors
' und der DisplayGröße (als Parameter übergeben)
'
' KraBBy 11.02.2019
'
' -> liefert (zumindest für meinen Monitor - 24 Zoll-) gute Ergebnisse!

calc_PixelDichte = 96 / 25.4 'Default Rückgabewert; 96dpi

' Device Kontext erstellen
Dim hdc As Long
hdc = CreateDC("DISPLAY", vbNullChar, 0&, ByVal 0&)
If 0 = hdc Then
MsgBox "Es konnte kein Devicekontext erstellt werden."
Exit Function
End If

'Informationen lesen (Auflösung)
Dim resHor As Long, resVer As Long
resHor = GetDeviceCaps(hdc, HORZRES)
resVer = GetDeviceCaps(hdc, VERTRES)

' Device Kontext zerstören
DeleteDC hdc

'DisplayDiagonale in Pixel
Dim diagPx As Double
diagPx = Sqr(resHor * resHor + resVer * resVer)

'Monitorgröße
'Const MonitorSizeInch As Double = 24
' ->als Parameter übergeben

'Auflösung dpi
Dim dPi As Double
dPi = diagPx / MonitorSizeInch

'MsgBox dpi, , "dpi"
'MsgBox dpi / 2.54, , "Pixel pro cm"

'Rückgabewert
calc_PixelDichte = dPi / 25.4 'pixel pro mm

End Function

Aufruf über "Ansicht1zu1", ggf. Varianten mit Strg- / Umschalt-Taste siehe Kommentare im Code.

------------------
Gruß KraBBy

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP