Копирование экрана через API в массив

[McConst]

Здравствуйте.
Требуется сделать алгоритм сканирования экрана. Заметил, что использование функции GetPixel на Win7 х64 сильно тормозит, поэтому решил сделать сканирование экрана через API-функции BitBlt и передачу в массив функцией GetDIBits.
Ранее я этими функциями не пользовался, поэтому алгоритм написал примерно так, как понял из разных источников в Google.
Чтобы протестить, правильно ли передаются пиксели в массив, написал тестовое приложение, в котором сканируется экран с листом экселя, затем книга эксель сворачивается и скан вновь попиксельно прорисовывается на экран (только верхняя половина - чтобы быстрее было). Вроде бы алгоритм и работает, но появляются какие-то непонятные полосы вертикальные на экране винды, что говорит о не совсем правильном сканировании или отображении скана.
Код приложения такой.
[spoiler]

Код (vb) Выделить Развернуть


Option Explicit

#If VBA7 Then
   Public Declare PtrSafe Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
#Else
   Public Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
#End If
'-----------------------------------------------------------------------------------------------------------------------
'Функции для работы с экраном и координатами форм
'
#If VBA7 Then
   'Функция получения координат прямоугольника-контрола
   Public Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
   'Функция для получения дескриптора контекстного устройства (напри. экран клиентской области формы).
   Public Declare PtrSafe Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
    'Освобождение контекстного устройства после вызова GetDC
   Public Declare PtrSafe Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hdc As Long) As Long
   'получить информацию относительно экранного устройства: экран монитора, принтер, плоттер
   Public Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
   'Получить системные параметры
   Public Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
   'Получить RGB-цвет пикселя по его координатам
   Public Declare PtrSafe Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
   'Отрисовать RGB-точку
   Public Declare PtrSafe Function SetPixel& Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long)
   'Создание копии совместимого контекстного устройства DC
   Public Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
   'Создается раст, совместимый с контекстным устройством DC
   Public Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
   'Выбор объекта изображения в контекстное устройство DC
   Public Declare PtrSafe Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
   'Удаление контекстного устройства
   Public Declare PtrSafe Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
   'Перенос изображения из/в: контекст отображения <--> контекст памяти
   'Передача прямоугольника пикселей с поверхности источника на поверхность приемника
   Public Declare PtrSafe Function BitBlt& Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop As Long)
    'Просканировать изображение в массив
   Public Declare PtrSafe Function GetDIBits Lib "gdi32.dll" (ByVal hdc As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
   
   Public Declare PtrSafe Function ShowWindow Lib "user32.dll" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long ' Показать окно с разными параметрами
#ElseIf Not Win64 Then 'Варинат для 2003 офиса на Win 32

   'Функция получения координат прямоугольника-контрола
   Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
   'Функция для получения дескриптора контекстного устройства (напри. экран клиентской области формы).
   Public Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
   'Освобождение контекстного устройства после вызова GetDC
   Public Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hdc As Long) As Long
   'получить информацию относительно экранного устройства: экран монитора, принтер, плоттер
   Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
   'Получить системные параметры
   Public Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
   'Получить RGB-цвет пикселя по его координатам
   Public Declare Function GetPixel Lib "gdi32.dll" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
   'Отрисовать RGB-точку
   Public Declare Function SetPixel& Lib "gdi32.dll" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long)
   
   'Преобразовать побитовое изображение в изображение для экрана (при рисовании)
   Public Declare Function SetDIBits Lib "gdi32.dll" (ByVal hdc As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, ByRef lpBits As Any, ByRef lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
   'Просканировать изображение в массив
   Public Declare Function GetDIBits Lib "gdi32.dll" (ByVal hdc As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
   'Перенос изображения из/в: контекст отображения <--> контекст памяти
   'Передача прямоугольника пикселей с поверхности источника на поверхность приемника
   Public Declare Function BitBlt& Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop As Long)
   'Создание копии совместимого контекстного устройства DC
   Public Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
   'Создается раст, совместимый с контекстным устройством DC
   Public Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
   'Выбор объекта изображения в контекстное устройство DC
   Public Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
   'Удаление контекстного устройства
   Public Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
   
   Public Declare Function ShowWindow Lib "user32.dll" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long ' Показать окно с разными параметрами
#ElseIf Win64 Then 'Варинат для 32bit офиса на Win 64
   
   'Функция получения координат прямоугольника-контрола
   Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As LongLong, lpRect As RECT) As LongLong
   'Функция для получения дескриптора контекстного устройства (напри. экран клиентской области формы).
   Public Declare Function GetDC Lib "user32.dll" (ByVal hwnd As LongLong) As LongLong
   'Освобождение контекстного устройства после вызова GetDC
   Public Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As LongLong, ByVal hdc As LongLong) As LongLong
   'получить информацию относительно экранного устройства: экран монитора, принтер, плоттер
   Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongLong, ByVal nIndex As LongLong) As LongLong
   'Получить системные параметры
   Public Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As LongLong) As LongLong
   'Получить RGB-цвет пикселя по его координатам
   Public Declare Function GetPixel Lib "gdi32" (ByVal hdc As LongLong, ByVal X As LongLong, ByVal Y As LongLong) As LongLong
   'Отрисовать RGB-точку
   Public Declare Function SetPixel& Lib "gdi32" (ByVal hdc As LongLong, ByVal X As LongLong, ByVal Y As LongLong, ByVal crColor As LongLong)
   
   'Преобразовать побитовое изображение в изображение для экрана (при рисовании)
   Public Declare Function SetDIBits Lib "gdi32.dll" (ByVal hdc As LongLong, ByVal hBitmap As LongLong, ByVal nStartScan As LongLong, ByVal nNumScans As LongLong, ByRef lpBits As Any, ByRef lpBI As BITMAPINFO, ByVal wUsage As LongLong) As LongLong
   'Просканировать изображение в массив
   Public Declare Function GetDIBits Lib "gdi32.dll" (ByVal hdc As LongLong, ByVal hBitmap As LongLong, ByVal nStartScan As LongLong, ByVal nNumScans As LongLong, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As LongLong
   'Перенос изображения из/в: контекст отображения <--> контекст памяти
   'Передача прямоугольника пикселей с поверхности источника на поверхность приемника
   Public Declare Function BitBlt& Lib "gdi32" (ByVal hDestDC As LongLong, ByVal X As LongLong, ByVal Y As LongLong, ByVal nWidth As LongLong, ByVal nHeight As LongLong, ByVal hSrcDC As LongLong, ByVal XSrc As LongLong, ByVal YSrc As LongLong, ByVal dwRop As LongLong)
   'Создание копии совместимого контекстного устройства DC
   Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongLong) As LongLong
   'Выбор объекта изображения в контекстное устройство DC
   Public Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As LongLong, ByVal hObject As LongLong) As LongLong
   'Удаление контекстного устройства
   Public Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As LongLong) As LongLong
