Здравствуйте!
Взят готовый макрос (точнее, несколько) и почти заточен "под себя".
Пиксели выбранной картинки раскладывает по ячейкам в виде кода 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 |