VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsdisplayInf"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

'   Display info class version 1.1
'  Written by Mike D Sutton of EDais
'     Microsoft Visual Basic MVP
'
' E-Mail: EDais@mvps.org
' WWW: Http://www.mvps.org/EDais/
'
' Written: 28/08/2002
' Last edited: 17/08/2003

'Version history:
'----------------

' Version 1.1 (17/08/2003):
'   Removed HorizRes and VertRes properties since new methods supersede them
'
'   GetMonitorCount()  - Number of monitors attached to the current desktop
'   GetDisplayLeft()   - Left coordinate of the virtual display area
'   GetDisplayTop()    - Top coordinate of the virtual display area
'   GetDisplayWidth()  - Width of the virtual display area
'   GetDisplayHeight() - Height of the virtual display area
'   GetDisplayRight()  - Right coordinate of the virtual display area
'   GetDisplayBottom() - Bottom coordinate of the virtual display area
'
' Version 1.01 (08/08/2003):
'   Minor non-impact code modifications

' Version 1.0 (28/08/2002):
'   Added HorizRes, VertRes and BitDepth properties
'
'   MapColour()         - Maps a 24-bit colour value to it's colour value on this display
'   ReQueryDisplay()    - Requeries the display and returns the current true bit depth
'   GetTrueBitDepth()   - Finds the true bit depth for the current display (15/16-bit safe)
'   Byte24to15Last()    - Maps a byte to the last good 5-bit version
'   Byte24to15Nearest() - Maps a byte to the  nearest  5-bit version
'   Byte24to16Last()    - Maps a byte to the last good 6-bit version
'   Byte24to16Nearest() - Maps a byte to the  nearest  6-bit version
'------------

Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, ByRef lpBits As Any) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function SetPixelV Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)

Public Enum enMapMode
    mmLast = &H0    ' Maps to the last good value
    mmNearest = &H1 ' Maps to the nearest value
End Enum

Private Const BITSPIXEL As Long = 12 ' Number of bits per pixel

Private Const SM_CXSCREEN As Long = 0
Private Const SM_CYSCREEN As Long = 1
Private Const SM_XVIRTUALSCREEN As Long = 76
Private Const SM_YVIRTUALSCREEN As Long = 77
Private Const SM_CXVIRTUALSCREEN As Long = 78
Private Const SM_CYVIRTUALSCREEN As Long = 79
Private Const SM_CMONITORS As Long = 80

Dim m_BitDepth As Long
Dim m_HorizRes As Long
Dim m_VertRes As Long

Public Property Get BitDepth() As Long
    BitDepth = m_BitDepth
End Property

Private Sub Class_Initialize()
    Call ReQueryDisplay
End Sub

Public Function GetMonitorCount() As Long
    GetMonitorCount = GetSystemMetrics(SM_CMONITORS)
    If (GetMonitorCount < 1) Then GetMonitorCount = 1
End Function

Public Function GetDisplayLeft() As Long
    If (GetMonitorCount > 1) Then GetDisplayLeft = GetSystemMetrics(SM_XVIRTUALSCREEN)
End Function

Public Function GetDisplayTop() As Long
    If (GetMonitorCount > 1) Then GetDisplayTop = GetSystemMetrics(SM_YVIRTUALSCREEN)
End Function

Public Function GetDisplayWidth() As Long
    GetDisplayWidth = GetSystemMetrics(IIf(GetMonitorCount > 1, SM_CXVIRTUALSCREEN, SM_CXSCREEN))
End Function

Public Function GetDisplayHeight() As Long
    GetDisplayHeight = GetSystemMetrics(IIf(GetMonitorCount > 1, SM_CYVIRTUALSCREEN, SM_CYSCREEN))
End Function

Public Function GetDisplayRight() As Long
    GetDisplayRight = Me.GetDisplayWidth() + Me.GetDisplayLeft()
End Function

Public Function GetDisplayBottom() As Long
    GetDisplayBottom = Me.GetDisplayHeight() + Me.GetDisplayTop()
End Function

Public Function MapColour(ByVal inColour As Long, ByVal inMode As enMapMode) As Long
    Dim DeskWnd As Long, DeskDC As Long
    Dim SrcPix(3) As Byte
    
    Select Case m_BitDepth
        Case 15, 16 ' Colour value needs mapping to high colour and back
            Call RtlMoveMemory(ByVal VarPtr(SrcPix(0)), ByVal VarPtr(inColour), &H4)
            
            If (inMode = mmNearest) Then
                SrcPix(0) = Byte24to15Nearest(SrcPix(0))
                If (m_BitDepth = 15) Then _
                     SrcPix(1) = Byte24to15Nearest(SrcPix(1)) _
                Else SrcPix(1) = Byte24to16Nearest(SrcPix(1))
                SrcPix(2) = Byte24to15Nearest(SrcPix(2))
            Else
                SrcPix(0) = Byte24to15Last(SrcPix(0))
                If (m_BitDepth = 15) Then _
                     SrcPix(1) = Byte24to15Last(SrcPix(1)) _
                Else SrcPix(1) = Byte24to16Last(SrcPix(1))
                SrcPix(2) = Byte24to15Last(SrcPix(2))
            End If
            
            Call RtlMoveMemory(ByVal VarPtr(MapColour), ByVal VarPtr(SrcPix(0)), &H4)
        Case Else: MapColour = inColour
    End Select
End Function

Public Function ReQueryDisplay() As Long
    Dim DeskWnd As Long, DeskDC As Long
    
    DeskWnd = GetDesktopWindow()
    DeskDC = GetDC(DeskWnd)
    m_BitDepth = GetTrueBitDepth(DeskDC)
    Call ReleaseDC(DeskWnd, DeskDC)
    
    ReQueryDisplay = m_BitDepth
End Function

Private Function GetTrueBitDepth(ByVal inDC As Long) As Long
    Dim MyDC As Long, MyDDB As Long, OldDIB As Long
    Dim RetPix As Long
    
    GetTrueBitDepth = GetDeviceCaps(inDC, BITSPIXEL)
    
    If (GetTrueBitDepth = 16) Then ' 15 or 16 bit?
        MyDC = CreateCompatibleDC(inDC)
        
        If (MyDC) Then
            MyDDB = CreateBitmap(1, 1, 1, 16, ByVal 0&)
            
            If (MyDDB) Then
                OldDIB = SelectObject(MyDC, MyDDB)
                
                If (OldDIB) Then
                    Call SetPixelV(MyDC, 0, 0, &HC00)
                    RetPix = GetPixel(MyDC, 0, 0)
                    If (RetPix <> &HC00) Then GetTrueBitDepth = 15
                    Call SelectObject(MyDC, OldDIB)
                End If
                
                Call DeleteObject(MyDDB)
            End If
            
            Call DeleteDC(MyDC)
        End If
    End If
End Function

Private Function Byte24to15Last(ByVal inByte As Byte) As Byte
    Byte24to15Last = (((inByte \ &H8) And &H1F) / &H20) * &HFF
End Function

Private Function Byte24to15Nearest(ByVal inByte As Byte) As Byte
    Byte24to15Nearest = ((((inByte \ &H8) And &H1F) + ((inByte \ &H4) And &H1)) / &H20) * &HFF
End Function

Private Function Byte24to16Last(ByVal inByte As Byte) As Byte
    Byte24to16Last = (((inByte \ &H4) And &H3F) / &H40) * &HFF
End Function

Private Function Byte24to16Nearest(ByVal inByte As Byte) As Byte
    Byte24to16Nearest = ((((inByte \ &H4) And &H3F) + ((inByte \ &H2) And &H1)) / &H40) * &HFF
End Function