#End If

Public Type RECT 'Тип, хранящий координаты прямоугольника контрола
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End Type

'Константы функции GetDeviceCaps параметра nIndex
Public Const LOGPIXELSX As Long = 88 'Число пикселей на горизонтальный логический дюйм
Public Const HORZSIZE As Long = 4& 'Размер по горизонтали в пикселях
Public Const VERTSIZE As Long = 6& 'Размер по вертикали в пикселях
Public Const HORZRES As Long = 8 'Разрешение по горизонтали в пикселях
Public Const VERTRES As Long = 10 'Разрешение по вертикали в пикселях
Public Const BITSPIXEL As Long = 12 'Глубина цвета в битах
Public Const VREFRESH As Long = 116 'Частота кадров монитора в герцах

'Константы функции GetSystemMetrics
Public Const SM_CXSCREEN As Long = 0 'Ширина экрана в пикселях
Public Const SM_CYSCREEN As Long = 1 'Высота экрана в пикселях

'Константа функции GetDIBits
Public Const DIB_RGB_COLORS = &H0 'RGB-палитра

'Типы и константы для получения информации в BITMAP вид
Public Type BITMAPINFOHEADER
  bmSize As Long
  bmWidth As Long
  bmHeight As Long
  bmPlanes As Integer
  bmBitCount As Integer
  bmCompression As Long
  bmSizeImage As Long
  bmXPelsPerMeter As Long
  bmYPelsPerMeter As Long
  bmClrUsed As Long
  bmClrImportant As Long
