I am trying to create a point graph chart for my VB.NET program but my points are looking all jacked up and the x axis graph doesnt look right either.
The data can be displayed in excel as this.
Chart In Excel
I just hardcoded the points in my code as this.
Private Sub GenPath()
Dim startPoint As Int32 = txt_StartPnt.Text
Dim endPoint As Int32 = txt_EndPnt.Text
Dim pathInfo As List(Of CInterop.PointCordInfo)
pathInfo = CInterop.PointsInfo.GetPath(startPoint, endPoint)
cht_Path.Series.Clear()
cht_Path.Series.Add("Path")
cht_Path.Series("Path").Color = Color.Red
cht_Path.Series("Path").ChartType = DataVisualization.Charting.SeriesChartType.Point
'For X As Integer = 0 To pathInfo.Count - 1
' cht_Path.Series("Path").Points.Add(pathInfo.Item(X).XPos / 1000, pathInfo.Item(X).YPos / 1000)
'Next
cht_Path.Series("Path").Points.Add(52501, 21468)
cht_Path.Series("Path").Points.Add(52501, 18669)
cht_Path.Series("Path").Points.Add(52501, 17058)
cht_Path.Series("Path").Points.Add(52501, 14259)
cht_Path.Series("Path").Points.Add(52501, 12648)
cht_Path.Series("Path").Points.Add(52501, 9849)
cht_Path.Series("Path").Points.Add(52501, 7281)
cht_Path.Series("Path").Points.Add(54701, 7281)
cht_Path.Series("Path").Points.Add(54701, 7281)
cht_Path.Series("Path").Points.Add(54701, 11849)
cht_Path.Series("Path").Points.Add(54701, 15701)
cht_Path.Series("Path").Points.Add(54701, 19451)
cht_Path.Series("Path").Points.Add(54701, 22724)
End Sub
And here is how it looks on my VB dialog.
Chart from VB dialog
What am I missing here? It looks like the Y Axis resized itself fine, but the X values area all well over 50000 but the X Axis only displays between 0-14.
Related
I'm rewriting a VB6 application in VB.net. Instead of using the VB6 printer namespace, I'm trying make the code natively VB.net compatible.
The VB6 application has a bunch of printer.print statements as well as a bunch of printer.line statements. (I believe the lines use TWIPs.) Here is an example of some of the lines.
Printer.DrawWidth = 1.5
Printer.Line (200, 12940)-(11275, 12940)
Printer.Line (200, 13680)-(6660, 13680)
Printer.Line (6712, 13680)-(11275, 13680)
Printer.FillStyle = vbFSTransparent
Printer.DrawWidth = 1
Printer.DrawStyle = vbDashDot
Printer.Circle (5700, 6000), draw_scale * BC_Diam / 2
media.FontItalic = True
Printer.Print "some text"
media.FontItalic = False
Printer.Print "additional, non italic text"
The only way I've been able to find how to do any of this in VB.net is by using the PrintDocument's PrintPage event. A problem with doing it this way is you have to pass all of the text to this subroutine all at once and deal with a "printArea" for word wrap. Another problem is it makes it very difficult to switch between italic and non italic text. In the same way for text, I think I would have to pass in all of the line/circle coordinates as well, then draw them from the event subroutine.
Private Sub document_PrintPage(ByVal sender As Object, ByVal e As System.Drawing.Printing.PrintPageEventArgs) Handles document.PrintPage
Dim printFont As Font = New Font("Courier New", 8.5, FontStyle.Regular)
' Set print area size and margins
With document.DefaultPageSettings
Dim leftMargin As Integer = .Margins.Left 'X
Dim topMargin As Integer = .Margins.Top 'Y
Dim printHeight As Integer = .PaperSize.Height - topMargin * 2
Dim printWidth As Integer = .PaperSize.Width - leftMargin * 2
End With
' Check if the user selected to print in Landscape mode
' if they did then we need to swap height/width parameters
If document.DefaultPageSettings.Landscape Then
Dim tmp As Integer
tmp = printHeight
printHeight = printWidth
printWidth = tmp
End If
Dim lines As Int32
Dim chars As Int32
'Now we need to determine the total number of lines
'we're going to be printing
Dim numLines As Int32 = CInt(printHeight / printFont.Height)
' Create a rectangle printing are for our document
Dim printArea As New RectangleF(leftMargin, topMargin, printWidth, printHeight)
' Set format of string.
Dim format As New StringFormat(StringFormatFlags.LineLimit)
e.Graphics.MeasureString(txtText.Text.Substring(curChar), printFont, New SizeF(printWidth, printHeight), format, chars, lines)
e.Graphics.DrawString(txtText.Text.Substring(curChar), printFont, Brushes.Black, printArea, format)
'Increase current char count
curChar += chars
'Detemine if there is more text to print, if
'there is the tell the printer there is more coming
Debug.Print("curChar < txtText.Text.Length:" & (curChar < txtText.Text.Length))
If curChar < txtText.Text.Length Then
e.HasMorePages = True
Else
e.HasMorePages = False
curChar = 0
End If
End Sub
There has to be a better way to do this, right? How I can call Graphics.DrawLine, Graphics.DrawEllipse, Graphics.DrawString, etc. for the PrintDocument from outside of the PrintPage event in VB.net like you could in VB6?
I've been working through a YouTube tutorial for creating a Drag and Drop game in PowerPoint using VBA, and have got the VBA code working as expected, but I'm wondering if anyone could give me some advice on how to add to the code in order to do something that I'm trying to do. I have some programming experience in Python, but no experience scripting PPT files or VBA. Any help you can give here would be appreciated!
What I'm trying to do is apply the code to multiple slides in the same presentation. For example, I want to have some items on one slide be affected by the Drag and Drop code, and then move on to the next slide and do the same with other items. From looking at the code, and from my understanding, it's the sections that have
ActivePresentation.Slides(2)
that are what needs changing. Now, I know that the (2) refers to the slide number, but could you advise what to change this to in order for it to work on ANY slide number (I'm guessing this would need to refer to the current slide somehow). I've tried various commands that I've found online, but none seem to do what I want - anything I enter in the brackets that looks like it should affect the current slide results in the drag and drop not working at all on any slide, including the original slide that was working before the change to the code.
The relevant code is below:
Sub DragAndDrop(selectedShape As Shape)
obj_end = selectedShape.Name + "_end"
dragMode = Not dragMode
DoEvents
' If the shape has text and we're starting to drag, copy it with its formatting to the clipboard
If selectedShape.HasTextFrame And dragMode Then selectedShape.TextFrame.TextRange.Copy
dx = GetSystemMetrics(SM_SCREENX)
dy = GetSystemMetrics(SM_SCREENY)
' Shirt start position
objStart.X = selectedShape.left
objStart.Y = selectedShape.top
objEnd.X = ActivePresentation.Slides(ActivePresentation.View.Slide.SlideNumber).Shapes(obj_end).left
objEnd.Y = ActivePresentation.Slides(ActivePresentation.View.Slide.SlideNumber).Shapes(obj_end).top
'objEnd.X = ActivePresentation.Slides(2).Shapes(obj_end).left
'objEnd.Y = ActivePresentation.Slides(2).Shapes(obj_end).top
Drag selectedShape
' Paste the original text while maintaining its formatting, back to the shape
If selectedShape.HasTextFrame Then selectedShape.TextFrame.TextRange.Paste
DoEvents
End Sub
Private Sub Drag(selectedShape As Shape)
#If VBA7 Then
Dim mWnd As LongPtr
#Else
Dim mWnd As Long
#End If
Dim sx As Long, sy As Long
Dim WR As RECT ' Slide Show Window rectangle
Dim StartTime As Single
' Change this value to change the timer to automatically drop the shape (can by integer or decimal)
Const DropInSeconds = 2
' Get the system cursor coordinates
GetCursorPos mPoint
' Find a handle to the window that the cursor is over
mWnd = WindowFromPoint(mPoint.X, mPoint.Y)
' Get the dimensions of the window
GetWindowRect mWnd, WR
sx = WR.lLeft
sy = WR.lTop
Debug.Print sx, sy
With ActivePresentation.PageSetup
dx = (WR.lRight - WR.lLeft) / .SlideWidth
dy = (WR.lBottom - WR.lTop) / .SlideHeight
Select Case True
Case dx > dy
sx = sx + (dx - dy) * .SlideWidth / 2
dx = dy
Case dy > dx
sy = sy + (dy - dx) * .SlideHeight / 2
dy = dx
End Select
End With
StartTime = Timer
While dragMode
GetCursorPos mPoint
selectedShape.left = (mPoint.X - sx) / dx - selectedShape.Width / 2
selectedShape.top = (mPoint.Y - sy) / dy - selectedShape.Height / 2
Dim left As Integer
Dim top As Integer
left = selectedShape.left
top = selectedShape.top
' Comment out the next line if you do NOT want to show the countdown text within the shape
If selectedShape.HasTextFrame Then selectedShape.TextFrame.TextRange.Text = CInt(DropInSeconds - (Timer - StartTime))
ActivePresentation.Slides(ActivePresentation.View.Slide.SlideNumber).Shapes("lblInfo").TextFrame.TextRange.Text = CInt(DropInSeconds - (Timer - StartTime))
'ActivePresentation.Slides(2).Shapes("lblInfo").TextFrame.TextRange.Text = CInt(DropInSeconds - (Timer - StartTime))
DoEvents
If Timer > StartTime + DropInSeconds Then
dragMode = False
With ActivePresentation.Slides(ActivePresentation.View.Slide.SlideNumber).Shapes(obj_end) ' EXAMPLE:square_end is where you want the square to land
If selectedShape.left >= .left And selectedShape.top >= .top And (selectedShape.left + selectedShape.Width) <= (.left + .Width) And (selectedShape.top + selectedShape.Height) <= (.top + .Height) Then
ActivePresentation.Slides(ActivePresentation.View.Slide.SlideNumber).Shapes("talk").TextFrame.TextRange = "Got it! Great job!"
'totalPoints = totalPoints + 1
Else
' Try again
selectedShape.left = objStart.X
selectedShape.top = objStart.Y
ActivePresentation.Slides(ActivePresentation.View.Slide.SlideNumber).Shapes("talk").TextFrame.TextRange = "Sorry! Try again!"
End If
End With
End If
Wend
DoEvents
End Sub
I have a loop that generates rectangles automatically on a visio drawing but I need to have the script to arrange them automatically right know I recorded a macro while I rearranged the rectangles manually under the title box. But my rectangle count change constantly because the results from my if statement change constantly because my data continuously changes. I need for my loop to start drawing them under the title box in columns of six or seven rectangles.
For I = 1 To WS_Count
Set vsoShape =
Application.ActiveWindow.Page.Drop(Application.DefaultRectangleDataObject,
aoffset, boffset)
vsoShape.Text = ActiveWorkbook.Worksheets(I).Name
aoffset = aoffset
boffset = boffset + 0.75
Dev_Count = Dev_Count + 1
ActiveDocument.DiagramServicesEnabled = DiagramServices
Next I
I need to be able to set a starting position to begin dropping the rectangles below the title rectangle creating a new column every six to seven rectangles. Thanks
Increment aOffset every time I is divisible by the number of shapes you want horizontally...
You can do this with the Mod Operator If (iterator Mod runEveryXIterations = 0) Then ...
The example below should clarify the idea, the code is not exactly what you need but you should be able to grasp the idea:
Option Explicit
Public Sub printXY()
xyDistribute 10, 3, 0, 0, 0.75, 1.5
End Sub
Private Function xyDistribute(ByRef iterations As Long, _
ByRef newColAfter As Long, _
ByRef xPosInitial As Double, _
ByRef yPosInitial As Double, _
ByRef xStep As Double, _
ByRef yStep As Double)
Dim iter As Long
Dim xPos As Double
Dim yPos As Double
yPos = yPosInitial
xPos = xPosInitial
Debug.Print "xPos", "yPos"
For iter = 1 To iterations
Debug.Print xPos, yPos
' your code goes here
If (iter Mod newColAfter = 0) Then
yPos = yPos + yStep
xPos = xPosInitial
Else
xPos = xPos + xStep
End If
Next iter
End Function
I'm designing a hexagon grid and I need to be able to name each hexagon, so I can refer to them later. Below is my class, it generates the hexagon grid, and I've labeled the code throughout so you can understand what's happening.
I've been searching for a while now reading a lot about Graphics, but I can't get a working design with the answers I've seen offered. Perhaps, I'm going about this wrong by using Graphics, but my plan is to be able to click on each hexagon and do something with it.
Note: If you see a way to improve my code let me know. It's appreciated!
' Generate Hexagon Grid
Private Sub Form1_Paint(sender As Object, e As PaintEventArgs) Handles Me.Paint
' Hexagon Grid Parameters
Dim HexagonRadius As Integer = 20 ' Fix "Position Hexagon Grid Columns" Before Changing Hexagon Radius
Dim GridSize As Integer = 10
' Generate Hexagon Grid
Dim HexagonX As Integer = HexagonRadius
Dim HexagonY As Integer = HexagonRadius
For i As Integer = 1 To GridSize
For j As Integer = 1 To GridSize
' Hexagon Vertex Coordinates
Dim point1 As New Point((HexagonX - HexagonRadius), (HexagonY))
Dim point2 As New Point((HexagonX - (HexagonRadius / 2)), (HexagonY + ((HexagonRadius / 2) * Math.Sqrt(3))))
Dim point3 As New Point((HexagonX + (HexagonRadius / 2)), (HexagonY + ((HexagonRadius / 2) * Math.Sqrt(3))))
Dim point4 As New Point((HexagonX + HexagonRadius), (HexagonY))
Dim point5 As New Point((HexagonX + (HexagonRadius / 2)), (HexagonY - ((HexagonRadius / 2) * Math.Sqrt(3))))
Dim point6 As New Point((HexagonX - (HexagonRadius / 2)), (HexagonY - ((HexagonRadius / 2) * Math.Sqrt(3))))
Dim hexagonPoints As Point() = {point1, point2, point3, point4, point5, point6}
' Create Hexagon
e.Graphics.FillPolygon(Brushes.Green, hexagonPoints)
' Hexagon Outline
e.Graphics.DrawLine(Pens.Black, point1, point2)
e.Graphics.DrawLine(Pens.Black, point2, point3)
e.Graphics.DrawLine(Pens.Black, point3, point4)
e.Graphics.DrawLine(Pens.Black, point4, point5)
e.Graphics.DrawLine(Pens.Black, point5, point6)
e.Graphics.DrawLine(Pens.Black, point6, point1)
' Position Hexagon Grid Columns
HexagonY += 34 ' Specific to Hexagon Radius: 20
Next
If i Mod 2 > 0 Then
HexagonY = 36.75 ' Specific to Hexagon Radius: 20
Else
HexagonY = 20 ' Specific to Hexagon Radius: 20
End If
HexagonX += 30 ' Specific to Hexagon Radius: 20
Next
End Sub
You'll need to create some Hexagon class with it's coordinates and (maybe name, if really needed). And save them to some suitable collection (2-dimensional array maybe?)
This should happen somewhere outside your Paint event and might be recalculated on grid SizeChanged event.
Inside your Paint event you'll just iterate throught existing collection and render according to pre-computed coordinates.
OnClick event will loop throught the same collection to find specific Hexagon for updating (changing background color for example) and forcing form to repaint to take effect.
For large rendering you should consider rendering to bitmap first and drawing that final bitmap to e.Graphics for faster work. Your bitmap could be cached as well to speed up even more.
EDIT: Code sample added
Turn Option Strict On in your project properties to avoid many problems in your code that you're not aware of.
Public Class frmTest
Private Const HexagonRadius As Integer = 20
Private Const GridSize As Integer = 10
Private fHexagons As New List(Of Hexagon)
Private fCache As Bitmap
Private fGraphics As Graphics
Private Sub ResetHexagons() 'Call when some parameter changes (Radius/GridSize)
fHexagons.Clear()
Invalidate()
End Sub
Private Function EnsureHexagons() As List(Of Hexagon)
Dim X, Y As Single, xi, yi As Integer
If fHexagons.Count = 0 Then
X = HexagonRadius : Y = HexagonRadius
For xi = 1 To GridSize
For yi = 1 To GridSize
fHexagons.Add(New Hexagon(HexagonRadius, X, Y))
Y += 34
Next
'Do your math to get theese values from HexagonRadius value
If xi Mod 2 > 0 Then
Y = 36.75
Else
Y = 20
End If
X += 30
Next
fCache?.Dispose()
fGraphics?.Dispose()
fCache = New Bitmap(GridSize * HexagonRadius * 2, GridSize * HexagonRadius * 2)
fGraphics = Graphics.FromImage(fCache)
For Each H As Hexagon In fHexagons
H.Render(fGraphics)
Next
End If
Return fHexagons
End Function
Private Sub frmTest_Paint(sender As Object, e As PaintEventArgs) Handles Me.Paint
EnsureHexagons()
e.Graphics.DrawImageUnscaled(fCache, Point.Empty)
End Sub
Private Sub frmTest_MouseClick(sender As Object, e As MouseEventArgs) Handles Me.MouseClick
Dim H As Hexagon = EnsureHexagons.FirstOrDefault(Function(X) X.Contains(e.Location))
If H IsNot Nothing Then
H.Checked = Not H.Checked
H.Render(fGraphics) 'Update cache without repainting all
Invalidate()
End If
End Sub
End Class
Public Class Hexagon
Public ReadOnly Radius, X, Y As Single
Public ReadOnly Points() As PointF
Public Property Checked As Boolean
Public Sub New(Radius As Single, X As Single, Y As Single)
Me.Radius = Radius : Me.X = X : Me.Y = Y
Points = {New PointF((X - Radius), (Y)),
New PointF((X - (Radius / 2)), CSng(Y + ((Radius / 2) * Math.Sqrt(3)))),
New PointF((X + (Radius / 2)), CSng(Y + ((Radius / 2) * Math.Sqrt(3)))),
New PointF((X + Radius), (Y)),
New PointF((X + (Radius / 2)), CSng(Y - ((Radius / 2) * Math.Sqrt(3)))),
New PointF((X - (Radius / 2)), CSng(Y - ((Radius / 2) * Math.Sqrt(3.0!))))}
End Sub
Public Sub Render(G As Graphics)
' Create Hexagon
G.FillPolygon(If(Checked, Brushes.Blue, Brushes.Green), Points)
' Hexagon Outline
For i As Integer = 0 To Points.Length - 1
G.DrawLine(Pens.Black, Points(i), Points((i + 1) Mod Points.Length))
Next
End Sub
Public Function Contains(P As Point) As Boolean
'Do your math here, this is just simplified estimation
Return X - Radius <= P.X AndAlso P.X <= X + Radius AndAlso Y - Radius <= P.Y AndAlso P.Y <= Y + Radius
End Function
End Class
I am drawing a series of lines on a PrintPreviewControl using the DrawLines method. Here is my code where I take x and y values and convert them into coordinates inside a page rectangle, adding them to a list. I then call DrawLines with a pen and the list converted to an array. I have found that DrawLines will only draw 8125 lines using 8126 point pairs. I receive no exception when DrawLines fails. Any way to increase the number of point pairs that DrawLines will use? Alternatively, I could draw each line individually, or I could parse the points array into 8000 point blocks.
Private Sub DrawGammaLog(ByVal gr As Graphics)
Try
'draw log in chart area
If Points.Count <> 0I Then
gr.SetClip(LogRect)
Dim LPoints As New List(Of PointF)
For Each pt In Points
Dim PointY As Single = LogRect.Top + ((pt.Depth - VScaleMinValue) * VScale)
Dim PointX As Single = LogRect.Left + (pt.Count * HScale)
If PointY >= LogRect.Top AndAlso PointY <= LogRect.Bottom Then
LPoints.Add(New PointF(PointX, PointY))
End If
Next
Debug.Print("{0}", LPoints.Count)
If LPoints.Count >= 2I Then gr.DrawLines(gpp.LogPen, LPoints.ToArray)
End If
'draw box around chart area
gr.DrawRectangle(gpp.LogPen, Rectangle.Round(LogRect))
Catch ex As Exception
MessageBox.Show(ex.Message.ToString & ", " & ex.Source.ToString, Me.Text & " DrawGammaLog")
Finally
gr.ResetClip()
End Try
End Sub
Same issue here using c# in Visual Studio 2010. 8125 seems to be the limit, even if there are no references to this problem online...
I have splitted my array into 8000 PointF[] array blocks as a work-around.
int counter = 0;
int block_size = Math.Min(data.Length, 8000);
PointF[] data_subset;
while (counter != data.Length)
{
data_subset = new PointF[block_size];
Array.Copy(data, counter, data_subset, 0, data_subset.Length);
g.DrawLines(p, data_subset);
counter += block_size;
block_size = Math.Min(data.Length - counter, 8000);
}