Image.Save() throws GDI+ exception for image derived from bitmap - vb.net

I have two classes: ChartObject & GrowthChartPane.
ChartObject has a method, GetChart(), that converts a bitmap to a Drawing.Image that is returned.
Public Function GetChart() As Drawing.Image
Dim chartImage As Drawing.Image
Dim gr As Graphics
Dim brush As Brush = Brushes.Blue
If m_bIsBoy Then
brush = Brushes.Red
End If
Using fs As New FileStream(m_sChartImageFileName, FileMode.Open, FileAccess.Read)
chartImage = Bitmap.FromStream(fs)
gr = Graphics.FromImage(chartImage)
End Using
For Each Point As PointObject In m_lstUpperPoints
If Not Point.IsVisible Then Continue For
Dim x As Integer = m_objUpperHorizontalAxis.ValueToPoint(Point.HorizontalValue)
Dim y As Integer = m_objUpperVerticalAxis.ValueToPoint(Point.VerticalValue)
gr.FillEllipse(brush, New RectangleF(x - 4, y - 4, 8, 8))
Next
For Each Point As PointObject In m_lstLowerPoints
If Not Point.IsVisible Then Continue For
Dim x As Integer = m_objLowerHorizontalAxis.ValueToPoint(Point.HorizontalValue)
Dim y As Integer = m_objLowerVerticalAxis.ValueToPoint(Point.VerticalValue)
gr.FillEllipse(brush, New RectangleF(x - 4, y - 4, 8, 8))
Next
DrawHeaderAndTable(gr)
Return chartImage
End Function
GrowthChartPane, when it is loading, makes a call to ChartObject.GetChart() to instantiate a Drawing.Image object. When trying to Save the image that is returned from growth chart, the exception occurs. The method is pretty big, but here is a snippet from the end where the exception is.
Dim fn As String = PediatricGrowthChartsImageHandler.GetPGCImagePath(CurrentPatient.EntityID, m_iChartTypeId)
If Not IsNothing(customDrowingChart) Then
Dim chartImage As Drawing.Image = customDrowingChart.GetChart()
hdnImgChartH.Value = chartImage.Height.ToString 'test
hdnImgChartW.Value = chartImage.Width.ToString 'test
chartImage.Save(fn, System.Drawing.Imaging.ImageFormat.Png)
chartImage.Dispose()
imgChart.ImageUrl = String.Format("PediatricGrowthChartsImageHandler.axd?PatientID={0}&PGCTypeID={1}&rnd={2}", CurrentPatient.EntityID, m_iChartTypeId, New Random().NextDouble().ToString())
Else
Chart1.SaveImage(fn, ChartImageFormat.Png)
End If
End If
If Not IsNothing(DataToBeFilled) Then DataToBeFilled.dispose()
End Sub
I have confirmed that the file does NOT exist, yet exception is still thrown on Image.Save()
I've done some research on this topic & there are so many different solutions out there, but that brought me to a concern about the stream being open.
I've read that the stream needs to be open to Save an image and that you can directly pass a stream into the Save() method, but I 'm curious about how that interaction goes between the two classes.

Related

Dealing with a memory leak when cropping images in vb.net