End Type
Public Type RGBTRIPLE
  Blue As Byte
  Green As Byte
  Red As Byte
  rgbReserved As Byte
End Type
Public Type BITMAPINFO
  bmHeader As BITMAPINFOHEADER
  bmColors As RGBTRIPLE
End Type

'Способы копирования функцией BitBlt в параметре dwRop
Public Const SRCCOPY = &HCC0020 'Полное копирование

Public Const BI_RGB As Long = 0 'Картинка в виде несжатого растра
'---------------------------------------------------------------------------------------------------------------------------------------------------

Public Const SW_MINIMIZE = 6 ' Свернуть окно и активизировать следующее окно в Z-порядке(следующее под свернутым окном)

Dim ScreenH As Long, ScreenW As Long 'Разрешение экрана. Инициализируются при вызове ScanScreen
'--------------------------------------------------------------------------------------------------------------------------------------------------

Public Sub test()
Dim Scan() As RGBTRIPLE 'Отсканированный массив
Dim hdc As Long ' хэндл контекстного устройства
Dim x As Long, y As Long 'Координаты для попиксельной перерисовки экрана
Dim Color As Long

ScanScreen Scan 'Копируем экран в массив
ShowWindow Application.hwnd, SW_MINIMIZE

hdc = GetDC(0)
'Перерисовываем верхнюю половину экрана
Application.ScreenUpdating = False 'Для чистоты эксперимента запрещаем обновление экрана
For x = 0 To ScreenW - 1
   For y = 0 To ScreenH / 2 - 1 '
       Color = Scan(x, y).Blue * (256 ^ 2) + CLng(Scan(x, y).Green) * 256 + Scan(x, y).Red
       SetPixel hdc, x, y, Color
   Next y
Next x
ReleaseDC 0, hdc
Application.ScreenUpdating = True 'Восстанавливаем обновление экрана

End Sub


Private Sub ScanScreen(Picture() As RGBTRIPLE)
'Функция сканирования экрана в массив Picture
Dim hdc As Long 'DC экрана
Dim Bitp As Long 'Глубина цвета в битах (12 или 24)
Dim hTmpDC As Long ' Временное DC для сканирования изображения
Dim hTmpBmp As Long 'Указатель на совместимый точечный рисунок
'Dim ScreenW As Long, ScreenH As Long 'Ширина и высота экрана
Dim BMP As BITMAPINFO 'Переменная, хранящая информацию о bmp рисунке
Dim Res As Long
Dim BytesPerScanLine As Long

hdc = GetDC(0) 'Получаем весь экран рабочего стола
ScreenW = GetDeviceCaps(hdc, HORZRES) 'Ширина экрана в пикселях
ScreenH = GetDeviceCaps(hdc, VERTRES) 'Выстоа экрана в пикселях

Bitp = GetDeviceCaps(hdc, BITSPIXEL) 'Получаем глубину цвета
hTmpDC = CreateCompatibleDC(hdc) 'Создаем DC, совместимую с экранной областью
hTmpBmp = CreateCompatibleBitmap(hdc, ScreenW, ScreenH) 'Создаю холст экрана
'Объектом для TmpDC выбираем растровый рисунок (варианты: кисть, шрифт, перо...)
Res = SelectObject(hTmpDC, hTmpBmp)

'Попиксельное копирование изображения из DC экрана во временное DC памяти (hTmpDC)
'первая пара 0,0 - координаты X,Y блока изображения получателя
'ScreenW, ScreenH - ширина и высота копируемого изображения
'последняя пара 0,0 - координаты X,Y блока изображения источника
'SRCCOPY - полное копирование без обработки
Res = BitBlt(hTmpDC, 0, 0, ScreenW, ScreenH, hdc, 0, 0, SRCCOPY)

