 Данный макрос читает информацию о цветах пикселей в битмапе (изображение BMP), формирует двумерный массив, содержащий информацию о цвете каждого пикселя, после чего переносит массив цветов на лист (в цикле закрашивая ячейки). Поддерживаются только 24-битные изображения BMP без сжатия. Для чтения информации из bitmap используется функция API-функция GetBitmapBits Преобразование результатов работы функции GetBitmapBits в двумерный массив производится следующим кодом: Function Bitmap2Array(ByVal PicBits, ByVal Width%, ByVal Height%, _ Optional ByVal Color$ = "RGB") As Variant On Error Resume Next: Dim res As Long x = 0: y = 0: n = 0: ReDim arr(1 To Height%, 1 To Width%) bytesPerRow% = UBound(PicBits) / 3 / Height% For Cnt = 1 To UBound(PicBits) Step 3 x = (n Mod Width%) + 1 If x = 1 Then y = y + 1 Select Case Color$ Case "R": res = PicBits(Cnt + 2) Case "G": res = PicBits(Cnt + 1) Case "B": res = PicBits(Cnt + 0) Case "RGB": res = RGB(PicBits(Cnt + y - 1 + 2), _ PicBits(Cnt + y - 1 + 1), _ PicBits(Cnt + y - 1 + 0)) End Select arr(y, x) = res n = n + 1 Next Cnt Bitmap2Array = arr End Function Для переноса массива цветов на лист применяется такой макрос: Sub ColorArray2Sheet(ByVal arr, ByRef FirstCell As Range) 'Application.ScreenUpdating = False For i = 1 To UBound(arr, 1) For j = 1 To UBound(arr, 2) FirstCell.Offset(i, j).Interior.Color = arr(i, j) DoEvents Next j Next i End Sub Пароль на проект VBA: 1 (единица)
|
|||||||
Комментарии
Для корректной обработки изображения его ширина должна быть не более 199 пикселей.
Отправить комментарий