vb.net - Save screenshot with reduced resolution and image quality - vb.net

I am using this code to take screenshots on a production machine and save them to a folder. each file is about 400 kb in size, and I do not really need good resolution and quality. How can I half the resolution and reduce the jpg quality to save space?
Private Sub TakeScreenShot()
Dim screenSize As Size = New Size(My.Computer.Screen.Bounds.Width, My.Computer.Screen.Bounds.Height)
Dim screenGrab As New Bitmap(My.Computer.Screen.Bounds.Width, My.Computer.Screen.Bounds.Height)
Dim g As Graphics = Graphics.FromImage(screenGrab)
g.CopyFromScreen(New Point(0, 0), New Point(0, 0), screenSize)
screenGrab.Save("screenshots\test.jpg", Imaging.ImageFormat.Jpeg)
End Sub

Following this MSDN article, you can set 50% quality like this
Private Sub TakeScreenShot()
Dim screenSize As Size = New Size(My.Computer.Screen.Bounds.Width, My.Computer.Screen.Bounds.Height)
Dim screenGrab As New Bitmap(My.Computer.Screen.Bounds.Width, My.Computer.Screen.Bounds.Height)
Dim g As Graphics = Graphics.FromImage(screenGrab)
g.CopyFromScreen(New Point(0, 0), New Point(0, 0), screenSize)
Dim jpgEncoder As System.Drawing.Imaging.ImageCodecInfo = GetEncoder(System.Drawing.Imaging.ImageFormat.Jpeg)
Dim myEncoder As System.Drawing.Imaging.Encoder = System.Drawing.Imaging.Encoder.Quality
Dim myEncoderParameters As New Imaging.EncoderParameters(1)
Dim myEncoderParameter As New System.Drawing.Imaging.EncoderParameter(myEncoder, 50&)
myEncoderParameters.Param(0) = myEncoderParameter
screenGrab.Save("screenshots\test.jpg", jpgEncoder, myEncoderParameters)
End Sub
Public Function GetEncoder(ByVal format As ImageFormat) As ImageCodecInfo
Dim codecs As ImageCodecInfo() = ImageCodecInfo.GetImageDecoders()
Dim codec As ImageCodecInfo
For Each codec In codecs
If codec.FormatID = format.Guid Then
Return codec
End If
Next codec
Return Nothing
End Function

Related

print Panel Content with high quality

I want to print a Panel content but the result it's not high quality, I faced the same issue when I try to save a PictureBox image but I solve it with this Img.Setresolution(300, 300)
now I want to increase the quality of the result in any way ( also I tried to take a screenshot then store it in an image and print it I get a small image !! )
i tried this but it doesn't work for me :
Private Sub PrintDocument1_PrintPage(sender As Object, e As Printing.PrintPageEventArgs) Handles PrintDocument1.PrintPage
Dim tmpImg As New Bitmap(Panel1.Width, Panel1.Height)
Using g As Graphics = Graphics.FromImage(tmpImg)
g.CopyFromScreen(Panel1.PointToScreen(New Point(0, 0)), New Point(0, 0), New Size(Panel1.Width, Panel1.Height))
End Using
e.Graphics.DrawImage(tmpImg, 0, 0)
Dim aPS As New PageSetupDialog
aPS.Document = PrintDocument1
'Dim bm As New Bitmap(Panel1.Width, Panel1.Height)
'Panel1.DrawToBitmap(bm, New Rectangle(0, 0, Panel1.Width, Panel1.Height))
'e.Graphics.DrawImage(bm, 0, 0)
'Dim aPS As New PageSetupDialog
'aPS.Document = PrintDocument1
End Sub

VB.NET resize and crop images