I keep getting a system out of memory error when I break an image up into sub images. There's nothing too fancy going on, just splitting an image into a bunch of smaller images. Here's my code:
Dim counterrr As Integer = 0
Dim sorucedir As String
Dim tardir As String
sorucedir = "C:\somedir\"
tardir = "C:\otherdir\"
Dim di2 As New DirectoryInfo(sorucedir)
Dim fiArr2 As FileInfo() = di2.GetFiles()
Dim fri2 As FileInfo
Dim hh As Integer
Dim ww As Integer
hh = 995 'height of source images
ww = 1080 'width of source images
Dim sizestepX As Integer = 180
Dim stepsizeY As Integer = 239
For i = 0 To ww - 1 Step sizestepX
For j = 0 To hh - 1 Step stepsizeY
For Each fri2 In fiArr2
Dim BM2 As Bitmap
BM2 = Image.FromFile(fri2.FullName)
''Threading.Thread.Sleep(3000)
'bm2 = Image.FromFile(fri2.FullName)
Dim BM3 As Bitmap
Dim rect As New Rectangle(i, j, sizestepX, stepsizeY)
BM3 = BM2.Clone(rect, Imaging.PixelFormat.DontCare)
counterrr += 1
Dim ss As String
ss = tardir & counterrr & ".png"
BM3.Save(ss, Imaging.ImageFormat.Png)
BM3 = Nothing
Next
Next
Next
The error comes up after creating as few as 6 images (occurs when creating the 7th image). The line where the error is thrown is this:
BM3 = BM2.Clone(rect, Imaging.PixelFormat.DontCare)
How can I modify my code so they objects are correctly disposed (?) of so they don't leak memory.
The Bitmap class, along with many of the other GDI+ classes implement IDisposable because they hold onto underlying GDI object handles which need to be released. Each process is limited by the OS to a maximum number of GDI objects, usually 10,000. You can view the total number of active GDI objects per process in the Windows task manager. To fix your problem, you need to either manually call the Dispose method on each Bitamp object you create, before it goes out of scope, or you need to wrap each Bitmap variable declaration in a Using block (so it will call Dispose for you). For instance:
Using BM2 As Bitmap = Image.FromFile(fri2.FullName)
Dim rect As New Rectangle(i, j, sizestepX, stepsizeY)
Using BM3 As Bitmap = BM2.Clone(rect, Imaging.PixelFormat.DontCare)
counterrr += 1
Dim ss As String
ss = tardir & counterrr & ".png"
BM3.Save(ss, Imaging.ImageFormat.Png)
End Using
End Using
Note: there's no point in setting the BM3 variable to Nothing at the end, like you're doing. That has no bearing on anything.

How to Trim a Line From An Ellipse (AutoCAD 2014)

