Сделал функцию для изменения размеров картинок
(картинки на входе - разных форматов: jpg, bmp, gif, png и т.п., на выходе - jpg)
Всё работает, - если вызывать эту функцию для конкретной картинки, или из цикла СОТНИ раз.
Если же обрабатывать этой функцией в том же цикле ТЫСЯЧИ картинок, - возникают проблемы
Функция работает в виде макроса в Excel, и иногда Excel молча вылетает после обработки 2-3 тысяч картинок
(есть 5 тыс картинок. если обрабатывать их в 10 запусков по 500 картинок, - всё ОК, если запустить обработку всех 5000 сразу, - то возникает ошибка)
Код функции:
- Код: Выделить всё
Function ResizeImage(ByVal FileName As String, ByVal newFilename As String, ByVal NewWidth&, ByVal NewHeight&) As Boolean
Dim tJpgEncoder As GUID, tParams As EncoderParameters, uGdiInput As GdiplusStartupInput
#If VBA7 Then
Dim hGdiImage As LongPtr, hBitmap As LongPtr, quality As LongPtr, hGdiPlus As LongPtr, lRes As LongPtr
Dim lGDIP As LongPtr, hDC As LongPtr, hBrush As LongPtr, Graphics As LongPtr, hResizedBitmap As LongPtr
#Else
Dim hGdiImage As Long, hBitmap As Long, quality As Long, hGdiPlus As Long, lRes As Long
Dim lGDIP As Long, hDC As Long, hBrush As Long, Graphics As Long, hResizedBitmap As Long
#End If
uGdiInput.GdiplusVersion = 1: quality = 80
If GdiplusStartup(hGdiPlus, uGdiInput) = Status_OK Then 'Запускаем GDI+
If GdipCreateBitmapFromFile(StrPtr(FileName), hGdiImage) = Status_OK Then 'Создаём изображение в памяти
'Делаем из изображения уменьшенное
hDC = CreateCompatibleDC(ByVal 0&) ' Create a memory DC and select a bitmap into it, fill it in with the backcolor
hBitmap = CreateBitmap(NewWidth&, NewHeight&, GetDeviceCaps(hDC, PLANES), GetDeviceCaps(hDC, BITSPIXEL), ByVal 0&)
hBitmap = SelectObject(hDC, hBitmap)
hBrush = CreateSolidBrush(vbWhite)
hBrush = SelectObject(hDC, hBrush)
PatBlt hDC, 0, 0, NewWidth&, NewHeight&, PATCOPY
DeleteObject SelectObject(hDC, hBrush)
' Resize the picture
GdipCreateFromHDC hDC, Graphics
GdipSetInterpolationMode Graphics, InterpolationModeHighQualityBicubic
lRes = GdipDrawImageRectI(Graphics, hGdiImage, 0, 0, NewWidth&, NewHeight&)
GdipDeleteGraphics Graphics
GdipDisposeImage hGdiImage
' Get the bitmap back
hBitmap = SelectObject(hDC, hBitmap)
DeleteDC hDC
If GdipCreateBitmapFromHBITMAP(hBitmap, 0, hResizedBitmap) = 0 Then
CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder ' Initialize the encoder GUID
tParams.Count = 1 ' Initialize the encoder parameters
With tParams.Parameter ' Quality
CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID ' Set the Quality GUID
.NumberOfValues = 1: .Type = 4: .Value = VarPtr(quality)
End With
lRes = GdipSaveImageToFile(hResizedBitmap, StrPtr(newFilename), tJpgEncoder, tParams) ' Save the image
If lRes = 0 Then ResizeImage = True Else Debug.Print "Ошибка сохранения уменьшенного файла: " & lRes
GdipDisposeImage hResizedBitmap ' Destroy the bitmap
Else
Debug.Print "Ошибка преобразования размеров файла"
End If
End If
GdiplusShutdown hGdiPlus
Else
Debug.Print "Ошибка при загрузке GDI+!"
End If
End Function
Пример вызова функции:
- Код: Выделить всё
Sub test()
Dim file1$, file2$
file1$ = "C:\Documents and Settings\Admin\Рабочий стол\file.jpg"
file2$ = "C:\Documents and Settings\Admin\Рабочий стол\file_new.jpg"
Debug.Print ResizeImage(file1$, file2$, 100, 200) ' 100, 200 - новые размеры картинки
End Sub
Возможно, где-то из 5000 картинок одна - какая-то «проблемная», - но не в этом суть,
косяк однозначно в коде (раз он не учитывает все возможные ошибки)
После того, как проявляется ошибка, - перестаёт работать ресайз даже для отдельно взятой картинки (процедура test).
Проблема в этой строке кода:
- Код: Выделить всё
hBitmap = CreateBitmap(NewWidth&, NewHeight&, GetDeviceCaps(hDC, PLANES), GetDeviceCaps(hDC, BITSPIXEL), ByVal 0&)
когда функция перестаёт работать, в переменную hBitmap функция CreateBitmap возвращает ноль.
(соответственно, дальнейшая обработка в функции уже значения не имеет)
Если перезапустить Excel, и снова выполнить процедуру test, - всё снова начинает работать.
Функции WinAPI объявлены так: http://excelvba.ru/code/ResizeImages
(код функций в статье под спойлером)
PS: В WinAPI я плохо разбираюсь, в GDI/GDI+ - тем более.
Код собирал из нескольких источников по форумам, - возможно, где-то некорректно вызываются функции,
или вообще надо применять другой подход.
Вопрос: чем вызвано прекращение корректной работы функции после нескольких тысяч вызовов?