With BMP.bmHeader
  .bmSize = Len(BMP.bmHeader) 'Размер блока .bmHeader в байтах
  .bmBitCount = Bitp 'Цветовая палитра ресунка
  .bmClrImportant = 0
  .bmClrUsed = 0
  .bmCompression = BI_RGB 'Без сжатия
  .bmHeight = -ScreenH
  .bmWidth = ScreenW 'Ширина рисунка
  .bmPlanes = 1 'Количество битовых плоскостей
  BytesPerScanLine = ((((.bmWidth * .bmBitCount) + 31) / 32) * 4)
  .bmSizeImage = BytesPerScanLine * Abs(.bmHeight)
  .bmXPelsPerMeter = 0
  .bmYPelsPerMeter = 0
End With

'Определяем размеры массива под сканирование экрана
ReDim Picture(0 To ScreenW - 1, 0 To ScreenH - 1)
'Получаем попиксельную информацию с экрана в массив
Res = GetDIBits(hTmpDC, hTmpBmp, 0, ScreenH, Picture(0, 0), BMP, DIB_RGB_COLORS)

DeleteDC hTmpDC 'Удаляем временно созданный DC
ReleaseDC 0, hdc 'Освобождаем контекстное DC
End Sub
[/spoiler]

Когда тестирую приложение на Win7 (с XP не пробовал), на  экране поверх скана книги эксель появляются ещё какие-то полосы вертикальные. Хотел сделать скриншот и прикрепить к теме, но на скриншоте эти полосы чудесным образом исчезают. Может проблема не в копировании а в отработке SetPixel.
Народ, проверьте, кто с этими API работал, приложение функционирует, или это особенности Win7 накладываются на повторно отрисованный экран? Допускаю, что у меня могут быть какие-то системные типы неправильно определены. Например, долго бодался, пока нашел, что отзеркаливание изображения у меня было из-за того, что нужно ставить знак минус в выражении  .bmHeight = -ScreenH
Код тестирую на Win10, Office 2016 х64

[McConst]

У меня в коде вижу одно слабое место. В массиве Scan получаю кроме цветов и значение альфа-канала:
rgbReserved As Byte
В ходе отладки обнаружилось, что альфа-канал у разных пикселей разный. Есть и 255, есть и 0. Подозреваю, что вертикальные полосы - это фон, который просвечивается через пиксели со нулевым значением альфа-канала.
У меня в SetPixel через переменную Color типа Long передается только цвет. Альфа-канал в Color простым преобразованием я не засуну, так как Long знаковый и при старшем байте больше 127 переменная меняет знак на минус.
В связи с этим ещё один вопрос. Элемент массива Scan(x,y) с типом RGBTRIPLE имеет размер 4 байта. Хорошо бы их впихнуть в Color с типом Long (4 байта). Скорее всего это легко сделать через указатель. Адрес элемента массива я могу получить через VarPtr. Вопрос такой. Можно ли считать байты элемента массива по адресу VarPtr в Color? Провести таким хитрым способом преобразование типов. Напрямую бейсик не позволяет.

[McConst]

Запустил программу на виртуальных машинах VirtualBox: WinXP х32 и Win7 х64 в офисе 2003. Работает идеально. Значит как минимум на 2003 офисе всё задекларировано правильно и в целом алгоритм рабочий. Цветные вертикальные полосы при воспроизведении экрана на Win10 х64 - это пробиваются цвета от окон, которые находятся ниже рабочей книги в момент копирования. Т.е. часть пикселей почему-то воспроизводятся прозрачными. Отчего на Win10 программа начинает глючить, не понимаю. Возможно функции SetPixel или GetDIBits или BitBlt задекларированы для офиса х64 неправильно.

[McConst]

Переписал все API под офис версии 2010 и выше согласно примерам, приведенным здесь:
http://www.cadsharp.com/docs/Win32API_PtrSafe.txt
Действительно, я задекларировал многие функции не совсем правильно, но проблема от этого не решилась.