i have a VSTO for powerpoint and want to resize images so they are the same size as the slide. a sample image i have is 1000x300 and the slide is 960x540. so this is the code i have:
_W=960
_H=540
Dim img As Image = System.Drawing.Bitmap.FromFile(file1)
OldRect = New RectangleF(233, 0, 533, 300) ' calculated values to crop left and right
NewRect = New RectangleF(0, 0, _W, _H)
Dim bmp As Bitmap = New Bitmap(img, _W, _H)
Dim g As Graphics = Graphics.FromImage(bmp)
g.InterpolationMode = Drawing2D.InterpolationMode.HighQualityBicubic
g.PixelOffsetMode = Drawing2D.PixelOffsetMode.HighQuality
g.CompositingQuality = Drawing2D.CompositingQuality.HighQuality
g.DrawImage(img, NewRect, OldRect, GraphicsUnit.Pixel)
img.Save(file2, Imaging.ImageFormat.Png)
but when i look at file2 it's the same 1000x300 file as the original. what am i missing here?
#plutonix; you're spot on. i was under the wrong impression that DrawImage would replace the image it was offered. but saving the bitmap the graphics object was created with produced the intended image.
bmp.Save(file2, Imaging.ImageFormat.Png)
works perfect. thanks!
The answer posted here is good but there is one major problem of quality that need to be addressed. In most cased you have to Crop Image and Maintain the Quality so in that regard, I have improved the crop feature of a sample and posted below is the link. This demo is in VB.NET but you can easily understand the concept and make adjustments.
http://www.mediafire.com/file/70rmlpcdjyxo8gc/ImageCroppingDemo_-_Maintain_Image_Quality.zip/file
CODES For Cropping (VB.NET)
Dim cropX As Integer
Dim cropY As Integer
Dim cropWidth As Integer
Dim cropHeight As Integer
Dim oCropX As Integer
Dim oCropY As Integer
Dim cropBitmap As Bitmap
Dim Loadedimage As Image
Public cropPen As Pen
Public cropPenSize As Integer = 1 '2
Public cropDashStyle As Drawing2D.DashStyle = Drawing2D.DashStyle.Solid
Public cropPenColor As Color = Color.Yellow
Private Sub crobPictureBox_MouseDown(ByVal sender As System.Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles crobPictureBox.MouseDown
Try
If e.Button = Windows.Forms.MouseButtons.Left Then
cropX = e.X
cropY = e.Y
cropPen = New Pen(cropPenColor, cropPenSize)
cropPen.DashStyle = DashStyle.DashDotDot
Cursor = Cursors.Cross
End If
crobPictureBox.Refresh()
Catch exc As Exception
End Try
End Sub
Dim tmppoint As Point
Private Sub crobPictureBox_MouseMove(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles crobPictureBox.MouseMove
Try
If crobPictureBox.Image Is Nothing Then Exit Sub
If e.Button = Windows.Forms.MouseButtons.Left Then
crobPictureBox.Refresh()
cropWidth = e.X - cropX
cropHeight = e.Y - cropY
crobPictureBox.CreateGraphics.DrawRectangle(cropPen, cropX, cropY, cropWidth, cropHeight)
End If
' GC.Collect()
Catch exc As Exception
If Err.Number = 5 Then Exit Sub
End Try
End Sub
Private Sub crobPictureBox_MouseUp(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles crobPictureBox.MouseUp
Try
Cursor = Cursors.Default
Try
If cropWidth < 1 Then
Exit Sub
End If
Dim smallWidthPercentage As Single = (cropWidth / crobPictureBox.Width) * 100
Dim smallHeightPercentage As Single = (cropHeight / crobPictureBox.Height) * 100
Dim smallXPercentage As Single = (cropX / crobPictureBox.Width) * 100
Dim smallYPercentage As Single = (cropY / crobPictureBox.Height) * 100
smallHeightPercentage += 10
smallYPercentage -= 10
Dim Widthdifference As Integer = Loadedimage.Width - crobPictureBox.Width
Dim HeightDifference As Integer = Loadedimage.Height - crobPictureBox.Height
Dim rect As Rectangle
rect = New Rectangle((smallXPercentage / 100) * Loadedimage.Width, (smallYPercentage / 100) * Loadedimage.Height, (smallWidthPercentage / 100) * Loadedimage.Width, (smallHeightPercentage / 100) * Loadedimage.Height)
Dim bit As Bitmap = New Bitmap(Loadedimage, Loadedimage.Width, Loadedimage.Height)
cropBitmap = New Bitmap(Loadedimage, (smallWidthPercentage / 100) * Loadedimage.Width, (smallHeightPercentage / 100) * Loadedimage.Height)
Dim g As Graphics = Graphics.FromImage(cropBitmap)
g.InterpolationMode = Drawing2D.InterpolationMode.HighQualityBicubic
g.PixelOffsetMode = Drawing2D.PixelOffsetMode.HighQuality
g.CompositingQuality = Drawing2D.CompositingQuality.HighQuality
g.DrawImage(bit, 0, 0, rect, GraphicsUnit.Pixel)
PreviewPictureBox.Image = cropBitmap
Catch exc As Exception
End Try
Catch exc As Exception
End Try
End Sub

Using custom font with AntiAlias

Hey all i am trying to load my custom ttf font and also have it AntiAlias so it doesnt look all jagged and all.
The code in order to load the custom font is this (found here):
Dim pfc As New PrivateFontCollection()
pfc.AddFontFile("C:\Path To\PALETX3.ttf")
label1.Font = New Font(pfc.Families(0), 16, FontStyle.Regular)
The code to do the Antialias on fonts is this (found here):
Dim fontFamily As New FontFamily("Times New Roman")
Dim font As New Font( _
fontFamily, _
32, _
FontStyle.Regular, _
GraphicsUnit.Pixel)
Dim solidBrush As New SolidBrush(Color.FromArgb(255, 0, 0, 255))
Dim string1 As String = "SingleBitPerPixel"
Dim string2 As String = "AntiAlias"
e.Graphics.TextRenderingHint = TextRenderingHint.SingleBitPerPixel
e.Graphics.DrawString(string1, font, solidBrush, New PointF(10, 10))
e.Graphics.TextRenderingHint = TextRenderingHint.AntiAlias
e.Graphics.DrawString(string2, font, solidBrush, New PointF(10, 60))
However, i am not able to merge those codes above... I've tried:
Private Sub Form1_Paint(ByVal sender As Object, ByVal e As System.Windows.Forms.PaintEventArgs) Handles Me.Paint
Dim font As New PrivateFontCollection()
font.AddFontFile("C:\Path To\PALETX3.ttf")
Dim fontFamily As New Font(font.Families(0))
Dim solidBrush As New SolidBrush(Color.FromArgb(255, 0, 0, 255))
Dim string1 As String = "SingleBitPerPixel"
Dim string2 As String = "AntiAlias"
e.Graphics.TextRenderingHint = TextRenderingHint.SingleBitPerPixel
e.Graphics.DrawString(string1, fontFamily, solidBrush, New PointF(10, 10))
e.Graphics.TextRenderingHint = TextRenderingHint.AntiAlias
e.Graphics.DrawString(string2, fontFamily, solidBrush, New PointF(10, 60))
End Sub
But an error of:
Overload resolution failed because no accessible 'New' accepts this number of arguments.
That is on the Dim fontFamily As New Font(font.Families(0)) line.
Any help to merge these 2 together would be great!
New Font has over a dozen overloads for new and you happen to pick one not in the list. The very minimum when specifying args is:
Dim myFont As New Font(familyName As String, emSize as integer)
so try this:
Dim myFont As New Font(font.Families(0), 16)

Display Metadata-thumbnail of Jpeg in picturebox

I need to display a Image's thumbnail, that is saved in its Metadata in a picturebox. I'm using VB.NET
http://msdn.microsoft.com/en-us/library/windows/desktop/ee719904%28v=vs.85%29.aspx#_jpeg_metadata
So far i came up with this. Adding a breakpoint displays that GETQUERY returns empty even if i know that the file does indeed have a thumbnail
Private Sub Form1_Load(sender As System.Object, e As System.EventArgs) Handles MyBase.Load
Dim imagepath = "C:\xampp\htdocs\Downloads\IMG_1322.JPG" ' path to file
Dim stream = New FileStream(imagepath, FileMode.Open, FileAccess.Read, FileShare.ReadWrite)
Dim decoder = New JpegBitmapDecoder(stream, BitmapCreateOptions.None, BitmapCacheOption.None)
Dim metadata = TryCast(decoder.Frames(0).Metadata, BitmapMetadata)
Dim ms As New System.IO.MemoryStream
Dim bm As Bitmap
Dim arData() As Byte
arData = metadata.GetQuery("/app0/{ushort=6}") '<--- Breakpoint here: Query returns nothing!
ms.Write(arData, 78, arData.Length - 78)
bm = New Bitmap(ms)
PictureBox1.Image = bm
stream.Close()
End Sub
You can try something like this:
Private Sub Form1_Load(sender As System.Object, e As System.EventArgs) Handles MyBase.Load
Dim imagepath = "C:\xampp\htdocs\Downloads\IMG_1322.JPG" ' path to file
Dim stream = New FileStream(imagepath, FileMode.Open, FileAccess.Read, FileShare.ReadWrite)
Dim decoder = New JpegBitmapDecoder(stream, BitmapCreateOptions.None, BitmapCacheOption.None)
Dim metadata = TryCast(decoder.Frames(0).Metadata, BitmapMetadata)
Dim thumb As BitmapMetadataBlob
thumb = metadata.GetQuery("/app1/thumb/")
If Not (thumb Is Nothing) Then
Dim src As New BitmapImage
Dim ms As MemoryStream = New MemoryStream(thumb.GetBlobValue())
src.BeginInit()
src.StreamSource = ms
src.EndInit()
PictureBox1.Source = src
End If
stream.Close()
End Sub

Save Draw String or e.graphic as image

NEED HELP PLEASE ! Saving Picture with ""Drawstring, e.graphic""
Protected Overrides Sub OnPaint(ByVal e As PaintEventArgs)
Dim Bmp As New Bitmap(Width, Height)
Dim objBitmap As New Bitmap(Width, Height)
objBitmap.Save("c:\Prompter\checking2.TIFF")
Dim g As Graphics = Graphics.FromImage(Bmp)
Dim cx As Integer = Width
Dim cy As Integer = Height
Dim pen As New Pen(Color.Black)
Dim rect As New Rectangle(0, 0, Width, Height)
Dim drawFormat As New StringFormat()
drawFormat.Alignment = StringAlignment.Center
drawFormat.LineAlignment = StringAlignment.Center
Dim stringFont As New Font("Arial", 50)
g.DrawString(RichTextBox1.Text, stringFont, New SolidBrush(Color.White), rect, drawFormat)
Bmp.Save("c:\Prompter\checking2.TIFF", Imaging.ImageFormat.Tiff)
Using bmp2 As New Drawing.Bitmap(Width, Height)
DrawToBitmap(Bmp, New Rectangle(0, 0, Bmp.Width, Bmp.Height))
Bmp.Save("c:\Prompter\screenshoot.bmp")
End Using
End Sub
Not saving Picture just BLANK Image is showing !
Try disposing graphics before save ..
g.Dispose()
Bmp.Save("c:\Prompter\checking2.TIFF", Imaging.ImageFormat.Tiff)