Goal
To create an Ellipse in AutoCAD 2014 with the possibility of rotating it horizontally (as seen in the red rectangle below).
Attempt
I was able to create the Ellipse but I cannot seem to find how to rotate it horizontally.
CreateEllipse(AcadDoc)
Public Function CreateEllipse(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 New Ellipse(CenterPoint, axisvec, New Vector3d(0, 20, 0), 0.5, 0, Math.PI * 2)
returnId = Utils.CreateAcadObject(AcadDoc, aEllipse)
aEllipse.Dispose()
Utils.regenLayers()
Return returnId
End Function
Utils.CreateAcadObject(AcadDoc, aEllipse)
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
This is the result I get:
I'll keep trying to figure it out and I'll post my answer when I end up doing so.
On the line where you create the ellipse:
Dim aEllipse As New Ellipse(CenterPoint, axisvec, New Vector3d(0, 20, 0), 0.5, 0, Math.PI * 2)
You need to change the coordinates of the major axis like this:
Dim aEllipse As New Ellipse(CenterPoint, axisvec, New Vector3d(20, 0, 0), 0.5, 0, Math.PI * 2)
Related
Very new to Visual basic, and I need to set the background color of a Windows Form as a ColorBlend this is what I have so far. How do I finish it off?
Dim col As New ColorBlend
Dim myColours As Color() = {Color.Red, Color.Green}
col.Colors = myColours
Me.BackColor
I know this may seem a bit futile, but I need it for an assignment. Thanks
The code below works perfectly for me :
Protected Overrides Sub OnPaintBackground(ByVal pevent As System.Windows.Forms.PaintEventArgs)
'Define starters (the point [0,0] is the top-left corner of the form)
Dim y As Integer = 0
Dim x As Integer = 0
'Define the dimension (here it depends on your form dimension)
Dim wid As Integer = Me.Width
Dim hgt As Integer = Me.Height
Dim red_green_brush As New LinearGradientBrush(New Point(x, y), New Point(x + wid, y), Color.Red, Color.Green)
' ColorBlend.
pevent.Graphics.DrawString("ColorBlend", Me.Font, Brushes.Red, x, y)
y += 15
Dim color_blend As New ColorBlend(2)
color_blend.Colors = New Color() {Color.Red, Color.Green}
color_blend.Positions = New Single() {0.0, 1.0}
red_green_brush.InterpolationColors = color_blend
pevent.Graphics.FillRectangle(red_green_brush, x, y, wid, hgt)
red_green_brush.Dispose()
End Sub
Basically my program takes a "sample" image from the user, then takes a screenshot of the entire user's screen, and then if it found that sample on the users screen, it returns the coordinates of it and moves the mouse there.
It works fine if I save the screenshot to a bitmap and compare the sample to a file, but when I try to call the screenshot directly into the function, it fails to find a match.
Any idea why?
First the code for the button click that triggers the comparison:
Private Sub Button2_Click(sender As Object, e As EventArgs) Handles Button2.Click
Dim clickhere As Point
Dim bounds As Rectangle
Dim screenshot As System.Drawing.Bitmap
Dim graph As Graphics
bounds = Screen.PrimaryScreen.Bounds
screenshot = New System.Drawing.Bitmap(bounds.Width, bounds.Height, System.Drawing.Imaging.PixelFormat.Format32bppArgb)
graph = Graphics.FromImage(screenshot)
graph.CopyFromScreen(bounds.X, bounds.Y, 0, 0, bounds.Size, CopyPixelOperation.SourceCopy)
Dim src As New Bitmap(srcpath.Text)
Dim g = Graphics.FromImage(screenshot)
g.CopyFromScreen(0, 0, 0, 0, screenshot.Size)
g.Dispose()
clickhere = BitmapExtension.Contains(screenshot, src)
MsgBox(clickhere.ToString)
Cursor.Position = clickhere
End Sub
And here is the function:
Imports System.Drawing
Imports System.Runtime.CompilerServices
Imports System.Drawing.Imaging
Imports System.Runtime.InteropServices
Module BitmapExtension
<Extension()>
Public Function Contains(src As Bitmap, ByRef bmp As Bitmap) As Point
'
'-- Some logic pre-checks
'
If src Is Nothing OrElse bmp Is Nothing Then Return New Point(Integer.MinValue, Integer.MinValue)
If src.Width < bmp.Width OrElse src.Height < bmp.Height Then
Return New Point(Integer.MinValue, Integer.MinValue)
End If
'
'-- Prepare optimizations
'
Dim sr As New Rectangle(0, 0, src.Width, src.Height)
Dim br As New Rectangle(0, 0, bmp.Width, bmp.Height)
Dim srcLock As BitmapData = src.LockBits(sr, Imaging.ImageLockMode.ReadOnly, PixelFormat.Format32bppRgb)
Dim bmpLock As BitmapData = bmp.LockBits(br, Imaging.ImageLockMode.ReadOnly, PixelFormat.Format32bppRgb)
Dim sStride As Integer = srcLock.Stride
Dim bStride As Integer = bmpLock.Stride
Dim srcSize As Integer = sStride * src.Height
Dim bmpSize As Integer = bStride * bmp.Height
Dim srcBuff(srcSize) As Byte
Dim bmpBuff(bmpSize) As Byte
Marshal.Copy(srcLock.Scan0, srcBuff, 0, srcSize)
Marshal.Copy(bmpLock.Scan0, bmpBuff, 0, bmpSize)
' we don't need to lock the image anymore as we have a local copy
bmp.UnlockBits(bmpLock)
src.UnlockBits(srcLock)
Return FindMatch(srcBuff, src.Width, src.Height, sStride, bmpBuff, bmp.Width, bmp.Height, bStride)
End Function
Private Function FindMatch(srcBuff() As Byte, srcWidth As Integer, srcHeight As Integer, srcStride As Integer,
bmpBuff() As Byte, bmpWidth As Integer, bmpHeight As Integer, bmpStride As Integer) As Point
For Y As Integer = 0 To srcHeight - bmpHeight - 1
For x As Integer = 0 To srcWidth - bmpWidth - 1
If AllPixelsMatch(x, Y, srcBuff, srcStride, bmpBuff, bmpWidth, bmpHeight, bmpStride) Then
Return New Point(x, Y)
End If
Next
Next
Return New Point(Integer.MinValue, Integer.MinValue)
End Function
Private Function AllPixelsMatch(X As Integer, Y As Integer, srcBuff() As Byte, srcStride As Integer,
bmpBuff() As Byte, bmpWidth As Integer, bmpHeight As Integer, bmpStride As Integer) As Boolean
For by As Integer = 0 To bmpHeight - 1
For bx As Integer = 0 To bmpWidth - 1
Dim bmpIndex As Integer = by * bmpStride + bx * 4
Dim a As Byte = bmpBuff(bmpIndex + 3)
'If bmp pixel is not transparent, check if the colours are identical
If a > 0 T
hen
Dim srcX = X + bx
Dim srcY = Y + by
Dim srcIndex = srcY * srcStride + srcX * 4
For i As Integer = 0 To 2
'check if the r, g and b bytes match
If srcBuff(srcIndex + i) <> bmpBuff(bmpIndex + i) Then Return False
Next
Else
'if bmp pixel is transparent, continue seeking.
Continue For
End If
Next
Next
Return True
End Function
End Module
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
i want to make an image in vb.net which is a string
it should be made of 2 colors one as forecolor the other as a color surrounding the first one
how should i make it using code?
my result must be some thing like this image(yellow as forecolor and red! as background)
[the string is in persian]
right now i first make the string using
Dim result As New Bitmap(100, 100)
Dim g As Graphics = Graphics.FromImage(result)
g.DrawString("My string", New Font("Arial", 40), New SolidBrush(Color.yellow), 22, 22)
and then process this image by checking every single pixel and if they are close to the string i color them as red , the code is this
kr = font_color.R
kg = font_color.G
kb = font_color.B
For i = 0 To (img.Height - 1) Step 1
prg.Value = prg.Value + 1
For j = 0 To (img.Width - 1)
If (kr = img.GetPixel(j, i).R And kg = img.GetPixel(j, i).G And kb = img.GetPixel(j, i).B) Then
'some code
ElseIf (isnabor(j, i) = True) Then'checks if it is close enough or not
img.SetPixel(j, i, back_color)
Else
img.SetPixel(j, i, Color.Transparent)
End If
Next
Next
The problem is that it takes a long time for a large image
any better way?
Try using GraphicsPath. Check the following links for more information
www.codeproject.com/Articles/42529/Outline-Text
www.java2s.com/Tutorial/VB/0300__2D-Graphics/Textoutline.htm
www.java2s.com/Tutorial/VB/0300__2D-Graphics/AddstringtoGraphicsPath.htm
Bob Powell: Text Effects
by the help of my friend i found the answer here it is:
Dim result As New Bitmap(1000, 1000)
Dim grp As Graphics = Graphics.FromImage(result)
Dim gp As New Drawing2D.GraphicsPath
Dim useFont As Font = New Font("IranNastaliq", 100, FontStyle.Regular)
grp.TextRenderingHint = Drawing.Text.TextRenderingHint.AntiAlias
grp.SmoothingMode = Drawing2D.SmoothingMode.AntiAlias
gp.AddString(rr.Lines(aa), useFont.FontFamily, FontStyle.Regular, 100, New Point(0, 0), StringFormat.GenericTypographic)
useFont.Dispose()
grp.FillPath(Brushes.White, gp)
grp.DrawPath(Pens.Black, gp)
gp.Dispose()
pic.Image = result
I am struggling with the following problem: I have a small picture with is painted in red. This color must be changed to another color (users'choice). I used msdn and some googling did the following:
Private Function GetPicture(Iterator As Integer, tempfile As String) As String
Dim Rstring = ""
If Colors.Count = 0 OrElse Iterator >= Colors.Count Then
Rstring = tempfile
Else
Dim NewPicture = My.Computer.FileSystem.GetTempFileName()
My.Computer.FileSystem.CopyFile(tempfile, NewPicture, True)
Dim mypict = New Bitmap(NewPicture)
Dim ColorList As New List(Of Color)
For x = 0 To mypict.Width - 1
For y = 0 To mypict.Height - 1
Dim mypixel = mypict.GetPixel(x, y)
If ColorList.Contains(mypixel) = False Then
ColorList.Add(mypixel)
End If
Next
Next
Dim NewColor = Color.FromArgb(255, 0, 0, 255)
Dim ListOfColorMaps As New List(Of ColorMap)
For Each elem In ColorList
Dim newcolormap = New ColorMap
newcolormap.OldColor = elem
newcolormap.NewColor = NewColor
ListOfColorMaps.Add(newcolormap)
Next
Dim imageAttributes As New ImageAttributes()
Dim width As Integer = mypict.Width
Dim height As Integer = mypict.Height
Dim colorMap As New ColorMap()
'colorMap.OldColor = Color.FromArgb(255, 0, 0, 0) ' opaque red
'colorMap.NewColor = Color.FromArgb(255, 0, 0, 255) ' opaque blue
Dim remapTable As ColorMap() = ListOfColorMaps.ToArray
imageAttributes.SetRemapTable(remapTable, ColorAdjustType.Bitmap)
Dim tempBmp = New Bitmap(width, height)
Dim g = Graphics.FromImage(tempBmp)
g.DrawImage(tempBmp, New Rectangle(0, 0, width, height), 0, 0, width, height, GraphicsUnit.Pixel, imageAttributes)
g.Save()
g.Dispose()
mypict.Dispose()
Dim NewFileName = NewPicture.Remove(NewPicture.IndexOf("."c) - 1) & ".png"
tempBmp.Save(NewFileName, Imaging.ImageFormat.Png)
My.Computer.FileSystem.DeleteFile(NewPicture)
tempBmp.Dispose()
Rstring = NewPicture
End If
Return Rstring
The Code runs without exceptions, and it seems to find the desired colors but the saved tempbmp contains no picture. Does this happen because the code runs in a dll without graphic?
You can pretty much ignore the "IF" part - that has something to do with another usecase.
Greetings and sincere thanks
Christian Sauer
You are getting no picture displayed because you are drawing an empty bitmap.
Your problem starts here:
Dim tempBmp = New Bitmap(width, height)
Dim g = Graphics.FromImage(tempBmp)
g.DrawImage(tempBmp, New Rectangle(0, 0, width, height), 0, 0, width, height, _
GraphicsUnit.Pixel, imageAttributes)
You create a new bitmap (probably with a white background).
Then you create a new Graphics object from your empty bitmap.
Then you draw the empty bitmap onto itself.
What you should be doing is drawing the mypict object (which is the bitmap whose colors you want to change). Thus your third line should be as follows:
g.DrawImage(mypict, New Rectangle(0, 0, width, height), 0, 0, width, height, _
GraphicsUnit.Pixel, imageAttributes)
Since the Graphics object g is associated with tempBmp (which is empty prior to the DrawImage operation) drawing mypict will draw to it with your parameters.
One other recommendation is that you remove the g.Save() line. You save a graphics object when you plan to restore it later. Doing a Graphics.Save() does not save a picture. What really saves the changes you have made is the tempBmp.Save() line.