Goal
To trim a line in an ellipse that goes to it's center. The portion of the line that enters the ellipse should be trimmed off.
This is the untrimmed ellipse
This is the trimmed ellipse, the goal of this question
Attempt
CreateConveyorNameEllipse(AcadDoc)
Public Function CreateConveyorNameEllipse(ByRef AcadDoc As Document) As ObjectId
Dim returnId As ObjectId
Dim db As Database = AcadDoc.Database
Dim x As Vector3d = db.Ucsxdir
Dim y As Vector3d = db.Ucsydir
Dim normalVec As Vector3d = x.CrossProduct(y)
Dim axisvec As Vector3d = normalVec.GetNormal()
Dim CenterPoint As New Point3d(Me.StartPoint.X + 50, Me.StartPoint.Y + 40, 0)
Dim aEllipse As Ellipse
aEllipse = New Ellipse(CenterPoint, axisvec, New Vector3d(30, 0, 0), 0.35, 0, Math.PI * 2)
aEllipse.SetDatabaseDefaults()
returnId = Utils.CreateAcadObject(AcadDoc, aEllipse)
aEllipse.Dispose()
Utils.regenLayers()
Return returnId
End Function
CreateConveyorEllipseLineConnection(AcadDoc)
Public Function CreateConveyorEllipseLineConnection(ByRef AcadDoc As Document) As ObjectId
Dim returnId As ObjectId
Dim CenterPoint As New Point3d(Me.StartPoint.X + 50, Me.StartPoint.Y + 40, 0)
Dim aLine As Line
aLine = New Line(Me.StartPoint, CenterPoint)
aLine.SetDatabaseDefaults()
returnId = Utils.CreateAcadObject(AcadDoc, aLine)
aLine.Dispose()
Utils.regenLayers()
Return returnId
End Function
CreateAcadObject(AcadDoc, AcadObj)
Public Function CreateAcadObject(ByRef acDoc As Document, ByRef acObj As Object) As ObjectId
Dim objId As ObjectId
Dim acCurDb As Database = acDoc.Database 'Get the current database
Dim acBlkTbl As BlockTable
Dim acBlkTblRec As BlockTableRecord
Using lock As DocumentLock = acDoc.LockDocument
'Start a transaction
Using acTrans As Transaction = acCurDb.TransactionManager.StartTransaction()
'Open Model space for write
acBlkTbl = acTrans.GetObject(acCurDb.BlockTableId, OpenMode.ForRead)
acBlkTblRec = acTrans.GetObject(acBlkTbl(BlockTableRecord.ModelSpace), OpenMode.ForWrite)
acObj.SetDatabaseDefaults()
'Add the object to the drawing
objId = acBlkTblRec.AppendEntity(acObj)
acTrans.AddNewlyCreatedDBObject(acObj, True)
'Commit the changes and dispose of the transaction
acTrans.Commit()
End Using
End Using
Return objId
End Function
I'm not quite sure how to apply the trim to the line. I've seen some IntersectWith methods but couldn't get it to work yet. I'll be working on this meanwhile and if I find the answer I'll be sure to post it here.
You can take advantage of a few cool methods dealing with curves to handle this:
Private Shared Function TrimmedLine(line As Line, ent As Entity) As Line
If line Is Nothing Then
Throw New ArgumentNullException("line")
End If
' Original line is returned since there's nothing to break it
If ent Is Nothing Then Return line
Dim extPoints = New Point3dCollection()
Try
line.IntersectWith(ent, Intersect.ExtendArgument, extPoints, IntPtr.Zero, IntPtr.Zero)
' Original line gets returned since it doesn't intersect
If extPoints.Count = 0 Then Return line
Dim splitLines = line.GetSplitCurves(extPoints)
' Not sure when this would fail, investigate.
If splitLines.Count = 0 Then Return Nothing
' Return the outer line in this case
Return DirectCast(splitLines(0), Line)
Catch ex As Autodesk.AutoCAD.Runtime.Exception
System.Diagnostics.Debug.Write(ex.Message)
Throw
End Try
End Function

Using Encoding Parameters to merge TIFF Files