Пришла в голову такая мысль, что API SetPixel просто не успевает отрисовывать в цикле отсканированный массив на экране, отсюда и прозрачные вертикальные полосы-пропуски (отрисовка идет сначала сверху вниз, затем слева направо).
Поставил в цикле процедуры Test паузу и DoEvents таким образом:

Код (vb) Выделить Развернуть


For x = 0 To ScreenW - 1
    For y = 0 To ScreenH / 2 - 1 '
        Color = GetColor(Scan(x, y))
        SetPixel hdc, x, y, Color
        For i = 1 To 10
            DoEvents
        Next i
    Next y
Next x

Эксперимент показал, что мысль частично верная, но не совсем.
Верхняя четверть экрана отрисовывается вообще без полосок, идеально, а пропуски остаются в нижней четверти экрана. При этом во время замедленного выполнения отрисовки стало хорошо видно, что все отсканированные пиксели функцией SetPixel сначала прорисовываются, затем что-то их затирает. Или Windows10 или сама SetPixel затирает соседние пиксели при прорисовке следующих.
Но это не принципиально. Главное, что я смог проверить, что сканирование экрана происходит правильно, всё без проблем передается в массив, который уже можно обрабатывать достаточно быстро.

На всякий случай размещаю код сканирования экрана на VBA c учетом правильного декларирования API для VBA7 офиса версии 2010 и выше.

[spoiler]

Код (vb) Выделить Развернуть


Option Explicit


'Примеры декларации для некоторых API на офис х64 здесь: http://www.cadsharp.com/docs/Win32API_PtrSafe.txt

#If VBA7 Then
    Public Declare PtrSafe Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
#Else
    Public Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
