Imports System.IO
Imports System.Drawing.Imaging
Module All
Public Function GetJpegContent(ByVal Pct As Image) As Byte()
Dim File As New MemoryStream
Pct.Save(File, ImageFormat.Jpeg)
Return File.ToArray()
End Function
Public Function GetJpegContent(ByVal Pct As Image, ByVal Quality As Long) As Byte()
Dim File As New MemoryStream
Dim EncoderParams As New EncoderParameters(1)
EncoderParams.Param(0) = New EncoderParameter(Encoder.Quality, Quality)
Pct.Save(File, GetEncoderInfo("image/jpeg"), EncoderParams)
Return File.ToArray()
End Function
Private Function GetEncoderInfo(ByVal MimeType As String) As ImageCodecInfo
For Each Codec As ImageCodecInfo In ImageCodecInfo.GetImageEncoders()
If Codec.MimeType = MimeType Then Return Codec
Next Codec
Return Nothing
End Function
Public Function ReduceByQuality(ByVal Pct As Image, ByVal Lim As Integer) As Byte()
Dim LastOk() As Byte = Nothing, Res() As Byte
Dim L As Integer = 0, R As Integer = 100, Cur As Integer
Do While L < R
Cur = (L + R + 1) >> 1
Res = GetJpegContent(Pct, Cur)
If Res.Length > Lim Then
R = Cur - 1
Else
L = Cur
LastOk = Res
End If
Loop
Return LastOk
End Function
Public Function ReduceBySize(ByVal Pct As Image, ByVal Lim As Integer) As Byte()
Dim LastOk() As Byte = Nothing, Res() As Byte
Dim LHeight As Integer = 0, RHeight As Integer = Pct.Height, CurHeight As Integer
Dim LWidth As Integer = 0, RWidth As Integer = Pct.Width, CurWidth As Integer
Do While LHeight < RHeight
CurHeight = (LHeight + RHeight + 1) >> 1
CurWidth = (LWidth + RWidth + 1) >> 1
Res = GetJpegContent(New System.Drawing.Bitmap(CType(Pct, Bitmap), CurWidth, CurHeight))
If Res.Length > Lim Then
RHeight = CurHeight - 1
RWidth = CurWidth - 1
Else
LHeight = CurHeight
LWidth = CurWidth
LastOk = Res
End If
Loop
Return LastOk
End Function
Public Sub Main()
My.Computer.FileSystem.WriteAllBytes("ReduceByQuality.jpg", ReduceByQuality(Bitmap.FromFile("input.jpg"), 307200), False)
My.Computer.FileSystem.WriteAllBytes("ReduceBySize.jpg", ReduceBySize(Bitmap.FromFile("input.jpg"), 307200), False)
MsgBox("Ready")
End Sub
End Module
krukovis84 писал(а):По смыслу похоже на JavaScript.
krukovis84 писал(а):Есть какие то плюсы в применении вместо обычных WF ?
krukovis84 писал(а):Qwertiy, спасибо, офигенный пример. Спасибо!Мне почти работы не осталось
Qwertiy писал(а):Не так уж мало там осталось: добавить три проверки на Nothing
PS: Было бы интересно увидеть итоговый код.
Cur = (L + R + 1) >> 1
Qwertiy писал(а):Код, изменяющий размер, может немного подпортить пропорции изображения. Лучше использовать коэффициент сжатия.
krukovis84 писал(а):Имеется ввиду проверка на существование файла для двух преобразований (сущестование кодека, думаю бессмысленно проверять)?
krukovis84 писал(а):Во всем разобрался, кроме вот этой строчки. Поясните пожалуйста ее смысл. А точнее смысл битового сдвига.
- Код: Выделить всё
Cur = (L + R + 1) >> 1
krukovis84 писал(а):Что имеется ввиду под "коэффициентом сжатия"? То что нужно не по одному пикселю убирать с каждой стороны, а равными частями уменьшать? Например 1% от шириниы и 1% от высоты отсекать? Если последнее, то да, я переделал на % - так работает быстрее и картинка не деформируется.
krukovis84 писал(а):Подскажите пожалуйста где у фотографии лежит информация "Дата снимка" и подобная. При обрезке это все пропадает, а надо, чтобы обязательно сохранялась эта информация.
krukovis84 писал(а):Подскажите пожалуйста где у фотографии лежит информация "Дата снимка" и подобная. При обрезке это все пропадает, а надо, чтобы обязательно сохранялась эта информация.
iGrok писал(а):Ключевое слово - EXIF.
Public Class Form1
Private Sub Button1_Click(sender As System.Object, e As System.EventArgs) Handles Button1.Click
'создаем диалог выбора файла
Dim OpenFile As New OpenFileDialog
OpenFile.ShowDialog()
'получаем полное имя файла
Dim FullFileName As String = OpenFile.FileName
'получаем имя файла без пути
Dim FileName As String = OpenFile.SafeFileName
'получаем имя папки
Dim FolderName As String = Strings.Left(OpenFile.FileName, OpenFile.FileName.Length - FileName.Length)
'задаем новое имя для файла
Dim NewFileName As String = "Reduced_" & FileName
'запоминаем текущее время
Dim StartTime As Date = DateAndTime.Now()
'преобразуем файл
My.Computer.FileSystem.WriteAllBytes(FolderName & NewFileName, ReduceJpegFileBySizeAndQuality(FullFileName, 80, 307200), False)
'определяем сколько прошло времени в секундах
Dim intTimeDiff = DateDiff(DateInterval.Second, StartTime, DateAndTime.Now())
'выводим по готовности
MsgBox("Готово. Преобразование длилось " & intTimeDiff & " сек ")
End Sub
End Class
Imports System.IO
Imports System.Drawing.Imaging
Public Module JpegFunctions
Public Function GetJpegFile(ByVal Img As Image, ByVal newWidth As Long, ByVal newHeight As Long) As MemoryStream
'создаем под файл резервное хранилище в памяти
Dim File As New MemoryStream
'вписываем полученное изображение в новые границы
Dim ResizedImg As Image
ResizedImg = New System.Drawing.Bitmap(CType(Img, Bitmap), newWidth, newHeight)
'сохраняем в памяти изображение в формате jpeg
ResizedImg.Save(File, ImageFormat.Jpeg)
'возвращаем файл
Return File
End Function
Public Function GetJpegFile(ByVal Img As Image, ByVal CodecInfo As ImageCodecInfo, ByVal Quality As Long) As MemoryStream
'создаем под файл резервное хранилище в памяти
Dim File As New MemoryStream
'создаем хранилище для параметров кодировки, с числом параметров 1
Dim EncoderParams As New EncoderParameters(1)
'помещаем в хранилище параметров параметр кодировки "Качество"
EncoderParams.Param(0) = New EncoderParameter(Encoder.Quality, Quality)
'сохраняем в памяти файл кодированный полученным кодеком в определенное качество
Img.Save(File, CodecInfo, EncoderParams)
'возвращаем файл
Return File
End Function
Private Function GetCodecInfo(ByVal MimeType As String) As ImageCodecInfo
'ищем кодек среди всех кодеков
For Each Codec As ImageCodecInfo In ImageCodecInfo.GetImageEncoders()
If Codec.MimeType = MimeType Then
Return Codec
End If
Next Codec
Return Nothing
End Function
'не используется, оставлено для коллекции
Public Function ReduceByQuality(ByVal Img As Image, ByVal Lim As Long) As Byte()
Dim LastOk() As Byte = Nothing
Dim File As MemoryStream '() As Byte
Dim L As Long = 0
Dim R As Long = 100
Dim Cur As Long
'находим кодек
Dim CodecInfo As ImageCodecInfo
CodecInfo = GetCodecInfo("image/jpeg")
Do While L < R
Cur = (L + R + 1) \ 2 '"\"-целочисленное деление, "/"-деление с остатком, "MOD" - остаток от деления.
File = GetJpegFile(Img, CodecInfo, Cur)
If File.ToArray().Length > Lim Then
R = Cur - 1
Else
L = Cur
LastOk = File.ToArray()
End If
Loop
Return LastOk
End Function
Public Function ReduceBySize(ByVal Img As Image, ByVal Lim As Long) As Byte()
Dim LastOk() As Byte = Nothing
Dim Res As MemoryStream '() As Byte
Dim LHeight As Long = 0
Dim RHeight As Long = Img.Height
Dim CurHeight As Long
Dim LWidth As Long = 0
Dim RWidth As Long = Img.Width
Dim CurWidth As Long
Do While LHeight < RHeight
CurHeight = (LHeight + RHeight + 1) \ 2
CurWidth = (LWidth + RWidth + 1) \ 2
Res = GetJpegFile(Img, CurWidth, CurHeight)
If Res.ToArray().Length > Lim Then
RHeight = CurHeight - 1
RWidth = CurWidth - 1
Else
LHeight = CurHeight
LWidth = CurWidth
LastOk = Res.ToArray()
End If
Loop
Return LastOk
End Function
Public Function ReduceJpegFileBySizeAndQuality(ByVal FileName As String, ByVal Quality As Long, ByVal Lim As Long) As Byte()
'сначала уменьшаем качество
'преобразуем файл в объект Image
Dim Img As Image = Bitmap.FromFile(FileName)
'Процесс уменьшения качества на столько тормозной и
'для существенного изменения размера файла требующий настолько сильного уменьшения качества,
'что я принял решение его не использовать вообще, кто хочет - может раскоментировать и проверить
'============================================
''Находим JPEG-кодек
'Dim Codec As ImageCodecInfo = GetCodecInfo("image/jpeg")
''@TODO проверка на существование кодека
''уменьшаем качество файла до заданной величины и запоминаем в памяти
'Dim File As MemoryStream = GetJpegFile(Img, Codec, Quality)
''преобразуем полученный файл в объект Image
'Img = Bitmap.FromStream(File)
'=============================================
'затем уменьшаем файл с помощью уменьшения размера до заданного веса и возвращаем результат
Dim ReducedFile As Byte()
ReducedFile = ReduceBySize(Img, Lim)
'@TODO проверка на существование файла
'возвращаем файл
Return ReducedFile
End Function
End Module
Public Function GetJpegFile(ByVal Img As Image, ByVal newWidth As Long, ByVal newHeight As Long) As MemoryStream
'создаем под файл резервное хранилище в памяти
Dim File As New MemoryStream
'вычисляем новые границы
Dim FileWidth As Integer = Img.Width
Dim FileHeight As Integer = Img.Height
Dim Kf = Math.Min(Math.Min(newWidth / FileWidth, newHeight / FileHeight), 1)
Dim NewFileWidth As Integer = FileWidth * Kf
Dim NewFileHeight As Integer = FileHeight * Kf
'вписываем полученное изображение в новые границы
Dim ResizedImg As Image
ResizedImg = New System.Drawing.Bitmap(CType(Img, Bitmap), NewFileWidth, NewFileHeight)
'сохраняем в памяти изображение в формате jpeg
ResizedImg.Save(File, ImageFormat.Jpeg)
'возвращаем файл
Return File
End Function
krukovis84 писал(а):Даже однократное уменьшение качества фотографии увеличивает время обработки в 1,5 -2 раза.
╔════════════╦═══════╤═══════╗
║ Итераций ║ 8 │ все ║
╠═════╤══════╬═══════╪═══════╣
║ Ваш │ 80% ║ 7 сек │ ║
║ Ваш │ 75% ║ 7 сек │ ║
║ Ваш │ none ║ 6 сек │ ║
╠═════╪══════╬═══════╪═══════╣
║ Мой │ 80% ║ 3 сек │ 6 сек ║
║ Мой │ 75% ║ 4 сек │ 7 сек ║
║ Мой │ none ║ 4 сек │ 7 сек ║
╚═════╧══════╩═══════╧═══════╝
Imports System.Drawing.Imaging
Imports System.IO
Module JpegFunctions
Private JpegCodec As ImageCodecInfo = (From Codec As ImageCodecInfo In ImageCodecInfo.GetImageEncoders() Where Codec.MimeType = "image/jpeg" Select Codec).First
Public Function GetJpegFile(ByVal Pct As Image, ByVal Quality As Integer) As MemoryStream
Dim File As New MemoryStream
Dim EncoderParams As New EncoderParameters(1)
EncoderParams.Param(0) = New EncoderParameter(Encoder.Quality, Quality)
Pct.Save(File, JpegCodec, EncoderParams)
'Pct.Save(File, ImageFormat.Jpeg)
Return File
End Function
Public Function ReduceJpegFileSize(ByVal Pct As Image, ByVal Quality As Integer, ByVal Lim As Integer) As Byte()
Dim File As MemoryStream, LastOk As MemoryStream = Nothing
Dim L As Double = 0, R As Double = 1, Cur As Double
'For Q As Integer = 0 To 7
For Q As Integer = 0 To Math.Log(Math.Max(Pct.Width, Pct.Height), 2)
Cur = (L + R) / 2
File = GetJpegFile(New System.Drawing.Bitmap(CType(Pct, Bitmap), Pct.Width * Cur, Pct.Height * Cur), Quality)
If File.Length > Lim Then
R = Cur
Else
L = Cur
LastOk = File
End If
Next Q
Return If(LastOk IsNot Nothing, LastOk.ToArray(), Nothing)
End Function
End Module
Module All
Public Sub Main()
'создаем диалог выбора файла
Dim OpenFile As New OpenFileDialog
OpenFile.ShowDialog()
'получаем полное имя файла
Dim FullFileName As String = OpenFile.FileName
'получаем имя файла без пути
Dim FileName As String = OpenFile.SafeFileName
'получаем имя папки
Dim FolderName As String = Strings.Left(OpenFile.FileName, OpenFile.FileName.Length - FileName.Length)
'задаем новое имя для файла
Dim NewFileName As String = "Reduced_" & FileName
'запоминаем текущее время
Dim StartTime As Date = DateAndTime.Now()
'преобразуем файл
My.Computer.FileSystem.WriteAllBytes(FolderName & NewFileName, ReduceJpegFileSize(Image.FromFile(FullFileName), 80, 307200), False)
'определяем сколько прошло времени в секундах
Dim intTimeDiff = DateDiff(DateInterval.Second, StartTime, DateAndTime.Now())
'выводим по готовности
MsgBox("Готово. Преобразование длилось " & intTimeDiff & " сек ")
End Sub
End Module
krukovis84 писал(а):Под коэффициентом сжатия это имелось ввиду?
Public Class Form1
Private Sub Button1_Click(sender As System.Object, e As System.EventArgs) Handles Button1.Click
'создаем диалог выбора файла
Dim OpenFile As New OpenFileDialog
OpenFile.ShowDialog()
'получаем полное имя файла
Dim FullFileName As String = OpenFile.FileName
'получаем имя файла без пути
Dim FileName As String = OpenFile.SafeFileName
'получаем имя папки
Dim FolderName As String = Strings.Left(OpenFile.FileName, OpenFile.FileName.Length - FileName.Length)
'задаем новое имя для файла
Dim NewFileName As String = "Reduced_" & FileName
'запоминаем текущее время
Dim StartTime As Date = DateAndTime.Now()
'преобразуем файл
My.Computer.FileSystem.WriteAllBytes(FolderName & NewFileName, ReduceJpegFileBySizeAndQuality(FullFileName, 80, 307200), False)
'определяем сколько прошло времени в секундах
Dim intTimeDiff = DateDiff(DateInterval.Second, StartTime, DateAndTime.Now())
'выводим по готовности
MsgBox("Готово. Преобразование длилось " & intTimeDiff & " сек ")
End Sub
End Class
FireFenix писал(а):Потому что нужно закрывать файловый поток
Считываем: Файл -> FileSrteam -> MemoryStream
Закрываем FileStream, работаем с MemoryStream, конвертируем в картинку, пережимаем, изменяем/создаём новый MemoryStream
Записываем: MemoryStream -> FileStream -> Файл
FireFenix писал(а):Потому что нужно закрывать файловый поток
My.Computer.FileSystem.WriteAllBytes(FolderName & NewFileName, ReduceJpegFileSize(Image.FromStream(New FileStream(FullFileName, FileMode.Open, FileAccess.Read, FileShare.ReadWrite)), 75, 307200), False)
Qwertiy писал(а):krukovis84, какой в итоге вариант преобразования? С коэффициентом сжатия разобрались?
krukovis84 писал(а):Но уменьшение качества решил не использовать. За счет уменьшения размера и вес хорошо падает и происходит это быстрее.
If OFD.ShowDialog() = Windows.Forms.DialogResult.OK Then
Qwertiy писал(а):krukovis84 писал(а):Но уменьшение качества решил не использовать. За счет уменьшения размера и вес хорошо падает и происходит это быстрее.
1. Я же привёл код, показывающий, что это не быстрее!
Qwertiy писал(а):2. Судя по получаемым результатам, сохранение как ImageFormat.Jpeg использует качество между 75 и 80%.
Qwertiy писал(а):3. Меня интересует число итераций: 8 (что близко к использованию процентов) или все (точность до 1 пикселя).
Qwertiy писал(а):Кстати, стоит добавить проверку
- Код: Выделить всё
If OFD.ShowDialog() = Windows.Forms.DialogResult.OK Then
Qwertiy писал(а):PS: Мне кажется странным, что уменьшение размера лучше, чем некоторое уменьшение качества.
krukovis84 писал(а):Ты сравнивал мой кривой код и свой оптимизированный. Ну ясен пень получилось быстрее. Попробуй из своего последнего алгоритма убрать работу с качеством и посмотри как изменится скорость.
Использование ImageFormat.Jpeg не даёт выигрыша по времени. Более того, время больше, чем при использовании качества 80%, но такое же, как при 75%. Размер получаемых изображений (в пикселях) подтверждает, что используется нечто между 75 и 80%.Qwertiy писал(а):Статистика (на файле 3072*2304 размером 3 266 616 байт):
- Код: Выделить всё
╔════════════╦═══════╤═══════╗
║ Итераций ║ 8 │ все ║
╠═════╤══════╬═══════╪═══════╣
║ Ваш │ 80% ║ 7 сек │ ║
║ Ваш │ 75% ║ 7 сек │ ║
║ Ваш │ none ║ 6 сек │ ║
╠═════╪══════╬═══════╪═══════╣
║ Мой │ 80% ║ 3 сек │ 6 сек ║
║ Мой │ 75% ║ 4 сек │ 7 сек ║
║ Мой │ none ║ 4 сек │ 7 сек ║
╚═════╧══════╩═══════╧═══════╝
krukovis84 писал(а):Да нет. На столько высокая точность не нужна.
For Q As Integer = 0 To Math.Log(Math.Max(Pct.Width, Pct.Height) / K, 2)
А что по-вашему означает строка none в этой таблице?
Сейчас этот форум просматривают: нет зарегистрированных пользователей и гости: 2