Здравствуйте!
Взят готовый макрос (точнее, несколько) и почти заточен "под себя".
Пиксели выбранной картинки раскладывает по ячейкам в виде кода RGB.
Прикручен стандартный статус-бар (внизу слева).
Прошу помочь ускорить работу, возможно организовав как-то массив, так как моя цель - конвертировать "тяжёлые" файлы изображений, например 6000x4000 пикселей.
Пока терпения хватает на небольшие картинки (примерно 800х500).
И ещё: если картинка не квадратная, а прямоугольная, конвертирование происходит неполное и с выводом ошибки. Почему?
Спасибо.
Сам файл прикрутить не могу: он почему-то весит порядка трёх МБ, хотя по количеству кода видно, что должен весить где-то 20-30 кБ.
Вот код:
Взят готовый макрос (точнее, несколько) и почти заточен "под себя".
Пиксели выбранной картинки раскладывает по ячейкам в виде кода RGB.
Прикручен стандартный статус-бар (внизу слева).
Прошу помочь ускорить работу, возможно организовав как-то массив, так как моя цель - конвертировать "тяжёлые" файлы изображений, например 6000x4000 пикселей.
Пока терпения хватает на небольшие картинки (примерно 800х500).
И ещё: если картинка не квадратная, а прямоугольная, конвертирование происходит неполное и с выводом ошибки. Почему?
Спасибо.
Сам файл прикрутить не могу: он почему-то весит порядка трёх МБ, хотя по количеству кода видно, что должен весить где-то 20-30 кБ.
Вот код:
| Код |
|---|
Option Explicit
Public Sub AAA()
Dim pIF As New WIA.ImageFile
Dim pV As WIA.Vector
Dim IP As New WIA.ImageProcess
Dim last As Long
Dim iRow, iCol As Long
Dim h As Single, w As Single
Dim FileName As String
Dim c As Range, i&
Dim lr As Long
Dim lAllCnt As Long 'количество итераций
Const lMaxQuad As Long = 20 'длина статус-бара
FileName = Application.GetOpenFilename _
("Рисунки bmp,*.bmp,Файлы Excel,*.xls*,Текстовые файлы txt,*.txt,Рисунки jpg,*.jpg", , "Выбор файла")
pIF.LoadFile FileName
'pIF.LoadFile "c:\кекс.jpg"
Application.ScreenUpdating = False
Dim sh As Worksheet: Set sh = ActiveSheet
sh.UsedRange.Interior.ColorIndex = 0
IP.Filters.Add IP.FilterInfos("Scale").FilterID
IP.Filters(1).Properties("MaximumWidth") = CLng(pIF.Width)
IP.Filters(1).Properties("MaximumHeight") = CLng(pIF.Height)
'last = CLng(pIF.Width# * CDbl(pIF.Height) / CDbl(pIF.Width))
Set pIF = IP.Apply(pIF)
Set pV = pIF.ARGBData
'Stop
For iRow = 1 To pIF.Height
For iCol = 1 To pIF.Width
'Cells(iRow, iCol).Interior.Color = GetColor(pV, pIF.Width, iCol, iRow)
i = GetColor(pV, pIF.Width, iCol, iRow)
Cells(iRow, iCol).Value = Format$(i Mod 256, "000\,") & Format$((i Mod 65536) \ 256, "000\,") & Format$(i \ 65536, "000")
Next iCol
Application.StatusBar = "Выполнено: " & Int(100 * iRow / iCol) & "%" & String(CLng(lMaxQuad * iRow / iCol), ChrW(9724)) & String(lMaxQuad - CLng(lMaxQuad * iRow / iCol), ChrW(9723))
Next iRow
'Очищаем статус-бар от значений после выполнения
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
Public Function GetColor(ByVal inVector As WIA.Vector, ByVal imgWidth As Long, ByVal xPixelID As Long, ByVal yPixelID As Long) As Long
Dim ToHex As String, vCount As Long
ToHex = VBA.Hex$(inVector(xPixelID + (yPixelID - 1&) * imgWidth))
vCount = VBA.Len(ToHex)
If vCount < 8 Then ToHex = VBA.String$(8 - vCount, "0") & ToHex
GetColor = VBA.RGB(CInt("&H" & VBA.Mid$(ToHex, 3, 2)), CInt("&H" & VBA.Mid$(ToHex, 5, 2)), CInt("&H" & VBA.Mid$(ToHex, 7, 2)))
End Function
Function GetFilePath(Optional ByVal Title As String = "Выберите файл для обработки", _
Optional ByVal InitialPath As String = "c:\", _
Optional ByVal FilterDescription As String = "Книги Excel", _
Optional ByVal FilterExtention As String = "*.xls*") As String
On Error Resume Next
With Application.FileDialog(msoFileDialogOpen)
.ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath
.Filters.Clear: .Filters.Add FilterDescription, FilterExtention
If .Show <> -1 Then Exit Function
GetFilePath = .SelectedItems(1): PS = Application.PathSeparator
End With
End Function |
