Изображение в файл

[Владимир7]

На листе Excel ячейки имеют фоновый цвет.
Зная цвет каждой из ячеек на листе каким образом с помощью VBA можно создать файл типа jpg png bmp c изображением соответсвующем изображению на листе Excel, пиксель нового файла должен быть такого же цвета как цвет фона отдельной ячейки листа Excel ?

[Денис]

Следующий код НЕ работает. Но должен! Посмотрите, где ошибка? Так вместе и поможем автору.
(добавляем в VBA-проект excel новую форму и копируем в нее нижеследующее)

Код: Выделить всё

Option Explicit

Private Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long

Private Sub UserForm_Click()
   
    Dim x As Long
    Dim y As Long
       
    x = 10
    y = 10
   
    Dim picBuffer As Image
    Set picBuffer = New Image
   
    picBuffer.Picture = LoadPicture("C:\Temp\xlsimg.bmp", x, y)
               
    For x = 1 To 10
    For y = 1 To 10
        Range("A1").Select
        ActiveCell.Offset(x, y).Range("A1").Select
        SetPixel GetDC(picBuffer.Picture.Handle), x, y, _
        ActiveCell.Interior.Color
       
        Range("A1").Select
    Next
    Next
   
    SavePicture picBuffer.Picture, "C:\Temp\xlsimg.bmp"
   
   
End Sub

[Владимир7]

Ваш код рабочий.
Даже в таком варианте: (только сохраняет первоначально открытое изображение)

Код: Выделить всё

Sub UserForm_Click()
    'Dim x As Long
    'Dim y As Long
    'x = 10
    'y = 10
    Dim picBuffer As Image
    Set picBuffer = New Image
    picBuffer.Picture = LoadPicture("D:\img.bmp", x, y)
    'For x = 1 To 10
    'For y = 1 To 10
    '    Range("A1").Select
    '    ActiveCell.Offset(x, y).Range("A1").Select
    '    SetPixel GetDC(picBuffer.Picture.Handle), x, y, ActiveCell.Interior.Color
    'Next
    'Next
    SavePicture picBuffer.Picture, "D:\xlsimg.bmp"
End Sub

[Viper] :: Не забываем пользоваться тэгами CODE!

[Andrev]

Следующий код НЕ работает. Но должен!

Код: Выделить всё

Может быть из-за того, что
[code]
picBuffer.Picture = LoadPicture("C:\Temp\xlsimg.bmp", x, y)
SavePicture picBuffer.Picture, "C:\Temp\xlsimg.bmp"
[/code] ?
   
   
End Sub

[Денис]

Следующий код НЕ работает. Но должен!

Может быть из-за того, что

Код: Выделить всё

picBuffer.Picture = LoadPicture("C:\Temp\xlsimg.bmp", x, y)
SavePicture picBuffer.Picture, "C:\Temp\xlsimg.bmp"


?


End Sub[/code]

Эмм, не понял, что ты хочешь сказать? Я делаю инициализацию IPictureDisp временным изображением из файла, а затем в этот же файл записываю полученное изображение. Это минус, да.

[Владимир7]

Цель не открыть файл-картинку и сохранить её же на диск, может даже и с новым именем.
Если взять, например, редактор иконок, то закрасив несколько квадратиков в таком редакторе, получаем новый файл изображения, в котором закраска пикселей такая же как и при редактировании иконки.
Работа в подобном графическом редакторе и даёт мысль о возможном использовании Excel для создания с нуля или редактировании имеющихся файлов изображений. В графическом редакторе cоздание/редактирование изображения одновариантно вручную, и как раз обратное можно сказать о возможностях Excel.

[Денис]

Работа в подобном графическом редакторе и даёт мысль о возможном использовании Excel для создания с нуля или редактировании имеющихся файлов изображений.

Бедные нубы, до чего только не додумаются. Ничего, сам таким был.
Забей на Excel, Владимир, давай лучше мы научим тебя загружать изображение в Picturebox, квадратиками, с сеточкой, всё как в редакторах иконок. Хочешь?

[Владимир7]

Нубы - первый раз слышу - надо в сети поиском найти - любопытно!
В Picturebox, квадратиками - не хочу, интересует то о чём пишу (не упрямый ребенок, а целеустремлённная личность )
Сам таким был - сейчас то можешь подсказать направление решения именно Excel VBA ?
Пусть не полное решение, ну хоть бы направление верное...