#End If
'-----------------------------------------------------------------------------------------------------------------------
'Функции для работы с экраном и координатами форм
'
#If VBA7 Then
    'Функция получения координат прямоугольника-контрола
    Public Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As LongPtr
    'Функция для получения дескриптора контекстного устройства (напри. экран клиентской области формы).
    Public Declare PtrSafe Function GetDC Lib "user32.dll" (ByVal hwnd As LongPtr) As LongPtr
     'Освобождение контекстного устройства после вызова GetDC
    Public Declare PtrSafe Function ReleaseDC Lib "user32.dll" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
    'получить информацию относительно экранного устройства: экран монитора, принтер, плоттер
    Public Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
    'Получить системные параметры
    Public Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    'Получить RGB-цвет пикселя по его координатам
    Public Declare PtrSafe Function GetPixel Lib "gdi32" (ByVal hdc As LongPtr, ByVal x As Long, ByVal y As Long) As Long
    'Отрисовать RGB-точку
    Public Declare PtrSafe Function SetPixel Lib "gdi32" (ByVal hdc As LongPtr, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
    Declare PtrSafe Function SetPixelV Lib "gdi32" (ByVal hdc As LongPtr, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
    'Создание копии совместимого контекстного устройства DC
    Public Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
    'Создается раст, совместимый с контекстным устройством DC
    Public Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    'Выбор объекта изображения в контекстное устройство DC
    Public Declare PtrSafe Function SelectObject Lib "gdi32.dll" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
    'Удаление контекстного устройства
    Public Declare PtrSafe Function DeleteDC Lib "gdi32.dll" (ByVal hdc As LongPtr) As Long
    'Перенос изображения из/в: контекст отображения <--> контекст памяти
    'Передача прямоугольника пикселей с поверхности источника на поверхность приемника
    Public Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As LongPtr, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
     'Просканировать изображение в массив
    Public Declare PtrSafe Function GetDIBits Lib "gdi32" (ByVal aHDC As LongPtr, ByVal hBitmap As LongPtr, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
   
    Public Declare PtrSafe Function ShowWindow Lib "user32.dll" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long ' Показать окно с разными параметрами
#ElseIf Not Win64 Then 'Варинат для 2003 офиса на Win 32

    'Функция получения координат прямоугольника-контрола
    Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    'Функция для получения дескриптора контекстного устройства (напри. экран клиентской области формы).
    Public Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
    'Освобождение контекстного устройства после вызова GetDC
    Public Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    'получить информацию относительно экранного устройства: экран монитора, принтер, плоттер
    Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
    'Получить системные параметры
    Public Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    'Получить RGB-цвет пикселя по его координатам
    Public Declare Function GetPixel Lib "gdi32.dll" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
    'Отрисовать RGB-точку
    Public Declare Function SetPixel Lib "gdi32.dll" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
   
    'Преобразовать побитовое изображение в изображение для экрана (при рисовании)
    Public Declare Function SetDIBits Lib "gdi32.dll" (ByVal hdc As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, ByRef lpBits As Any, ByRef lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
    'Просканировать изображение в массив
    Public Declare Function GetDIBits Lib "gdi32.dll" (ByVal hdc As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
    'Перенос изображения из/в: контекст отображения <--> контекст памяти
    'Передача прямоугольника пикселей с поверхности источника на поверхность приемника
    Public Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop As Long) As Long
    'Создание копии совместимого контекстного устройства DC
    Public Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
    'Создается раст, совместимый с контекстным устройством DC
    Public Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
    'Выбор объекта изображения в контекстное устройство DC
    Public Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
    'Удаление контекстного устройства
    Public Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
   
    Public Declare Function ShowWindow Lib "user32.dll" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long ' Показать окно с разными параметрами
#ElseIf Win64 Then 'Варинат для 32bit офиса на Win 64
   
    'Функция получения координат прямоугольника-контрола
    Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As LongLong, lpRect As RECT) As LongLong
    'Функция для получения дескриптора контекстного устройства (напри. экран клиентской области формы).
    Public Declare Function GetDC Lib "user32.dll" (ByVal hwnd As LongLong) As LongLong
    'Освобождение контекстного устройства после вызова GetDC
    Public Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As LongLong, ByVal hdc As LongLong) As LongLong
    'получить информацию относительно экранного устройства: экран монитора, принтер, плоттер
    Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongLong, ByVal nIndex As LongLong) As LongLong
    'Получить системные параметры
    Public Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As LongLong) As LongLong
    'Получить RGB-цвет пикселя по его координатам
    Public Declare Function GetPixel Lib "gdi32" (ByVal hdc As LongLong, ByVal x As LongLong, ByVal y As LongLong) As LongLong
    'Отрисовать RGB-точку
    Public Declare Function SetPixel& Lib "gdi32" (ByVal hdc As LongLong, ByVal x As LongLong, ByVal y As LongLong, ByVal crColor As LongLong)
   
    'Преобразовать побитовое изображение в изображение для экрана (при рисовании)
    Public Declare Function SetDIBits Lib "gdi32.dll" (ByVal hdc As LongLong, ByVal hBitmap As LongLong, ByVal nStartScan As LongLong, ByVal nNumScans As LongLong, ByRef lpBits As Any, ByRef lpBI As BITMAPINFO, ByVal wUsage As LongLong) As LongLong
    'Просканировать изображение в массив
    Public Declare Function GetDIBits Lib "gdi32.dll" (ByVal hdc As LongLong, ByVal hBitmap As LongLong, ByVal nStartScan As LongLong, ByVal nNumScans As LongLong, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As LongLong
    'Перенос изображения из/в: контекст отображения <--> контекст памяти
    'Передача прямоугольника пикселей с поверхности источника на поверхность приемника
    Public Declare Function BitBlt& Lib "gdi32" (ByVal hDestDC As LongLong, ByVal x As LongLong, ByVal y As LongLong, ByVal nWidth As LongLong, ByVal nHeight As LongLong, ByVal hSrcDC As LongLong, ByVal XSrc As LongLong, ByVal YSrc As LongLong, ByVal dwRop As LongLong)
    'Создание копии совместимого контекстного устройства DC
    Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongLong) As LongLong
    'Выбор объекта изображения в контекстное устройство DC
    Public Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As LongLong, ByVal hObject As LongLong) As LongLong
    'Удаление контекстного устройства
    Public Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As LongLong) As LongLong
#End If

Public Type RECT 'Тип, хранящий координаты прямоугольника контрола
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