Edit: I found another example that creates the encoder params like this and I get the exact same error as befoer: "A generic error occurred in GDI+"
Dim info As ImageCodecInfo = Nothing
Dim ice As ImageCodecInfo
For Each ice In ImageCodecInfo.GetImageEncoders()
If ice.MimeType = "image/tiff" Then
info = ice
End If
Next ice 'use the save encoder
Dim enc As Encoder = Encoder.SaveFlag
Dim ep As New EncoderParameters(1)
ep.Param(0) = New EncoderParameter(enc, CLng(EncoderValue.MultiFrame))
ORIGINAL POST
VB.Net, Visual Studio 2012, .Net 4.5
I have been trying to write, borrow, or steal code that will merge multiple TIFF files in to a single tiff file. Every example, whether I write or get it from someplace fails on the same line with the exception, "A generic error occurred in GDI+". The line that causes the problem is DestinationImage.SaveAdd(img, imagePararms). There is just not enough to go on with that generic error message about a generic error. Has anyone experienced this?
Greg
Public Sub mergeTiffPages(str_DestinationPath As String, sourceFiles As String())
Dim codec As System.Drawing.Imaging.ImageCodecInfo = Nothing
For Each cCodec As System.Drawing.Imaging.ImageCodecInfo In System.Drawing.Imaging.ImageCodecInfo.GetImageEncoders()
If cCodec.CodecName = "Built-in TIFF Codec" Then
codec = cCodec
End If
Next
Try
Dim imagePararms As New System.Drawing.Imaging.EncoderParameters(1)
imagePararms.Param(0) = New System.Drawing.Imaging.EncoderParameter(System.Drawing.Imaging.Encoder.SaveFlag, CLng(System.Drawing.Imaging.EncoderValue.MultiFrame))
If sourceFiles.Length = 1 Then
System.IO.File.Copy(DirectCast(sourceFiles(0), String), str_DestinationPath, True)
ElseIf sourceFiles.Length >= 1 Then
Dim DestinationImage As System.Drawing.Image = DirectCast(New System.Drawing.Bitmap(DirectCast(sourceFiles(0), String)), System.Drawing.Image)
DestinationImage.Save(str_DestinationPath, codec, imagePararms)
imagePararms.Param(0) = New System.Drawing.Imaging.EncoderParameter(System.Drawing.Imaging.Encoder.SaveFlag, CLng(System.Drawing.Imaging.EncoderValue.FrameDimensionPage))
For i As Integer = 0 To sourceFiles.Length - 2
Dim img As System.Drawing.Image = DirectCast(New System.Drawing.Bitmap(DirectCast(sourceFiles(i), String)), System.Drawing.Image)
DestinationImage.SaveAdd(img, imagePararms)
img.Dispose()
Next
imagePararms.Param(0) = New System.Drawing.Imaging.EncoderParameter(System.Drawing.Imaging.Encoder.SaveFlag, CLng(System.Drawing.Imaging.EncoderValue.Flush))
DestinationImage.SaveAdd(imagePararms)
imagePararms.Dispose()
DestinationImage.Dispose()
End If
Catch ex As Exception
MsgBox(ex.Message)
End Try
End Sub
Although I did not find a solution for this code I did find code that works. JohnH a moderator at http://www.vbdotnetforums.com/ posted the code below in this thread http://www.vbdotnetforums.com/graphics-gdi/22113-create-multipage-tiff-loop.html
It works for me. I added a few lines at the top to show how I called it.
Greg
'Example: Combine 4 tiff images in a new file called FinishedTiff.tiff
'Dim oNewImage As Image
'oNewImage = Image.FromFile("C:\IRISScan\Week of Jan 6 no SSN_Page_1.tif")
'SaveAddTiff(oNewImage, "C:\IRISScan\FinishedTiff.tif")
'oNewImage = Image.FromFile("C:\IRISScan\Week of Jan 6 no SSN_Page_2.tif")
'SaveAddTiff(oNewImage, "C:\IRISScan\FinishedTiff.tif")
'oNewImage = Image.FromFile("C:\IRISScan\Document3_Page_1.tif")
'SaveAddTiff(oNewImage, "C:\IRISScan\FinishedTiff.tif")
'oNewImage = Image.FromFile("C:\IRISScan\Document3_Page_2.tif")
'SaveAddTiff(oNewImage, "C:\IRISScan\FinishedTiff.tif")
Imports System.Drawing.Imaging
Module modTiff
'
Sub SaveAddTiff(ByVal img As Image, ByVal filename As String)
If Not IO.File.Exists(filename) Then
img.Save(filename, Imaging.ImageFormat.Tiff)
Else
Dim frames As List(Of Image) = getFrames(filename)
frames.Add(img)
SaveMultiTiff(frames.ToArray, filename)
End If
img.Dispose()
End Sub
Sub SaveMultiTiff(ByVal frames() As Image, ByVal filename As String)
Dim codec As ImageCodecInfo = getTiffCodec()
Dim enc As Encoder = Encoder.SaveFlag
Dim ep As New EncoderParameters(2)
ep.Param(0) = New EncoderParameter(enc, CLng(EncoderValue.MultiFrame))
ep.Param(1) = New EncoderParameter(Encoder.Compression, CLng(EncoderValue.CompressionNone))
Dim tiff As Image = frames(0)
tiff.Save(filename, codec, ep)
ep.Param(0) = New EncoderParameter(enc, CLng(EncoderValue.FrameDimensionPage))
For i As Integer = 1 To frames.Length - 1
tiff.SaveAdd(frames(i), ep)
frames(i).Dispose()
Next
ep.Param(0) = New EncoderParameter(enc, CLng(EncoderValue.Flush))
tiff.SaveAdd(ep)
tiff.Dispose()
End Sub
Function getTiffCodec() As ImageCodecInfo
For Each ice As ImageCodecInfo In ImageCodecInfo.GetImageEncoders()
If ice.MimeType = "image/tiff" Then
Return ice
End If
Next
Return Nothing
End Function
Function getFrames(ByVal filename) As List(Of Image)
Dim frames As New List(Of Image)
Dim img As Image = Image.FromFile(filename)
For i As Integer = 0 To img.GetFrameCount(Imaging.FrameDimension.Page) - 1
img.SelectActiveFrame(Imaging.FrameDimension.Page, i)
Dim tmp As New Bitmap(img.Width, img.Height)
Dim g As Graphics = Graphics.FromImage(tmp)
g.CompositingQuality = Drawing2D.CompositingQuality.HighQuality
g.InterpolationMode = Drawing2D.InterpolationMode.HighQualityBicubic
g.PixelOffsetMode = Drawing2D.PixelOffsetMode.HighQuality
g.SmoothingMode = Drawing2D.SmoothingMode.HighQuality
g.TextRenderingHint = Drawing.Text.TextRenderingHint.AntiAliasGridFit
g.DrawImageUnscaled(img, 0, 0)
frames.Add(tmp)
g.Dispose()
Next
img.Dispose()
Return frames
End Function
End Module
I replaced
g.DrawImageUnscaled(img, 0, 0)
with
g.DrawImageUnscaledAndClipped(img, New Rectangle(0, 0, img.Width, img.Height))
and it fixed the scaling issue where it would shrink the image to a quarter of its original size

