1
1

HDPI.bas 1.3 KB

12345678910111213141516171819202122232425262728293031323334353637383940
  1. Attribute VB_Name = "HDPI"
  2. #If VBA7 Then
  3. Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
  4. Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
  5. Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
  6. #Else
  7. Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
  8. Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
  9. Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
  10. #End If
  11. Public Function GetHDPI() As Double
  12. Const LOGPIXELSX = 88
  13. Const HORZRES = 8
  14. Dim hdc As Long, dpi As Long, width As Long
  15. hdc = GetDC(0)
  16. dpi = GetDeviceCaps(hdc, LOGPIXELSX)
  17. width = GetDeviceCaps(hdc, HORZRES)
  18. ReleaseDC 0, hdc
  19. GetHDPI = dpi / width * 25.4
  20. End Function
  21. Public Function GetHDPIPercentage() As Integer
  22. Const LOGPIXELSX = 88
  23. Const HORZRES = 8
  24. Dim hdc As Long, dpi As Long, width As Long
  25. hdc = GetDC(0)
  26. dpi = GetDeviceCaps(hdc, LOGPIXELSX)
  27. width = GetDeviceCaps(hdc, HORZRES)
  28. ReleaseDC 0, hdc
  29. GetHDPIPercentage = Round(dpi / 96 * 100, 0)
  30. End Function
  31. Sub MSG_HDPIPercentage()
  32. MsgBox "HDPI Percentage:" & GetHDPIPercentage
  33. End Sub