'Константы функции GetDeviceCaps параметра nIndex
Public Const LOGPIXELSX As Long = 88 'Число пикселей на горизонтальный логический дюйм
Public Const HORZSIZE As Long = 4& 'Размер по горизонтали в пикселях
Public Const VERTSIZE As Long = 6& 'Размер по вертикали в пикселях
Public Const HORZRES As Long = 8 'Разрешение по горизонтали в пикселях
Public Const VERTRES As Long = 10 'Разрешение по вертикали в пикселях
Public Const BITSPIXEL As Long = 12 'Глубина цвета в битах
Public Const VREFRESH As Long = 116 'Частота кадров монитора в герцах

'Константы функции GetSystemMetrics
Public Const SM_CXSCREEN As Long = 0 'Ширина экрана в пикселях
Public Const SM_CYSCREEN As Long = 1 'Высота экрана в пикселях

'Константа функции GetDIBits
Public Const DIB_RGB_COLORS = &H0 'RGB-палитра

'Типы и константы для получения информации в BITMAP вид
Public Type BITMAPINFOHEADER
   bmSize As Long
   bmWidth As Long
   bmHeight As Long
   bmPlanes As Integer
   bmBitCount As Integer
   bmCompression As Long
   bmSizeImage As Long
   bmXPelsPerMeter As Long
   bmYPelsPerMeter As Long
   bmClrUsed As Long
   bmClrImportant As Long
End Type
Public Type RGBTRIPLE
   Blue As Byte
   Green As Byte
   Red As Byte
   rgbReserved As Byte
End Type
Public Type BITMAPINFO
   bmHeader As BITMAPINFOHEADER
   bmColors As RGBTRIPLE
End Type

'Способы копирования функцией BitBlt в параметре dwRop
Public Const SRCCOPY = &HCC0020 'Полное копирование

Public Const BI_RGB As Long = 0 'Картинка в виде несжатого растра
'---------------------------------------------------------------------------------------------------------------------------------------------------

Public Const SW_MINIMIZE = 6 ' Свернуть окно и активизировать следующее окно в Z-порядке(следующее под свернутым окном)

Dim ScreenH As Long, ScreenW As Long 'Разрешение экрана. Инициализируются при вызове ScanScreen

Public Sub test()
Dim Scan() As RGBTRIPLE 'Отсканированный массив
#If VBA7 Then
    Dim hdc As LongPtr  ' хэндл контекстного устройства
#Else
    Dim hdc As Long  ' хэндл контекстного устройства
#End If
Dim x As Long, y As Long 'Координаты для попиксельной перерисовки экрана
Dim Color As Long
Dim i As Long



ScanScreen Scan 'Копируем экран в массив
ShowWindow Application.hwnd, SW_MINIMIZE

hdc = GetDC(0)
'Перерисовываем верхнюю половину экрана
'В идеале после перерисовки на экране ничего не должно измениться
Application.ScreenUpdating = False 'Для чистоты эксперимента запрещаем обновление экрана
For x = 0 To ScreenW - 1
    For y = 0 To ScreenH / 2 - 1 '
        Color = GetColor(Scan(x, y))
        SetPixel hdc, x, y, Color
        'Ниже закомментирована пауза, в которой видно, что сканирование в массив Scan выполнено правильно, но пиксели затираются после их прорисовки
'        For i = 1 To 10
'            DoEvents
'        Next i
    Next y
Next x
ReleaseDC 0, hdc
Application.ScreenUpdating = True 'Восстанавливаем обновление экрана

End Sub


Private Sub ScanScreen(Picture() As RGBTRIPLE)
'Функция сканирования экрана в массив Picture
#If VBA7 Then
    Dim hdc As LongPtr  'DC экрана
    Dim hTmpDC As LongPtr ' Временное DC для сканирования изображения
    Dim hTmpBmp  As LongPtr 'Указатель на совместимый точечный рисунок
#Else
    Dim hdc As Long  'DC экрана
    Dim hTmpDC As Long ' Временное DC для сканирования изображения
    Dim hTmpBmp  As Long 'Указатель на совместимый точечный рисунок
#End If