ReportViewer.LocalReport.Render("PDF")

I am using Report Viewer for WinForms. The problem i am having is this: I have a form that contains a form which is used to view a local report which work fine, but when I try to render the same report as a PDF, it is cut-off, but in report viewer the same report renders a report on one page. When I render to PDF it cuts it off and the part of the report that was cut-off renders on a 2nd page. So in other words, part of the same report is on page 1, and 2nd half is on 2nd page in the PDF?
Code:
Private Function GetPDfReport() As String
Dim parameters = Me.GetReportParms()
Dim query = Me.GetReportQuery()
Dim rView As Microsoft.Reporting.WinForms.ReportViewer = New Microsoft.Reporting.WinForms.ReportViewer
rView.Dock = DockStyle.Fill
rView.SetDisplayMode(DisplayMode.PrintLayout)
Dim pnl As New Panel()
pnl.Name = "pnlMain"
pnl.Location = New System.Drawing.Point(0, 25)
pnl.Size = New System.Drawing.Size(734, 478)
pnl.Controls.Add(rView)
Dim dbReader As New dbReader()
Dim ds As DataSet = dbReader.DataSet(query)
Dim rds As Microsoft.Reporting.WinForms.ReportDataSource = New Microsoft.Reporting.WinForms.ReportDataSource("DataSet1", ds.Tables(0))
rView.ProcessingMode = Microsoft.Reporting.WinForms.ProcessingMode.Local
rView.LocalReport.DataSources.Add(rds)
rView.LocalReport.ReportEmbeddedResource = "EasyDose.rptIncident.rdlc"
If Not IsNothing(parameters) Then
Dim Bound0 As Integer = parameters.GetUpperBound(0)
Dim Bound1 As Integer = parameters.GetUpperBound(1)
For index = 0 To Bound0
Dim rParameter As New ReportParameter(parameters(index, 0), parameters(index, 1))
rView.LocalReport.SetParameters(rParameter)
Next
End If
Dim ps As PageSettings = rView.GetPageSettings
ps.Margins.Top = 0 ' 10mm approx
ps.Margins.Right = 0
ps.Margins.Bottom = 0
ps.Margins.Left = 0
ps.Landscape = False
'ps.PaperSize = New PaperSize("LetterExtra", (9.275 * 100), (12 * 100)) ' Letter paper (8.5 in. by 11 in.) ' Letter extra paper (9.275 in. by 12 in.)
ps.PaperSize = New PaperSize("A4", (8.27 * 100), (11.69 * 100))
rView.RefreshReport()
Dim exePath As String = System.IO.Path.GetDirectoryName(Application.ExecutablePath)
Dim dir As New DirectoryInfo(System.IO.Path.Combine(exePath, "tmpDir"))
Dim file As New FileInfo(System.IO.Path.Combine( _
dir.FullName, String.Format("Patient_Details_{0:yyyyMMdd_hhmmss}.pdf", DateTime.Now)))
If Not dir.Exists Then
dir.Create()
End If
Dim bytes As Byte() = rView.LocalReport.Render("PDF")
Using fs As New System.IO.FileStream(file.FullName, System.IO.FileMode.Create)
fs.Write(bytes, 0, bytes.Length)
fs.Close()
End Using
Return file.FullName
End Function
are you seeing the local report in the embedded ReportViewer using the "Print Layout" option activated? That should show exactly the same output as your printed result.
If you have problems in the PDF is probably caused by the design of the report itself. Check the font, the page size and orientation, the margins, the page breaks.
uisng System.IO;
byte[] rep = reportViewer1.LocalReport.Render("pdf", deviceInfo: "");
// if a certificate warning appears just ignore and re-run
File.WriteAllBytes(filepath+filename+".pdf",rep);