[Денис]

сейчас то можешь подсказать направление решения именно Excel VBA

Уже подсказал. В своем первом сообщении.

[Владимир7]

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

[Владимир7]

Денис, не пойму в чём подсказка, примерно так как Вы говорите, я делал свой первый файл, тот что в первом посте с фоновой картинкой Excel. Это как бы этап пройденный. Пожалуйста вернитесь непосредственно к теме вопроса, может Вы встречали в сети что либо подобное, хотелось бы всё таки решить проблему.

[Денис]

Денис, не пойму в чём подсказка

Давайте сначала говорить на одном языке, а не на разных. Для того,чтобы это сделать, сформируйте алгоритм решения вашей задачи по шагам. Затем мы вместе начнем разбирать шаги по отдельности. Вот пример алгоритма:

• Проснулся.
• Открыл глаза.
• Откинул одеяло.
• Опустил на пол ноги.
• Обул правую ногу в правый тапок.
• Обул левую ногу в левый тапок.

Надеюсь смысл ясен.

[Владимир7]

Алгоритм предельно прост:
1. Открываем новый лист Excel;
2. В ячейках А1, А2 задаём фон зеленого цвета;
3. В ячейках В1, В2 задаём фон синего цвета;
4. Сохраняем на диске файл;
5. Оставляем Excel в покое, начинаем изучать форматы файлов изображений и порядок их создания;
6. И вот когда Educated Full можно вернуться к своему файлу Excel и используя VBA создать интересующий нас новый файл изображения в котором левый верхний пиксель будет зеленого цвета и т.д.

Пока я застрял по этому алгоритму на первой половине 5 пункта

[Денис]

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

5.1. Чтобы не забивать себе голову форматами файлов на данном этапе, рекомендую использовать
5.2. функции GetPixel() SetPixel().
Есть в моем коде, который я привел сразу же. Первая получает значение цвета пиксела по указанным координатам картинки, измеряя ее в пикселах, вторая записывает в картинку значение цвета пиксела по указанным координатам. Картинка, это объект. У меня в примере он называется picBuffer. При создании объекта, он пустой. Как правильно проинициализировать его я не знаю (и сдается мне это и не возможно) кроме как загрузить в него любой BMP-файл с диска. Что я и делаю в примере.
Проблема в том, что цвета из ячеек не хотят записываться в объект-картинку, о чем я и написал сразу же, что приведенный код не работает.
Ждем, пока кто-нибудь нам еще поможет советом.

[Владимир7]

Нашёл для начала:
http://jenyay.net/Programming/Bmp
но это уж наверно такой длинный путь...
GetPixel() для получения цвета пикселей из исходной картинки с диска и закраски фонового цвета ячеек листа - да,
SetPixel() надо пробовать.

[Денис]

Любопытная ссылка, сейчас гляну, а пока, с нуля склепал такой код:

Код: Выделить всё

Option Explicit

Private Sub UserForm_Click()
   
    Dim X As Integer
    Dim Y As Integer
    Dim b As Byte
    Dim s As String
    Dim s0 As String
    Dim BMP_HEADER As String
   
    X = 10
    Y = 10
   
    BMP_HEADER = "BM:" & _
                String(7, Chr$(0)) & _
                "6" & _
                String(3, Chr$(0)) & _
                "(" & _
                String(3, Chr$(0)) & _
                Chr$(X) & _
                String(3, Chr$(0)) & _
                Chr$(Y) & _
                String(3, Chr$(0)) & _
                Chr$(1) & Chr$(0) & Chr$(&H18) & _
                String(5, Chr$(0)) & _
                Chr$(4) & _
                String(19, Chr$(0))
   
    Open "C:\Temp\xlsimg.bmp" For Binary As #1
        For X = 1 To Len(BMP_HEADER)
            s = Mid$(BMP_HEADER, X, 1)
            Put #1, , s
        Next

    For Y = 0 To 9
        For X = 0 To 9
            Range("A1").Select
            ActiveCell.Offset(X, Y).Range("A1").Select
            Put #1, , ActiveCell.Interior.Color
            Range("A1").Select
        Next
    Next
   
    Close #1
       