Dim Bitp As Long 'Глубина цвета в битах (12 или 24)

'Dim ScreenW As Long, ScreenH As Long 'Ширина и высота экрана
Dim BMP As BITMAPINFO 'Переменная, хранящая информацию о bmp рисунке
Dim Res
Dim BytesPerScanLine As Long

hdc = GetDC(0) 'Получаем весь экран рабочего стола
ScreenW = GetDeviceCaps(hdc, HORZRES) 'Ширина экрана в пикселях
ScreenH = GetDeviceCaps(hdc, VERTRES) 'Выстоа экрана в пикселях

Bitp = GetDeviceCaps(hdc, BITSPIXEL) 'Получаем глубину цвета
hTmpDC = CreateCompatibleDC(hdc) 'Создаем DC, совместимую с экранной областью
hTmpBmp = CreateCompatibleBitmap(hdc, ScreenW, ScreenH) 'Создаю холст экрана
'Объектом для TmpDC выбираем растровый рисунок (варианты: кисть, шрифт, перо...)
Res = SelectObject(hTmpDC, hTmpBmp)

'Попиксельное копирование изображения из DC экрана во временное DC памяти (hTmpDC)
'первая пара 0,0 - координаты X,Y блока изображения получателя
'ScreenW, ScreenH - ширина и высота копируемого изображения
'последняя пара 0,0 - координаты X,Y блока изображения источника
'SRCCOPY - полное копирование без обработки
Res = BitBlt(hTmpDC, 0, 0, ScreenW, ScreenH, hdc, 0, 0, SRCCOPY)

With BMP.bmHeader
   .bmSize = Len(BMP.bmHeader) 'Размер блока .bmHeader в байтах
   .bmBitCount = Bitp 'Цветовая палитра ресунка
   .bmClrImportant = 0
   .bmClrUsed = 0
   .bmCompression = BI_RGB 'Без сжатия
   .bmHeight = -ScreenH
   .bmWidth = ScreenW 'Ширина рисунка
   .bmPlanes = 1 'Количество битовых плоскостей
   BytesPerScanLine = ((((.bmWidth * .bmBitCount) + 31) / 32) * 4)
   .bmSizeImage = 0 'BytesPerScanLine * Abs(.bmHeight)
   .bmXPelsPerMeter = 0
   .bmYPelsPerMeter = 0
End With

'Определяем размеры массива под сканирование экрана
ReDim Picture(0 To ScreenW - 1, 0 To ScreenH - 1)
'Получаем попиксельную информацию с экрана в массив
Res = GetDIBits(hTmpDC, hTmpBmp, 0, ScreenH, Picture(0, 0), BMP, DIB_RGB_COLORS)

DeleteDC hTmpDC 'Удаляем временно созданный DC
ReleaseDC 0, hdc 'Освобождаем контекстное DC
End Sub

Private Function GetColor(Pixel As RGBTRIPLE) As Long
'Преобразование цвета RGBTRIPLE в Long

GetColor = CLng(Pixel.Blue) * 256 ^ 2 + CLng(Pixel.Green) * 256 + Pixel.Red

End Function
[/spoiler]

[McConst]

Обнаружил ошибку в коде.
Если приложение повторно вызывает функцию ScanScreen, API GetDIBits возвращает ошибку и не сканирует экран в массив. Документация по функциям подсказала, что после использования CreateCompatibleBitmap нужно удалять точечный рисунок функцией DeleteObject.
Я думал, что после удаления созданного мной DC рисунок удалится автоматически. Практика показала, что нет.
Вот такая последовательность команд устраняет проблему:

Код (vb) Выделить Развернуть

Res = GetDIBits(hTmpDC, hTmpBmp, 0, ScreenH, Picture(0, 0), BMP, DIB_RGB_COLORS)
If Res = 0 Then
    Stop
End If
DeleteObject hTmpBmp 'Освобождаю системные ресурсы, занятые под точечный рисунок
DeleteDC hTmpDC 'Удаляем временно созданный DC
ReleaseDC 0, hdc 'Освобождаем контекстное DC