Данный макрос читает информацию о цветах пикселей в битмапе (изображение 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 (единица)
Комментарии
Код написан давно (в 2011 году), под 32-битную версию Office
Нынче почти у всех 64-битный Office, потому, требуется адаптация кода.
макрос не работает даже с "родной" картинкой, постоянно та же ошибка
https://ibb.co/2ncSHdH
Можем сделать под заказ. От 5000 руб.
Не могу переделать это под VBA7 и Win64. Меняю декларирование апи функции на:
Private Declare PtrSafe Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As LongPtr, ByVal nCount As Long, lpObject As Any) As Long
Private Declare PtrSafe Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As LongPtr, ByVal dwCount As Long, lpBits As Any) As Long
Private Declare PtrSafe Function SetBitmapBits Lib "gdi32" (ByVal hBitmap As LongPtr, ByVal dwCount As Long, lpBits As Any) As Long
Объявление типа BITMAP меняю на:
Private Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As LongPtr
End Type
Но раскраска не работает:( PicInfo остается пустым, данные о размере и типе картинки не заполняются. Помогите плз.
Я опубликовал то, что делал под заказ. Там не было ограничения на размер картинки.
Хотите опубликовать вариант для больших картинок, - сделайте сами да опубликуйте. Мне нет интереса делать это бесплатно.
Моя благодарность автору за этот проект.
Просьба к автору: опубликуйте, пожалуйста, вариант конвертера, способный конвертировать значительно большие картинки.
Размеры в 199 пикселей - как-то несерьёзно, что ли...
Спасибо.
Спасибо автору сайта за этот и другие примеры макросов, разобрался с BMP - mono. Дополнил свой программный комплекс "доп. инструмент администрирования системы Инфотех" - подсистемой "автоматизация документооборота" (генерация штрих-кодов в колонтитулах, ввод оригиналов заявок, распознавание макросами VBA и перемещение в хранилище). В данное время, зарегистрировано как рац. предл. без эк.эффекта.
Согласен, верхняя граница оговорена (не более 199 пикселей), но о нижней границе (не менее) нет упоминания.
Мне очень помогло, спасибо. Имеется также минимальное ограничение размера изображения. Если изображение меньше определённого размера, то при переводе происходит искажение. При переводе исказились буквы с изображений размером 30х30 пикселей.
Для корректной обработки изображения его ширина должна быть не более 199 пикселей.
Отправить комментарий