mail mail
Нужен макрос для Excel?
Сделайте заказ прямо сейчас!
Ищете готовое решение?
Выбирайте и покупайте!
У вас есть интернет-магазин?
Настроим парсер под любой сайт!

Конвертер BMP в Excel (попиксельный перенос изображения на лист)

Перенос изображения на лист Excel (чтение bitmap в массив)

Данный макрос читает информацию о цветах пикселей в битмапе (изображение 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 (единица)

ВложениеРазмерЗагрузкиПоследняя загрузка
Bitmap2Sheet.xls180 КБ6515 недель 1 день назад

Комментарии

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

Спасибо автору сайта за этот и другие примеры макросов, разобрался с BMP - mono. Дополнил свой программный комплекс "доп. инструмент администрирования системы Инфотех" - подсистемой "автоматизация документооборота" (генерация штрих-кодов в колонтитулах, ввод оригиналов заявок, распознавание макросами VBA и перемещение в хранилище). В данное время, зарегистрировано как рац. предл. без эк.эффекта.

Согласен, верхняя граница оговорена (не более 199 пикселей), но о нижней границе (не менее) нет упоминания.

Мне очень помогло, спасибо. Имеется также минимальное ограничение размера изображения. Если изображение меньше определённого размера, то при переводе происходит искажение. При переводе исказились буквы с изображений размером 30х30 пикселей.

Для корректной обработки изображения его ширина должна быть не более 199 пикселей.

Отправить комментарий

Содержание этого поля является приватным и не предназначено к показу.
CAPTCHA
Подтвердите, пожалуйста, что вы - человек:
   ___    _               ____    _   _   ____  
/ _ \ | |__ _ __ | _ \ | | | | | _ \
| | | | | '_ \ | '_ \ | |_) | | |_| | | |_) |
| |_| | | | | | | | | | | _ < | _ | | __/
\__\_\ |_| |_| |_| |_| |_| \_\ |_| |_| |_|
Введите код, изображенный в стиле ASCII-арт.

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.