Related
I have a Custom Control that displays color selections in a drop down and it works good.
I found the performance was poor with multiple controls on the same Form so I changed it to store the Color index in the Items collection.
This works good but the Designer gets populated with a large array of values and this causes empty items in the control.
How do I stop the designer from storing the Items?
Here is the designer code I don't want:
Me.cboCWarcColor.Items.AddRange(New Object()
{0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18,
19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35,
36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52,
53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69,
70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86,
87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102,
103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 114, 115,
116, 117, 118, 119, 120, 121, 122, 123, 124, 125, 126, 127, 128,
129, 130, 131, 132, 133, 134, 135, 136, 137, 138, 139, 140}
)
Here is the Custom Control code:
Imports System.Collections.Generic
Public Class ColorCombo
Inherits System.Windows.Forms.ComboBox
Private mSelectedColor As Color = Nothing
Private Shared myColors As New List(Of Color)
Private Shared myColorsIndices As New List(Of Object)
Private Sub ColorCombo_DrawItem(ByVal sender As Object, ByVal e As System.Windows.Forms.DrawItemEventArgs) Handles Me.DrawItem
Try
If e.Index < 0 Or e.Index >= myColors.Count Then
e.DrawBackground()
e.DrawFocusRectangle()
Exit Try
End If
' Get the Color object from the Items list
Dim aColor As Color = myColors.Item(e.Index) 'myColors.Item(e.Index)
' get a square using the bounds height
Dim rect As Rectangle = New Rectangle(4, e.Bounds.Top + 2, CInt(e.Bounds.Height * 1.5), e.Bounds.Height - 4)
' call these methods first
e.DrawBackground()
e.DrawFocusRectangle()
Dim textBrush As Brush
' change brush color if item is selected
If e.State = DrawItemState.Selected Then
textBrush = Brushes.White
Else
textBrush = Brushes.Black
End If
' draw a rectangle and fill it
Dim p As New Pen(aColor)
Dim br As New SolidBrush(aColor)
e.Graphics.DrawRectangle(p, rect)
e.Graphics.FillRectangle(br, rect)
' draw a border
rect.Inflate(1, 1)
e.Graphics.DrawRectangle(Pens.Black, rect)
' draw the Color name
e.Graphics.TextRenderingHint = Drawing.Text.TextRenderingHint.ClearTypeGridFit
e.Graphics.DrawString(aColor.Name, Me.Font, textBrush, rect.Width + 5, ((e.Bounds.Height - Me.Font.Height) \ 2) + e.Bounds.Top)
p.Dispose()
br.Dispose()
Catch ex As Exception
e.DrawBackground()
e.DrawFocusRectangle()
End Try
End Sub
Public Sub New()
' This call is required by the Windows Form Designer.
InitializeComponent()
Try
Dim aColorName As String
Me.BeginUpdate()
Items.Clear()
SelectedItem = Nothing
If myColors.Count = 0 Then
Dim names() As String = System.Enum.GetNames(GetType(System.Drawing.KnownColor))
For Each aColorName In names
If aColorName.StartsWith("Active") _
Or aColorName.StartsWith("Button") _
Or aColorName.StartsWith("Window") _
Or aColorName.StartsWith("Inactive") _
Or aColorName.StartsWith("HighlightText") _
Or aColorName.StartsWith("Control") _
Or aColorName.StartsWith("Scroll") _
Or aColorName.StartsWith("Menu") _
Or aColorName.StartsWith("Gradient") _
Or aColorName.StartsWith("App") _
Or aColorName.StartsWith("Desktop") _
Or aColorName.StartsWith("GrayText") _
Or aColorName.StartsWith("HotTrack") _
Or aColorName.StartsWith("Transparent") _
Or aColorName.StartsWith("Info") Then
Else
AddColor(Color.FromName(aColorName))
End If
Next
Else
Me.Items.AddRange(myColorsIndices.ToArray)
End If
Catch
Finally
Me.EndUpdate()
End Try
' Add any initialization after the InitializeComponent() call.
End Sub
Public Function AddColor(clr As Color) As Integer
myColors.Add(clr)
Dim idx As Integer = myColors.Count - 1
myColorsIndices.Add(idx)
Me.Items.Add(idx)
Return idx
End Function
''' <summary>
''' Returns a named color if one matches else it returns the passed color
''' </summary>
Public Function GetKnownColor(ByVal c As Color, Optional ByVal tolerance As Double = 0) As Color
For Each clr As Color In myColors
If ColorDistance(c, clr) <= tolerance Then
Return clr
End If
Next
Return c
End Function
''' <summary>
''' Returns index if one matches
''' </summary>
Public Function ContainsColor(ByVal c As Color) As Integer
Dim idx As Integer = 0
For Each clr As Color In myColors
If c.ToArgb = clr.ToArgb Then
Return idx
End If
idx += 1
Next
Return -1
End Function
Sub ColorCombo_SelectedIndexChanged(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.SelectedIndexChanged
If SelectedIndex >= 0 Then
mSelectedColor = myColors.Item(SelectedIndex)
End If
End Sub
Public Property SelectedColor() As Color
Get
'If mSelectedColor.Name = "Transparent" Then
' Return Color.Black
'End If
Return mSelectedColor
End Get
Set(ByVal value As Color)
Try
Dim smallestDist As Double = 255
Dim currentDist As Double = 0
Dim bestMatch As Integer = 0
Dim idx As Integer = -1
For Each c As Color In myColors
idx += 1
currentDist = ColorDistance(c, value)
If currentDist < smallestDist Then
smallestDist = currentDist
bestMatch = idx
End If
Next
If Me.Items.Count >= bestMatch Then
Me.SelectedIndex = bestMatch
End If
Catch ex As Exception
Debug.Print(ex.Message)
End Try
End Set
End Property
Private Function ColorDistance(ByRef clrA As Color, ByRef clrB As Color) As Double
Dim r As Long, g As Long, b As Long
r = CShort(clrA.R) - CShort(clrB.R)
g = CShort(clrA.G) - CShort(clrB.G)
b = CShort(clrA.B) - CShort(clrB.B)
Return Math.Sqrt(r * r + g * g + b * b)
End Function
End Class
Since you're adding the Color selection to the ComboBox.Items collection, the Form Designer serializes this this collection, adding all items to the Form.Designer.vb file. This also happens when you add Items a ComboBox using the Properties pane in the Designer: same effect.
You can instead set the DataSource of the ComboBox: it's faster and the object you add are not serialized. I also suggest not to add these values in the Control Constructor, but in the OnHandleCreated() override: the values are loaded only when the Control Handle is created, at run-time, so you don't load (not so useful) collections of items in the designer.
Since the handle can be recreated at run-time, more than once, there's a check for that (to avoid building the collection more than once).
Here, I'm using the ColorConverter's GetStandardValues() method to build a collection of known colors, excluding from the enumeration colors that have the IsSystemColor property set.
The collection is store in an array of Color objects, here named supportedColors.
You can also filter the collection returned by [Enum].GetValues() to get the same result, e.g.:
Dim colors As Color() = [Enum].GetValues(GetType(KnownColor)).OfType(Of KnownColor)().
Where(Function(kc) kc > 26 AndAlso kc < 168).
Select(function(kc) Color.FromKnownColor(kc)).ToArray()
SystemColors have Indexes < 27 and > 167 (I suggest not to rely on these values).
I've made a few changes to Custom Control:
When a Control is derived from an existing class, we don't subscribe to the events (e.g., DrawItem), we override the methods that rise the events (e.g., OnDrawItem()), then call base (MyBase) to rise the event (eventually, we can also not do that, if necessary). We are always one step ahead this way.
The drawing part needed some refactoring:
The Item's background actually was drawn 3 times
Disposable object should be declared with a Using statement, so we don't forget to dispose of them: very important when it comes to Graphics objects.
Replaced Graphics.DrawString() with TextRenderer.DrawText, to respect the original drawing.
Simplified the calculations: it's important to be as fast as possible here.
Thus also remove all Try/Catch blocks: costly and not really needed (don't use Try/Catch blocks when drawing, a few If conditions and some constraints - e.g., Math.Min(Math.Max()) - are better).
Also overridden OnMeasureItem() to change the height of the Items, set to Font.Height + 4 (pretty standard).
Other stuff you can see in the source code.
I've changed the SelectedColor custom property to be more reliable and to make it work with both OnSelectedIndexChanged() and OnSelectionChangeCommitted().
All Items represent a Color, so you can get the Color selected as, e.g.:
Private Sub ColorCombo1_SelectionChangeCommitted(sender As Object, e As EventArgs) Handles ColorCombo1.SelectionChangeCommitted
SomeControl.BackColor = DirectCast(ColorCombo1.SelectedItem, Color)
' Or
SomeControl.BackColor = ColorCombo1.SelectedColor
End Sub
Modified the ComboBox Custom Control:
Remove what you have in Public Sub New and InitializeComponent(), it's not needed anymore.
Imports System.Collections.Generic
Imports System.ComponentModel
Imports System.Drawing
Imports System.Windows.Forms
Public Class ColorCombo
Inherits ComboBox
Private mSelectedColor As Color = Color.Empty
Private supportedColors As Color() = Nothing
Public Sub New()
DropDownStyle = ComboBoxStyle.DropDownList
DrawMode = DrawMode.OwnerDrawVariable
FlatStyle = FlatStyle.Flat
FormattingEnabled = False
' Set these just to show that the background color is important here
ForeColor = Color.White
BackColor = Color.FromArgb(32, 32, 32)
End Sub
Protected Overrides Sub OnHandleCreated(e As EventArgs)
MyBase.OnHandleCreated(e)
If DesignMode OrElse Me.Items.Count > 0 Then Return
supportedColors = New ColorConverter().GetStandardValues().OfType(Of Color)().
Where(Function(c) Not c.IsSystemColor).ToArray()
' Preserves a previous selection if any
Dim tmpCurrentColor = mSelectedColor
Me.DisplayMember = "Name"
Me.DataSource = supportedColors
If Not tmpCurrentColor.Equals(Color.Empty) Then
mSelectedColor = tmpCurrentColor
SelectedColor = mSelectedColor
End If
End Sub
Private flags As TextFormatFlags = TextFormatFlags.NoPadding Or TextFormatFlags.VerticalCenter
Protected Overrides Sub OnDrawItem(e As DrawItemEventArgs)
e.DrawBackground()
If e.Index < 0 Then Return
Dim itemColor = supportedColors(e.Index)
Dim colorRect = New Rectangle(e.Bounds.X + 1, e.Bounds.Y + 1, e.Bounds.Height - 2, e.Bounds.Height - 2)
Using colorBrush As New SolidBrush(itemColor)
e.Graphics.FillRectangle(colorBrush, colorRect)
Dim textRect = New Rectangle(New Point(colorRect.Right + 6, e.Bounds.Y), e.Bounds.Size)
TextRenderer.DrawText(e.Graphics, itemColor.Name, e.Font, textRect, e.ForeColor, Color.Transparent, flags)
End Using
e.DrawFocusRectangle()
MyBase.OnDrawItem(e)
End Sub
Protected Overrides Sub OnMeasureItem(e As MeasureItemEventArgs)
e.ItemHeight = Font.Height + 4
MyBase.OnMeasureItem(e)
End Sub
Protected Overrides Sub OnSelectedIndexChanged(e As EventArgs)
If SelectedIndex >= 0 Then mSelectedColor = supportedColors(SelectedIndex)
MyBase.OnSelectedIndexChanged(e)
End Sub
Protected Overrides Sub OnSelectionChangeCommitted(e As EventArgs)
mSelectedColor = supportedColors(SelectedIndex)
MyBase.OnSelectionChangeCommitted(e)
End Sub
Public Property SelectedColor As Color
Get
Return mSelectedColor
End Get
Set
mSelectedColor = Value
If Not IsHandleCreated Then Return
If mSelectedColor.IsKnownColor Then
SelectedItem = mSelectedColor
Else
If supportedColors Is Nothing Then Return
Dim smallestDist As Double = 255
Dim currentDist As Double = 0
Dim bestMatch As Integer = 0
Dim idx As Integer = -1
For Each c As Color In supportedColors
idx += 1
currentDist = ColorDistance(c, Value)
If currentDist < smallestDist Then
smallestDist = currentDist
bestMatch = idx
End If
Next
If supportedColors.Count >= bestMatch Then
mSelectedColor = supportedColors(bestMatch)
SelectedItem = mSelectedColor
End If
End If
End Set
End Property
Private Function ColorDistance(clrA As Color, clrB As Color) As Double
Dim r As Integer = CInt(clrA.R) - clrB.R
Dim g As Integer = CInt(clrA.G) - clrB.G
Dim b As Integer = CInt(clrA.B) - clrB.B
Return Math.Sqrt(r * r + g * g + b * b)
End Function
Public Function GetKnownColor(c As Color, Optional ByVal tolerance As Double = 0) As Color
For Each clr As Color In supportedColors
If ColorDistance(c, clr) <= tolerance Then Return clr
Next
Return c
End Function
Public Function ContainsColor(c As Color) As Integer
Dim idx As Integer = 0
For Each clr As Color In Me.Items
If c.ToArgb = clr.ToArgb Then Return idx
idx += 1
Next
Return -1
End Function
End Class
This is how it works:
I have been banging my head against the wall trying to figure out how to make numbers not repeat from a specific list that I have created. Can someone please help? Once a number is chosen I dont want it to be chosen again. Seems like numbers.Remove(number) isnt working
Private Sub GetMoneyRand()
If randomLog.Count = numberList.Count Then
MsgBox("No more number for random")
Return
End If
For i As Integer = 1 To 100
Dim rndDummy As Integer = CInt(numMax.Value * Rnd())
lblRandomNumber.Text = rndDummy
Threading.Thread.Sleep(30)
Application.DoEvents()
Next
Randomize()
Dim r As New Random
Dim numbers As New List(Of Integer)
numbers.AddRange(New Integer() {1, 16, 31, 46, 61, 10, 15, 14, 75, 33, 11, 19, 25, 44, 50, 72, 2, 44, 20, 30})
Dim number As Integer = numbers(r.Next(0, numbers.Count))
For x As Integer = 1 To 20
numbers.Remove(number)
Next
randomLog.Add(number)
lblRandomNumber.Text = number
numberList(number).BackColor = Color.LightBlue
Please turn on Option Strict. This is a 2 part process. First for the current project - In Solution Explorer double click My Project. Choose Compile on the left. In the Option Strict drop-down select ON. Second for future projects - Go to the Tools Menu -> Options -> Projects and Solutions -> VB Defaults. In the Option Strict drop-down select ON. This will save you from bugs at runtime.
To create a list with unique random numbers use the .Contains method of List(of T) before adding the new random to the list.
Private numbers As New List(Of Integer) From {1, 16, 31, 46, 61, 10, 15, 14, 75, 33, 11, 19, 25, 44, 50, 72, 2, 44, 20, 30}
Private r As New Random
Private Sub AddRandomsToList()
Dim i = r.Next(0, 21)
If numbers.Contains(i) Then
MessageBox.Show("Sorry that number is already in the list. Try Again.")
Else
numbers.Add(i)
End If
End Sub
Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
AddRandomsToList()
End Sub
To remove duplicates from an existing list use the .Distinct extension method. It will return a new list of unique elements when you call .ToList
Private numbers As New List(Of Integer) From {1, 16, 1, 46, 61, 16, 15, 14, 61, 46, 11, 19, 25, 46, 50, 50, 2, 44, 20, 30}
Private r As New Random
Private Sub RemoveDuplicate()
Dim UniqueNumbers = numbers.Distinct().ToList
For Each i In UniqueNumbers
Debug.Print(i.ToString)
Next
End Sub
You should be using a stack or a queue. They both remove items as they are used.
Private numbers As Integer() = {1, 16, 31, 46, 61, 10, 15, 14, 75, 33, 11, 19, 25, 44, 50, 72, 2, 44, 20, 30}
Private rng As New Random
Private Sub OutputNumbersInRandomOrder()
Dim randomisedNumbers As New Queue(Of Integer)(numbers.OrderBy(Function(n) rng.NextDouble()))
Do Until randomisedNumbers.Count = 0
Dim number = randomisedNumbers.Dequeue()
Console.WriteLine(number)
Loop
End Sub
Each time you call Dequeue, the first number is removed from the list and returned. You can do this as many times as you like, creating a new queue each time the previous one is empty, e.g.
Private numbers As Integer() = {1, 16, 31, 46, 61, 10, 15, 14, 75, 33, 11, 19, 25, 44, 50, 72, 2, 44, 20, 30}
Private randomisedNumbers As Queue(Of Integer)
Private rng As New Random
Private Function GetRandomNumber() As Integer
If randomisedNumbers Is Nothing OrElse randomisedNumbers.Count = 0 Then
randomisedNumbers = New Queue(Of Integer)(numbers.OrderBy(Function(n) rng.NextDouble()))
End If
Return randomisedNumbers.Dequeue()
End Function
You can do the same thing with a Stack(Of Integer) and calling Pop. The only difference is that a stack takes items from the other end - LIFO instead of FIFO. As the items are randomised and all added at the same time, there's really no difference in the outcome, especially given that calling OrderByDescending would reverse the outcomes of the two types anyway. To illustrate:
Dim numbers = {1, 2, 3, 4, 5}
Dim q1 As New Queue(Of Integer)(numbers)
Dim s1 As New Stack(Of Integer)(numbers)
Console.WriteLine("q1:")
Do Until q1.Count = 0
Console.WriteLine(q1.Dequeue())
Loop
Console.WriteLine("s1:")
Do Until s1.Count = 0
Console.WriteLine(s1.Pop())
Loop
Array.Reverse(numbers)
Dim q2 As New Queue(Of Integer)(numbers)
Dim s2 As New Stack(Of Integer)(numbers)
Console.WriteLine("q2:")
Do Until q2.Count = 0
Console.WriteLine(q2.Dequeue())
Loop
Console.WriteLine("s2:")
Do Until s2.Count = 0
Console.WriteLine(s2.Pop())
Loop
Output:
q1:
1
2
3
4
5
s1:
5
4
3
2
1
q2:
5
4
3
2
1
s2:
1
2
3
4
5
I'm making a program that is randomly generating numbers into 100 rows of 15 in a ListBox using a button click. I need to get it sorted from LARGEST to SMALLEST, from left to right across the rows. I have a bubble sort in place but it is sorting smallest to largest and only down the first column.
This is how I am getting the numbers generated:
Private Sub btnGen_Click(sender As Object, e As EventArgs) Handles btnGen.Click
'Number Generator
Dim rn As New Random()
Dim array(14) As Integer
Dim temp As Integer
Dim st As String
For y As Integer = 1 To 100
For x As Integer = 1 To 15
array(x - 1) = rn.Next(100, 1000)
Next
txtList.Items.Add(ats(array))
Next
st = st & vbNewLine
Call sort()
Using fs As New FileStream(My.Settings.DAT_PATH, FileMode.Append, FileAccess.Write)
Using sw As New StreamWriter(fs)
sw.WriteLine()
End Using
End Using
End Sub
Function ats(ar As Integer()) As String
'FUNCTION for array to string seperated by comma
Dim sb As New System.Text.StringBuilder
For x As Integer = 0 To UBound(ar)
If x = UBound(ar) Then
sb.Append(ar(x).ToString)
Else
sb.Append(ar(x).ToString & ", ")
End If
Next
Return sb.ToString
End Function
This is how I am sorting them:
Sub sort()
'bubble sort from biggest to smallest
txtList.Sorted = True
Dim array(14) As Integer
Dim temp As Integer
For ipass = 1 To UBound(array)
For i = 0 To UBound(array) - 1
If array(i) > array(i + 1) Then
temp = array(i)
array(i) = array(i + 1)
array(i + 1) = temp
array.Reverse()
End If
Next i
Next ipass
End Sub
Lastly, here is an example of my current results:
107, 512, 139, 233, 582, 460, 698, 231, 395, 724, 717, 284, 699, 419, 825
119, 214, 513, 382, 538, 161, 431, 603, 573, 354, 757, 307, 204, 906, 200
124, 493, 153, 507, 675, 878, 698, 911, 625, 171, 915, 174, 270, 629, 770
126, 585, 480, 317, 731, 193, 385, 143, 152, 374, 246, 124, 205, 347, 936
139, 497, 422, 381, 127, 968, 236, 637, 406, 758, 594, 944, 929, 733, 428
Any help would be appreciated
Here's an alternative solution using a dedicated class.
The Input() method accepts a boolean switch that allows to sort the List(Of Integer) by Ascending or Descending order.
The Output() method will return a String() array that can be passed to a ListBox, using its .AddRange() method.
The Delimiter property can be used to specify how the string components (the integer values in this case) must be separated.
Private Class SortedLists
Private OutputList As List(Of String)
Public Sub New()
OutputList = New List(Of String)
Delimiter = ", "
End Sub
Public Property Delimiter As String
Public Sub Input(Values As List(Of Integer), Ascending As Boolean)
If Ascending Then
Values.Sort()
Else
Dim IValues As IOrderedEnumerable(Of Integer) = Values.OrderByDescending(Function(i) i)
Values = IValues.ToList()
End If
OutputList.Add(String.Join("", Values.
Select(Function(val, i) (val.ToString &
If(i < Values.Count - 1, Delimiter, "")))))
End Sub
Public Function Output() As String()
Return OutputList.ToArray()
End Function
End Class
The refactored procedure creates the random integers list, add the string results to a ListBox control, saves the strings to a file.
The elapsed time for the whole procedure, calculated with a StopWatch, is 7~9 milliseconds.
Using File.WriteAllLines() the elapsed time is 10~14 milliseconds.
Dim rn As New Random()
Dim MySortedLists As New SortedLists
Dim MyIntegerList As New List(Of Integer)
For y As Integer = 1 To 100
For x As Integer = 1 To 15
MyIntegerList.Add(rn.Next(100, 1000))
Next
MySortedLists.Input(MyIntegerList, False)
MyIntegerList.Clear()
Next
txtList.Items.AddRange(MySortedLists.Output())
'File.WriteAllLines is a little slower, but it's easier to read
File.WriteAllLines(My.Settings.DAT_PATH, MySortedLists.Output)
'Using fs As New FileStream(My.Settings.DAT_PATH, FileMode.Append, FileAccess.Write)
' Using sw As New StreamWriter(fs)
' For Each line As String In MySortedLists.Output
' sw.WriteLine(line)
' Next
' End Using
'End Using
I followed your "way" of doing things. You should know there are way better ways to achieve what you want.
Private Sub btnGen_Click(sender As Object, e As EventArgs) Handles btnGen.Click
'Number Generator
Dim rn As New Random()
Dim array(14) As Integer
Dim temp As Integer
Dim st As String
For y As Integer = 1 To 100
For x As Integer = 1 To 15
array(x - 1) = rn.Next(100, 1000)
Next
'txtList.Items.Add(ats(array))
Next
Dim sortedArray = sort(array)
Using fs As New FileStream(My.Settings.DAT_PATH, FileMode.Append, FileAccess.Write)
Using sw As New StreamWriter(fs)
For Each item In sortedArray
sw.WriteLine(item)
Next
End Using
End Using
End Sub
Function sort(array() As Integer) As IEnumerable(Of Integer)
'bubble sort from biggest to smallest
txtList.Sorted = True
Dim temp As Integer
For ipass = 1 To UBound(array)
For i = 0 To UBound(array) - 1
If array(i) > array(i + 1) Then
temp = array(i)
array(i) = array(i + 1)
array(i + 1) = temp
End If
Next i
Next ipass
Dim sortedArray = array.Reverse()
Return sortedArray
End Function
I recently made an app in VB 2010 and in order to make it independent of the .Net Framework, I begun remaking the app in VB 6.0. There's supposed to be a button on the form that, when pressed, opens the default email client. Then it opens a new email and copies into its body the text generated by the application on a Textbox. The problem with it is that the copied text in the body gets pasted with the wrong encoding and completely different from how it's supposed to be. I also encountered that problem in VB 2010 but I was able to fix this by using System.Uri.EscapeDataString like this
Process.Start("mailto:test#email.com?subject= &body=" & System.Uri.EscapeDataString(TextBox1.Text))
Is there a way to do something like this in vb 6.0 ?
ShellExecute Me.hwnd, "open", "mailto:test#email.com?subject= &body=" & NoonText.Text, _
vbNullString, vbNullString, 1
P.S I've tried URL Encoding it but wherever there are supposed to be spaces, crosses ("+") are pasted instead.
OK. Here's the bulk of the code that should behave like System.Uri.EscapeUriString and System.Uri.EscapeDataString using, respectively, the methods named EscapeURI() and EscapeURIData() provided in the listing below. Like any random piece of code, consider it's provided as is and thoroughly test it before you ever consider using it.
I'm providing the code for two (2) reasons:
Although your motives are questionable, as people with more reputation than me have rightly noted, there may arise a case where somebody will be confronted with the same question but for different reasons. The answer to your problem remains "Don't do it", but I still consider the technical question, per se, not any less valid and on topic.
Hopefully, with this answer you'll realize it's utterly pointless to reinvent the wheel. VB.NET was created as the successor of VB6, with among other objectives to provide means to build solutions for current, "real-world" problems all the while using less code, so it's more manageable and easier to maintain. Also, the VB6 runtime (MSVBVM60.DLL) as a dependency is more problematic than the .NET Framework simply because its support is no longer guaranteed.
So, here's the code. It's basically an implementation of character escaping as described in RFC 3986 on top of a UTF-8 encoding routine. The code is not optimized but commented so as to be easy to understand. Also, it does not support Internationalized Domain Names (RFC 3987).
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, src As Any, ByVal cb As Long)
Private Declare Function MultiByteToWideChar Lib "Kernel32.dll" ( _
ByVal CodePage As Long, _
ByVal dwFlags As Long, _
ByVal lpMultiByteStr As Long, _
ByVal cbMultiByte As Long, _
ByVal lpWideCharStr As Long, _
ByVal cchWideChar As Long _
) As Long
Private Declare Function WideCharToMultiByte Lib "Kernel32.dll" ( _
ByVal CodePage As Long, _
ByVal dwFlags As Long, _
ByVal lpWideCharStr As Long, _
ByVal cchWideChar As Long, _
ByVal lpMultiByteStr As Long, _
ByVal cbMultiByte As Long, _
ByVal lpDefaultChar As Long, _
ByVal lpUsedDefaultChar As Long _
) As Long
Private Enum VbStrConv2
vbUpperCase = VbStrConv.vbUpperCase
vbLowerCase = VbStrConv.vbLowerCase
vbProperCase = VbStrConv.vbProperCase
vbWide = VbStrConv.vbWide
vbNarrow = VbStrConv.vbNarrow
vbHiragana = VbStrConv.vbHiragana
vbUnicode = VbStrConv.vbUnicode
vbFromUnicode = VbStrConv.vbFromUnicode
vbUTF8 = &H100&
vbFromUTF8 = &H200&
End Enum
Private Const CP_ACP As Long = 0 ' Default ANSI code page.
Private Const CP_UTF8 As Long = 65001 ' UTF8.
Private Const CP_UTF16_LE As Long = 1200 ' UTF16 - little endian.
Private Const CP_UTF16_BE As Long = 1201 ' UTF16 - big endian.
Private Const CP_UTF32_LE As Long = 12000 ' UTF32 - little endian.
Private Const CP_UTF32_BE As Long = 12001 ' UTF32 - big endian.
Public Function EscapeURI(ByVal URI As String, Optional ByVal JSCompatible As Boolean = False) As String
' As per "RFC 1738: Uniform Resource Locators (URL) specification"
' 21-06-2010: Modified to conform to "RFC 3986: Uniform Resource Identifier (URI): Generic Syntax"
Dim i As Long
Dim bAnsi() As Byte
Dim iAscii As Integer
Dim sEscapedUri As String
bAnsi = StrConv2(URI, VbStrConv2.vbUTF8)
sEscapedUri = vbNullString
For i = LBound(bAnsi) To UBound(bAnsi)
iAscii = bAnsi(i)
Select Case iAscii
' ASCII control caracters, always escape
Case 0 To 31, 127
If iAscii < 16 Then
sEscapedUri = sEscapedUri & "%0" & Hex$(iAscii)
Else
sEscapedUri = sEscapedUri & "%" & Hex$(iAscii)
End If
' Non-ASCII characters, always escape
Case 128 To 255
sEscapedUri = sEscapedUri & "%" & Hex$(iAscii)
' Reserved characters, don't escape with an URI
' RFC 3986 section 2.2 Reserved Characters (January 2005)
' ! # $ & ' ( ) * + , / : ; = ? # [ ]
Case 33, 35, 36, 38, 39, 40, 41, 42, 43, 44, 47, 58, 59, 61, 63, 64, 91, 93
If JSCompatible Then
Select Case iAscii
' [ ]
Case 91, 93
' ECMAScript's encodeURI() escapes those
' (since IPv6, hosts can be e.g. [::1/128] so we want to preserve them unescaped)
sEscapedUri = sEscapedUri & "%" & Hex$(iAscii)
Case Else
sEscapedUri = sEscapedUri & Chr$(iAscii)
End Select
Else
sEscapedUri = sEscapedUri & Chr$(iAscii)
End If
' Unreserved characters, never escape
' RFC 3986 section 2.3 Unreserved Characters (January 2005)
' - . 0 ... 9 A ... Z a .... z _ ~
Case 45, 46, 48 To 57, 65 To 90, 97 To 122, 95, 126
sEscapedUri = sEscapedUri & Chr$(iAscii)
' Unsafe characters, always escape
' " % < > \ ^ ` { | }
Case 34, 37, 60, 62, 92, 94, 96, 123, 124, 125
sEscapedUri = sEscapedUri & "%" & Hex$(iAscii)
' Space, escaped
Case 32
sEscapedUri = sEscapedUri & "%20"
Case Else
sEscapedUri = sEscapedUri & "%" & Hex$(iAscii)
End Select
Next i
EscapeURI = sEscapedUri
End Function
Public Function EscapeURIData(ByVal URIData As String, Optional ByVal JSCompatible As Boolean = False) As String
' As per "RFC 1738: Uniform Resource Locators (URL) specification"
' 21-06-2010: Modified to conform to "RFC 3986: Uniform Resource Identifier (URI): Generic Syntax"
Dim i As Long
Dim bAnsi() As Byte
Dim iAscii As Integer
Dim sEscapedData As String
bAnsi = StrConv2(URIData, VbStrConv2.vbUTF8)
sEscapedData = vbNullString
For i = LBound(bAnsi) To UBound(bAnsi)
iAscii = bAnsi(i)
Select Case iAscii
' ASCII control caracters, always escape
Case 0 To 31, 127
If iAscii < 16 Then
sEscapedData = sEscapedData & "%0" & Hex$(iAscii)
Else
sEscapedData = sEscapedData & "%" & Hex$(iAscii)
End If
' Non-ASCII characters, always escape
Case 128 To 255
sEscapedData = sEscapedData & "%" & Hex$(iAscii)
' Reserved characters, always escape when treated as data
' RFC 3986 section 2.2 Reserved Characters (January 2005)
' ! # $ & ' ( ) * + , / : ; = ? # [ ]
Case 33, 35, 36, 38, 39, 40, 41, 42, 43, 44, 47, 58, 59, 61, 63, 64, 91, 93
If JSCompatible Then
Select Case iAscii
' ! ' ( ) *
Case 33, 39, 40, 41, 42
' ECMAScript's encodeURIComponent() doesn't escape those
sEscapedData = sEscapedData & Chr$(iAscii)
Case Else
sEscapedData = sEscapedData & "%" & Hex$(iAscii)
End Select
Else
sEscapedData = sEscapedData & "%" & Hex$(iAscii)
End If
' Unreserved characters, never escape
' RFC 3986 section 2.3 Unreserved Characters (January 2005)
' - . 0 ... 9 A ... Z a .... z _ ~
Case 45, 46, 48 To 57, 65 To 90, 97 To 122, 95, 126
sEscapedData = sEscapedData & Chr$(iAscii)
' Unsafe characters, always escape
' " % < > \ ^ ` { | }
Case 34, 37, 60, 62, 92, 94, 96, 123, 124, 125
sEscapedData = sEscapedData & "%" & Hex$(iAscii)
' Space, escaped
Case 32
sEscapedData = sEscapedData & "%20"
Case Else
sEscapedData = sEscapedData & "%" & Hex$(iAscii)
End Select
Next i
EscapeURIData = sEscapedData
End Function
'
' Utilities
'
Private Function StrConv2(Expr As Variant, Conversion As VbStrConv2, Optional LocaleID As Long = 0)
Const METHOD_NAME = "StrConv2"
Dim sExpr As String, arr_bytInput() As Byte, lLBound As Long
Select Case Conversion
Case VbStrConv2.vbUTF8 ' LocaleID not used (no case changing, no code page mapping)
Dim lInputChars As Long
Dim lOutputBytes As Long, arr_bytOutputBytes() As Byte
' Expected input: Unicode (UCS-2)
Select Case VarType(Expr)
Case vbString
sExpr = CStr(Expr)
' Get length of input, in *characters*
lInputChars = Len(sExpr)
' Copy input string as-is
arr_bytInput = sExpr
Case (vbArray + vbByte)
' Get length of input, in *characters*
lInputChars = (UBound(Expr) - LBound(Expr) + 1) \ 2
' Copy array (same type)
arr_bytInput = Expr
Case Else
Err.Raise 13, METHOD_NAME, "Expr: Type mismatch (in " & METHOD_NAME & "())"
End Select
' Get size of output strings, in *bytes*
lOutputBytes = WideCharToMultiByte(CP_UTF8, 0, VarPtr(arr_bytInput(0)), lInputChars, 0, 0, 0, 0)
' Size appropriately
ReDim arr_bytOutputBytes(lOutputBytes - 1)
' Second call
lOutputBytes = WideCharToMultiByte(CP_UTF8, 0, VarPtr(arr_bytInput(0)), lInputChars, VarPtr(arr_bytOutputBytes(0)), lOutputBytes, 0, 0)
' Return as array of bytes
StrConv2 = arr_bytOutputBytes
Case VbStrConv2.vbFromUTF8 ' LocaleID not used (no case changing, no code page mapping)
Dim lInputBytes As Long
Dim lOutputChars As Long, arr_bytOutputChars() As Byte
' Expected input: UTF-8
Select Case VarType(Expr)
Case vbString
arr_bytInput = StrConv(Expr, vbFromUnicode)
' Get length of input, in *bytes*
lInputBytes = (UBound(arr_bytInput) - LBound(arr_bytInput) + 1)
Case (vbArray + vbByte)
' Copy array (same type)
arr_bytInput = Expr
' Get length of input, in *bytes*
lInputBytes = (UBound(arr_bytInput) - LBound(arr_bytInput) + 1)
Case Else
Err.Raise 13, METHOD_NAME, "Expr: Type mismatch (in " & METHOD_NAME & "())"
End Select
' Get size of output strings, in *chars*
lOutputChars = MultiByteToWideChar(CP_UTF8, 0, VarPtr(arr_bytInput(0)), lInputBytes, 0, 0)
' Size appropriately
ReDim arr_bytOutputChars(lOutputChars * 2 - 1)
' Second call
lOutputChars = MultiByteToWideChar(CP_UTF8, 0, VarPtr(arr_bytInput(0)), lInputBytes, VarPtr(arr_bytOutputChars(0)), lOutputChars)
' Return as string
sExpr = arr_bytOutputChars
StrConv2 = Left$(sExpr, lOutputChars)
Case Else
StrConv2 = StrConv(Expr, Conversion, LocaleID)
End Select
End Function
I have a system that is generating a text file that contains an unknown amount of data. I have two separate chunks of code one for Payment and one for Distribution. I know I will have at least one Payment and one Distribution (Payment has 23 fields with varying widths and Distribution has 12 fields).
Payment Field lengths are: {10, 1, 10, 8, 1, 20, 13, 1, 8, 8, 8, 40, 40, 40, 40, 40, 25, 2, 9, 40, 10, 20, 6}
Distribution Field lengths are: {10, 1, 10, 20, 40, 13, 1, 40, 40, 10, 1, 14}
The payment field is 400 characters and then the Distribution field is 200 characters. I can have one distribution field or many distribution fields as well as payment fields, but the payment fields do not go in order.
Example of the Payment structure [DO NOT REMOVE SPACES] I need to maintain the structure just in case there is a value there:
00000041285111 20140106EDA0000-001 0000010636317+201401012014010320140106 Some Tax Company Non testing agency service TEST GROUP INC 11#####23
Example of the Distribution structure [DO NOT REMOVE SPACES] I need to maintain the structure just in case there is a value there:
00000041286111 DA0000-005 0000000016731+ 666111 98552
I need to be able to parse through the first Payment gather all of the values in the fixed length, and somehow switch the length of fields to be the distribution fields until I get all of those, and switch it back if it goes back to a Payment.
Here is the code that I have:
Using MyReader As New Microsoft.VisualBasic.FileIO.
TextFieldParser("C:\COM_20140103_173912.txt")
'This field parser gives me the first 400characters with not problems
MyReader.TextFieldType =
Microsoft.VisualBasic.FileIO.FieldType.FixedWidth
MyReader.FieldWidths = {10, 1, 10, 8, 1, 20, 13, 1, 8, 8, 8, 40, 40, 40, 40, 40, 25, 2, 9, 40, 10, 20, 6}
Dim currentRow As String()
While Not MyReader.EndOfData
Try
currentRow = MyReader.ReadFields()
Dim currentField As String
For Each currentField In currentRow
MsgBox(currentField)
Next
Catch ex As Microsoft.VisualBasic.FileIO.MalformedLineException
MsgBox("Line " & ex.Message &
"is not valid and will be skipped.")
End Try
End While
End Using
I got this code from http://msdn.microsoft.com/en-us/library/microsoft.visualbasic.fileio.textfieldparser.fieldwidths.aspx
I have done research and I can't figure out how to manipulate this to do what I need it to do. Any help would be appreciated. I hope I gave enough information, and if you need me to explain it differently I can.
Thanks,
John
Here's one idea. The TextFielParser constructor can also take a stream as its parameter. Use a regular StreamReader to read the file line by line and then use a StringReader with the TextFieldParser to process each line based on it's length. Something like the following (untested):
Imports Microsoft.VisualBasic.FileIO
Imports System.IO
Sub Main
Using rdr As New StreamReader("C:\COM_20140103_173912.txt")
Dim currentLine As String = rdr.ReadLine()
While currrentLine IsNot Nothing
Dim currentRow As String()
If currentLine.Length = 400 Then
currentRow = processDistributionRow(currentLine)
Else
currentRow = processPaymentRow(currentLine)
End If
If currentRow IsNot Nothing Then
'Process current set of fields
End If
currentLine = rdr.ReadLine()
End While
End Using
End Sub
'This method uses a TextFieldParser to process a single line of a file that is passed in
Private Function processDistributionRow(currentLine As String)
Dim result As String()
Using strStream As New StringStream(currentLine)
Using MyReader As New TextFieldParser(strStream)
MyReader.TextFieldType = FieldType.FixedWidth
MyReader.FieldWidths = {10, 1, 10, 8, 1, 20, 13, 1, 8, 8, 8, 40, 40, 40, 40, 40, 25, 2, 9, 40, 10, 20, 6}
Try
result = MyReader.ReadFields()
Dim currentField As String
Catch ex As Microsoft.VisualBasic.FileIO.MalformedLineException
MsgBox("Line " & ex.Message & "is not valid and will be skipped.")
End Try
End Using
End Using
return result
End Function
'This method uses a TextFieldParser to process a single line of a file that is passed in
Private Function processPaymentRow(currentLine As String)
Dim result As String()
Using strStream As New StringStream(currentLine)
Using MyReader As New TextFieldParser(strStream)
MyReader.TextFieldType = FieldType.FixedWidth
MyReader.FieldWidths = {?, ?, ?} 'Set proper field widths for the payment row here
Try
result = MyReader.ReadFields()
Dim currentField As String
Catch ex As Microsoft.VisualBasic.FileIO.MalformedLineException
MsgBox("Line " & ex.Message & "is not valid and will be skipped.")
End Try
End Using
End Using
return result
End Function
' Define other methods and classes here