Главная » Макросы для Excel » Конвертер BMP в 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 КБ
  • 13160 просмотров

Комментарии

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

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".
Игорь (администратор сайта), 10 Июн 2021 - 17:26.#1

Можем сделать под заказ. От 5000 руб.

Ino, 10 Июн 2021 - 16:12.#2

Не могу переделать это под 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 остается пустым, данные о размере и типе картинки не заполняются. Помогите плз.

Игорь (администратор сайта), 31 Июл 2018 - 20:36.#3

Я опубликовал то, что делал под заказ. Там не было ограничения на размер картинки.
Хотите опубликовать вариант для больших картинок, - сделайте сами да опубликуйте. Мне нет интереса делать это бесплатно.

Александр, 31 Июл 2018 - 15:36.#4

Моя благодарность автору за этот проект.
Просьба к автору: опубликуйте, пожалуйста, вариант конвертера, способный конвертировать значительно большие картинки.
Размеры в 199 пикселей - как-то несерьёзно, что ли...
Спасибо.

Ильфат, 19 Окт 2015 - 20:32.#5

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

Пётр, 11 Авг 2015 - 11:17.#6

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

Пётр, 10 Авг 2015 - 16:31.#7

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

Павел, 7 Июл 2011 - 16:00.#8

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

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

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

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

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