End Sub


Файл сохраняется, но цвета передаются неправильно. После праздников потыкаю еще.

[Владимир7]

Подвижка есть,
цвета пока ещё не те, разные вариации записи в новый файл, в.т.ч. RGB не выдают решение

Код: Выделить всё

Private Sub UserForm_Click()
    Dim x As Integer, Y As Integer, b As Byte, s As String, s0 As String, BMP_HEADER As String, str0 As String, str As String
    x = 10: Y = 10
    BMP_HEADER = "BM:" & String(7, Chr$(0)) & "6" & String(3, Chr$(0)) & "(" & String(3, Chr$(0)) & Chr$(x) & String(3, Chr$(0)) & Chr$(Y) & String(3, Chr$(0)) & Chr$(1) & Chr$(0) & Chr$(&H18) & String(5, Chr$(0)) & Chr$(4) & String(19, Chr$(0))
    Open "D:\Downloads\LR.bmp" For Binary As #1
    For cX = 1 To Len(BMP_HEADER)
        s = Mid$(BMP_HEADER, cX, 1)
        Put #1, , s
    Next
    For bY = 0 To 9
        For aX = 0 To 9
            str0 = Right("000000" & Hex(Cells(aX + 1, bY + 1).Interior.Color), 6)
            str = Right(str0, 2) & Mid(str0, 3, 2) & Left(str0, 2)
            re = ConvertDec(Right(str0, 2)): gr = ConvertDec(Mid(str0, 3, 2)): bl = ConvertDec(Left(str0, 2))
            cv = re & gr & bl 'cv = re & "." & gr & "." & bl 'cv = 254000000'cv = 254254254'cv = "&H254"
            Put #1, , cv
        Next
    Next
    Close #1
    Me.Hide
End Sub
Function ConvertDec(heximal) As Long
    Dim Simvol As String, DesChislo As Long, x As Long
    ConvertDec = 0
    For x = 1 To Len(heximal)
        Simvol = Mid(heximal, x, 1)
        If UCase(Simvol) = "A" Then
            DesChislo = 10
        ElseIf UCase(Simvol) = "B" Then
            DesChislo = 11
        ElseIf UCase(Simvol) = "C" Then
            DesChislo = 12
        ElseIf UCase(Simvol) = "D" Then
            DesChislo = 13
        ElseIf UCase(Simvol) = "E" Then
            DesChislo = 14
        ElseIf UCase(Simvol) = "F" Then
            DesChislo = 15
        Else
            DesChislo = Val(Simvol)
        End If
        ConvertDec = ConvertDec + DesChislo * 16 ^ (Len(heximal) - x)
    Next x
End Function


[Viper]

Работа со строками при записи/чтении изображения это мягко говоря неправильно. То есть совсем.

[Владимир7]

Та да, неправильно.
Приятно что проявили интерес такие уважаемые люди!

[Денис]

Работа со строками при записи/чтении изображения это мягко говоря неправильно. То есть совсем.

Надеюсь, это не мне было адресовано? Потому что в моем примере я работал с байтами (несмотря на то, что заголовки я получил обратной разработкой из шестнадцатеричного дампа bmp-файла и объявил их как строку, я все равно работаю с ней (строкой) как с массивом байтов.

[Владимир7]

Люди тоже как то делали:
http://www.vb-helper.com/howto_create_icon.html
http://www.andypope.info/vba/gex.htm
http://www.andypope.info/vba/buttoneditor.htm

[Денис]

Люди тоже как то делали:
http://www.vb-helper.com/howto_create_icon.html
http://www.andypope.info/vba/gex.htm
http://www.andypope.info/vba/buttoneditor.htm

Это делалось либо на API либо в .Net, даже и не мечтай сделать это встроенными средствами VBA.

[Viper]

Работа со строками при записи/чтении изображения это мягко говоря неправильно. То есть совсем.

Надеюсь, это не мне было адресовано? Потому что в моем примере я работал с байтами (несмотря на то, что заголовки я получил обратной разработкой из шестнадцатеричного дампа bmp-файла и объявил их как строку, я все равно работаю с ней (строкой) как с массивом байтов.

Адресовано было несомненно Владимир7.