Live text reader with highlighting in VB.net

I have a program which writes to a .log file as it is installing software.
Some of the lines will contain either WARNING or FAILED.
What I would like, is a window in my program which will read the .log file and display the content into this window as it is being written too. Any lines which contain WARNING or FAILED in them are highlighted yellow/red.
Does anyone know how to do this?
Create a FORM (I used VB 2010) and add this code.
it will write 3 lines on the form in 2 colours.
It might get you on your way. Ask MSDN help for each function that is new to you.
Private Sub Form1_Paint(sender As Object, e As System.Windows.Forms.PaintEventArgs) Handles Me.Paint
Dim chRs(0) As CharacterRange
Dim sbRs(0) As SolidBrush
Dim flRs(0) As SolidBrush
Dim blueBrush As New SolidBrush(Color.Blue)
Dim whiteBrush As New SolidBrush(Color.White)
Dim redBrush As New SolidBrush(Color.Red)
Dim EditFont As New Font("Courier New", 9)
Dim stringFormat As New StringFormat
Dim aRectangle As Rectangle
Dim RectHeight As Integer = 20
For i = 1 To 3
Dim txt As String = "a string " & CStr(i)
If i = 2 Then
sbRs(0) = blueBrush
Else
sbRs(0) = redBrush
End If
flRs(0) = whiteBrush
chRs(0) = New CharacterRange(0, txt.Length())
Dim chRsa As Array = Array.CreateInstance(GetType(CharacterRange), 1)
Array.Copy(chRs, 0, chRsa, 0, 1)
aRectangle = New Rectangle(0, CInt((i - 1) * RectHeight), ClientRectangle.Size.Width, RectHeight) ' x, y, w, h
stringFormat.SetMeasurableCharacterRanges(chRsa)
Dim stringRegions As Array = Array.CreateInstance(GetType([Region]), 1)
stringRegions = e.Graphics.MeasureCharacterRanges(txt, EditFont, aRectangle, stringFormat)
Dim measureRect1 As RectangleF = stringRegions(0).GetBounds(e.Graphics)
Dim g As Graphics = e.Graphics
g.FillRectangle(flRs(0), measureRect1)
g.DrawString(txt.Substring(chRs(0).First, chRs(0).Length), EditFont, sbRs(0), CSng(measureRect1.X), CSng(measureRect1.Y))
Next
End Sub