Данный макрос читает информацию о цветах пикселей в битмапе (изображение 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 пикселей - как-то несерьёзно, что ли...
Спасибо.
Спасибо автору сайта за этот и другие примеры макросов, разобрался с BMP - mono. Дополнил свой программный комплекс "доп. инструмент администрирования системы Инфотех" - подсистемой "автоматизация документооборота" (генерация штрих-кодов в колонтитулах, ввод оригиналов заявок, распознавание макросами VBA и перемещение в хранилище). В данное время, зарегистрировано как рац. предл. без эк.эффекта.
Согласен, верхняя граница оговорена (не более 199 пикселей), но о нижней границе (не менее) нет упоминания.
Мне очень помогло, спасибо. Имеется также минимальное ограничение размера изображения. Если изображение меньше определённого размера, то при переводе происходит искажение. При переводе исказились буквы с изображений размером 30х30 пикселей.
Для корректной обработки изображения его ширина должна быть не более 199 пикселей.
Отправить комментарий