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)
Related
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
I'm trying to display a list of colors in a combobox. Each item in the box contains the name of a color suffixed by a rectangle filled with the corresponding color as shown in a project here.
The project is written in c#. I don't understand c# so I've converted the codes to vb .net as shown below.
Private Sub Button1_Click(ByVal sender As Object, ByVal e As EventArgs) Handles Button1.Click
Dim ColorList As ArrayList = New ArrayList()
Dim colorType As Type = GetType(System.Drawing.Color)
Dim propInfoList As PropertyInfo() = colorType.GetProperties(BindingFlags.[Static] Or BindingFlags.DeclaredOnly Or BindingFlags.[Public])
For Each c As PropertyInfo In propInfoList
ComboBox1.Items.Add(c.Name)
Next
End Sub
Private Sub Combobox1_DrawItem(ByVal sender As Object, ByVal e As DrawItemEventArgs) Handles ComboBox1.DrawItem
Dim g As Graphics = e.Graphics
Dim rect As Rectangle = e.Bounds
If e.Index >= 0 Then
Dim n As String = (CType(sender, ComboBox)).Items(e.Index).ToString()
Dim f As Font = New Font("Arial", 9, FontStyle.Regular)
Dim c As Color = Color.FromName(n)
Dim b As Brush = New SolidBrush(c)
g.DrawString(n, f, Brushes.Black, rect.X, rect.Top)
g.FillRectangle(Brushes.Blue, rect.X + 110, rect.Y + 5, rect.Width - 10, rect.Height - 10)
End If
End Sub
When I execute the above code, the combo box Combobox1 displays items with only the names of the color. The colored rectangles are not displayed as show in the project I've linked above.
What's causing the rectangles not be displayed?
I've tried setting Combobox1's DrawMode to all available DrawModes. Nothing worked.
Note, I've used Telerik's code converter to convert the c# code to vb .net code.
Dim N As String = (CType(sender, ComboBox)).Items(e.Index).ToString()
Dim F As Font = New Font("Arial", 10, FontStyle.Regular)
Dim B As Brush = New SolidBrush(e.ForeColor)
Dim C As Color = Color.FromName(N)
Dim P As Brush = New SolidBrush(C)
Dim L As Pen = New Pen(e.ForeColor)
Dim R1 As Rectangle = New Rectangle(e.Bounds.Left + 2, e.Bounds.Top + 2, 50, e.Bounds.Height - 4)
Dim R2 As Rectangle = New Rectangle(e.Bounds.Left + 3, e.Bounds.Top + 3, 48, e.Bounds.Height - 6)
Dim R3 As Rectangle = New Rectangle(e.Bounds.Left + 2, e.Bounds.Top + 2, 50, e.Bounds.Height - 4)
Dim R4 As Rectangle = New Rectangle(e.Bounds.Left + 2, e.Bounds.Top + 2, 50, e.Bounds.Height - 4)
e.Graphics.DrawRectangle(L, R1)
e.Graphics.FillRectangle(P, R2)
e.Graphics.DrawString(N, F, B, e.Bounds.Left + 65, e.Bounds.Top + 2)
e.DrawFocusRectangle()
I've been doing a skin stealer, but for some reason, when I re-click button 3, it just freezes. Note that I've added the MsgBoxes to know where it freezes (As far as I know, it freezes at AssembleSkin()). I have no idea why it would do that, so if you have an idea why, go ahead and post a suggestion! Thanks
Private Sub Button3_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button3.Click
If TextBox1.Text = "" Then
Else
MsgBox("1")
Dim request = DirectCast(WebRequest.Create _
("http://www.minecraft.net/skin/" + TextBox1.Text + ".png"), WebRequest)
MsgBox("2")
Try
Dim response As WebResponse = DirectCast(request.GetResponse(), WebResponse)
MsgBox("3")
AssembleSkin(FindImage(TextBox1.Text), PictureBox1, PictureBox2, PictureBox5, PictureBox6, PictureBox3, PictureBox4)
MsgBox("4")
Dim Skin As Image = FindImage(TextBox1.Text)
MsgBox("5")
PictureBox7.Image = SizeImage(Skin, 300, 150)
Catch ex As WebException
Dim response As WebResponse = DirectCast(ex.Response, WebResponse)
MsgBox("Skin does not exist", MsgBoxStyle.OkOnly, "Mynecraft V2")
End Try
End If
End Sub
Private Function FindImage(ByVal Username As String) As Image
Dim tClient As WebClient = New WebClient
Dim tImage As Bitmap = Bitmap.FromStream(New MemoryStream(tClient.DownloadData("http://www.minecraft.net/skin/" + Username + ".png")))
Return tImage
End Function
Public Function GetPicturePart(ByVal SourceImage As Bitmap, ByVal Region As Rectangle) As Bitmap
Dim ImagePart As Bitmap = New Bitmap(Region.Width, Region.Height)
Using G As Graphics = Graphics.FromImage(ImagePart)
Dim TargetRect As Rectangle = New Rectangle(0, 0, Region.Width, Region.Height)
Dim SourceRect As Rectangle = Region
G.DrawImage(SourceImage, TargetRect, SourceRect, GraphicsUnit.Pixel)
End Using
Return ImagePart
End Function
Private Function SizeImage(ByVal img As Bitmap, ByVal width As Integer, ByVal height As Integer) As Bitmap
Dim newBit As New Bitmap(width, height)
Dim g As Graphics = Graphics.FromImage(newBit)
g.InterpolationMode = Drawing2D.InterpolationMode.NearestNeighbor
g.PixelOffsetMode = Drawing2D.PixelOffsetMode.Half
g.DrawImage(img, 0, 0, width, height)
Return newBit
End Function
Private Sub AssembleSkin(ByVal Image As Image, ByVal Head As PictureBox, ByVal Body As PictureBox, ByVal LeftArm As PictureBox, ByVal RightArm As PictureBox, ByVal RightLeg As PictureBox, ByVal LeftLeg As PictureBox)
Head.Image = SizeImage(GetPicturePart(Image, New Rectangle(New Point(8, 8), New Size(8, 8))), 64, 64)
Body.Image = SizeImage(GetPicturePart(Image, New Rectangle(New Point(20, 20), New Size(8, 12))), 64, 96)
LeftArm.Image = SizeImage(GetPicturePart(Image, New Rectangle(New Point(44, 20), New Size(4, 12))), 32, 96)
RightArm.Image = SizeImage(GetPicturePart(Image, New Rectangle(New Point(44, 20), New Size(4, 12))), 32, 96)
LeftLeg.Image = SizeImage(GetPicturePart(Image, New Rectangle(New Point(4, 20), New Size(4, 12))), 32, 96)
RightLeg.Image = SizeImage(GetPicturePart(Image, New Rectangle(New Point(4, 20), New Size(4, 12))), 32, 96)
End Sub
ByVal Image As Image
;o first time i've seen this notation.
also, in your catch statement check the ex.tostring stack trace. (or using system.diagnostics.stacktrace)/
also, what happens when the findimage method returns null, and that is passed to the assembleskin method. that also has a high probability of being the issue.
in any case, check the exception code/trace.
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)
I have a problem in flipping text in VB.NET
It is flipped but with no line brake
See the Link:
http://www.spider-news.net/Flip_Text_question.JPG
Imports System.Drawing.Drawing2D
Imports System.Drawing
Public Class Form1
Private Sub Form1_Paint(ByVal sender As Object, ByVal e As System.Windows.Forms.PaintEventArgs) Handles Me.Paint
' Draw the text and the surrounding rectangle START.
Dim text1 As String = RichTextBox1.Text
Dim font1 As New Font("Arial", 10, FontStyle.Bold, GraphicsUnit.Point)
Try
Dim rect1 As New Rectangle(10, 10, 1000, 140)
' Create a StringFormat object with the each line of text, and the block
' of text centered on the page.
Dim stringFormat As New StringFormat()
stringFormat.Alignment = StringAlignment.Center
stringFormat.LineAlignment = StringAlignment.Center
' Draw the text and the surrounding rectangle.
e.Graphics.DrawString(text1, font1, Brushes.Blue, rect1, stringFormat)
e.Graphics.DrawRectangle(Pens.Black, rect1)
Finally
font1.Dispose()
End Try
' Draw the text and the surrounding rectangle END.
'' FLIP TEXT ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Draw Flipped Text the text surrounding rectangle START.
Using the_font As New Font("Arial", 20, FontStyle.Bold, GraphicsUnit.Point)
DrawFlippedText(e.Graphics, the_font, Brushes.Black, 10, 10, RichTextBox1.Text, True, False)
Dim txt_size As SizeF
txt_size = e.Graphics.MeasureString(RichTextBox1.Text, the_font)
e.Graphics.DrawRectangle(Pens.Red, 10, 10, txt_size.Width, txt_size.Height)
End Using
' Draw Flipped Text the text surrounding rectangle END.
'' FLIP TEXT ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
End Sub
Public Sub DrawFlippedText(ByVal gr As Graphics, ByVal the_font As Font, ByVal the_brush As Brush, ByVal x As Integer, ByVal y As Integer, ByVal txt As String, ByVal flip_x As Boolean, ByVal flip_y As Boolean)
' Save the current graphics state.
Dim state As GraphicsState = gr.Save()
' Set up the transformation.
Dim scale_x As Integer = IIf(flip_x, -1, 1)
Dim scale_y As Integer = IIf(flip_y, -1, 1)
gr.ResetTransform()
gr.ScaleTransform(scale_x, scale_y)
' Figure out where to draw.
Dim txt_size As SizeF = gr.MeasureString(txt, the_font)
If flip_x Then x = -x - RichTextBox1.Size.Width
If flip_y Then y = -y - RichTextBox1.Size.Height
Dim rect1 As New Rectangle(10, 10, 1000, 140)
Dim stringFormat As New StringFormat()
stringFormat.Alignment = StringAlignment.Center
stringFormat.LineAlignment = StringAlignment.Center
' Draw.
gr.DrawString(txt, the_font, the_brush, x, y)
' Restore the original graphics state.
gr.Restore(state)
End Sub
End Class
Please HELP
My guess is that if the linebreaks are not there you have to split the string into single words.
Then concatenate the words one by one and measure the lenght. if it exceeds your line width draw this string and continue with the next words.
The next draw should be on y-coordinate + your line-height.
I did this in a pdf where i place a text to an absolute position which could be more than 1 line:
Dim splitted As String() = text.Split()
Dim tempchunk As Chunk = New Chunk("", pdfFont)
Dim count As Integer = 0
For Each s As String In splitted
Dim chunk2 As Chunk
chunk2 = New Chunk(tempchunk.Content, pdfFont)
chunk2.Append(" " & s)
If chunk2.GetWidthPoint() > 155 Then
cb.SaveState()
cb.BeginText()
cb.MoveText(x, y - (13 * count))
cb.SetFontAndSize(bfont, 11)
cb.ShowText(tempchunk.Content.Trim())
cb.EndText()
cb.RestoreState()
tempchunk = New Chunk(s, pdfFont)
count += 1
Else
tempchunk.Append(" " & s)
End If
Next
If tempchunk.Content <> "" Then
cb.SaveState()
cb.BeginText()
cb.MoveText(x, y - (13 * count))
cb.SetFontAndSize(bfont, 11)
cb.ShowText(tempchunk.Content.Trim())
cb.EndText()
cb.RestoreState()
End If
Its the code for the pdf but maybe it helps
Try this.
I created a bitmap, draw the string and rectangle there, flipped it, then draw the bitmap (with flipped text) on the Form.
Public Class Form1
Private Sub RichTextBox1_TextChanged(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles RichTextBox1.TextChanged
Dim b As New Bitmap(300, 100)
Dim g As Graphics = Graphics.FromImage(b)
Dim d As Graphics = Me.CreateGraphics
Dim r As New Rectangle(0, 0, b.Width - 1, b.Height - 1)
Dim f As New StringFormat
f.Alignment = StringAlignment.Center
f.LineAlignment = StringAlignment.Center
g.Clear(BackColor)
g.DrawRectangle(Pens.Red, r)
g.DrawString(RichTextBox1.Text, RichTextBox1.Font, Brushes.Blue, r, f)
b.RotateFlip(RotateFlipType.RotateNoneFlipX)
d.DrawImageUnscaled(b, 10, 10)
g.Dispose()
b.Dispose()
d.Dispose()
End Sub
End Class