home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 4_2005-2006.ISO / data / Zips / Sorting_ar197714312006.psc / Form1.frm < prev    next >
Text File  |  2006-03-01  |  5KB  |  146 lines
  1. VERSION 5.00
  2. Begin VB.Form Form1 
  3.    BorderStyle     =   1  'Fixed Single
  4.    Caption         =   "Sort array & remove duplicates v1.1"
  5.    ClientHeight    =   3150
  6.    ClientLeft      =   45
  7.    ClientTop       =   435
  8.    ClientWidth     =   4815
  9.    LinkTopic       =   "Form1"
  10.    MaxButton       =   0   'False
  11.    ScaleHeight     =   3150
  12.    ScaleWidth      =   4815
  13.    StartUpPosition =   3  'Windows Default
  14.    Begin VB.TextBox Text1 
  15.       Height          =   1335
  16.       Left            =   120
  17.       Locked          =   -1  'True
  18.       MultiLine       =   -1  'True
  19.       ScrollBars      =   3  'Both
  20.       TabIndex        =   1
  21.       Top             =   1440
  22.       Width           =   4575
  23.    End
  24.    Begin VB.ListBox List1 
  25.       BackColor       =   &H8000000F&
  26.       Height          =   1230
  27.       Left            =   120
  28.       TabIndex        =   0
  29.       Top             =   120
  30.       Width           =   4575
  31.    End
  32.    Begin VB.Label Label1 
  33.       Caption         =   "Written by Olof Larsson (kalebeck@hotmail.com)"
  34.       Height          =   255
  35.       Left            =   120
  36.       TabIndex        =   2
  37.       Top             =   2880
  38.       Width           =   4455
  39.    End
  40. End
  41. Attribute VB_Name = "Form1"
  42. Attribute VB_GlobalNameSpace = False
  43. Attribute VB_Creatable = False
  44. Attribute VB_PredeclaredId = True
  45. Attribute VB_Exposed = False
  46. Option Explicit
  47. Private Declare Function GetTickCount Lib "kernel32" () As Long 'used to measure the speed, not essential for the code to work
  48.  
  49. '------------------------------------
  50. '
  51. '   This project is made by Olof Larsson
  52. '   ⌐ 2006, kalebeck@hotmail.com
  53. '
  54. '   The sortingalgorithm is written by Philippe Lord // Marton
  55. '    Email:      StromgaldMarton@Hotmail.com
  56. '    ICQ:        12181387
  57. '
  58. '   TriQuickSortString ' Sorts the string array.  // when the distance gets below 5, which speeds things A LOT (over 40%).
  59. '
  60. '   The following code is a demonstration of how to remove duplicates
  61. '   from a string array as quickly as possible. The program first uses
  62. '   the very fast TriQuickSort algorithm to sort the array after it has
  63. '   been dimensioned and populated. Then it uses the remdups sub to remove
  64. '   any possible duplicates from the array. remdups assumes that you don't
  65. '   want any vbNullString in your array, if you would, then just replace
  66. '   vbNullString in the remdups sub with any other character, like Chr$(1),
  67. '   or whatever that floats your boat. This code can be used to remove
  68. '   duplicates from arrays that contains hundreds of thousands of entries,
  69. '   even millions. And it's very fast.
  70. '
  71. '   I hope you enjoy it!
  72. '
  73. '   Enjoy!
  74. '
  75. '------------------------------------
  76.  
  77. Private Sub Form_Load()
  78.  
  79.  
  80.     '-----------------------------
  81.     ' The following code demonstrates on how to create your array and populate it using a file
  82.     ' You can of course use any other normal way to populate the array with strings
  83.     '
  84.     ' This code will load a file with 182,193 entries and remove the duplicates, it will
  85.     ' also measure how fast this process is completed on your computer
  86.     '-----------------------------
  87.     
  88.     
  89.     '-----------------------------
  90.     ' Opens the file muff.txt in the application directory and uses it
  91.     ' to populate the array to demonstrate how the code works
  92.         
  93.     Dim ho() As String, g As Long, tim As Long
  94.     ReDim ho(0) As String
  95.     
  96.     Open App.Path & "\muff.txt" For Input As #1
  97.     Dim a As String, total As Long
  98.     Do Until EOF(1)
  99.         Line Input #1, a
  100.         If g >= UBound(ho) Then
  101.             ReDim Preserve ho(UBound(ho) + 20000) As String
  102.         End If
  103.         total = total + 1
  104.         ho(g) = a
  105.         g = g + 1
  106.     Loop
  107.     Close #1
  108.     ReDim Preserve ho(total) As String
  109.     
  110.     '-----------------------------
  111.  
  112.     g = GetTickCount 'measures the speed of the process
  113.     
  114.     '-----------------------------
  115.     ' This is what does the big job
  116.     
  117.     TriQuickSortString ho 'sorts your string array
  118.     remdups ho 'removes all duplicates
  119.     
  120.     '-----------------------------
  121.     
  122.     Text1.Text = total - UBound(ho) - 1 & " duplicates removed in " & Round((GetTickCount - g) / 1000, 3) & " seconds" & vbCrLf & vbCrLf & "Items left in the array: " & (UBound(ho) + 1) & vbCrLf & "Original size: " & total
  123.     
  124.     '-----------------------------
  125.     ' Prints the contents of your array to the listbox, after the duplicates have been removed
  126.     
  127.     'For g = 0 To UBound(ho)
  128.     '    List1.AddItem Chr$(34) & ho(g) & Chr$(34)
  129.     'Next g
  130.     
  131.     '-----------------------------
  132.     
  133.     '-----------------------------
  134.     ' Prints the contents of your array to the file output.txt in the
  135.     ' application directory, after the duplicates have been removed
  136.     
  137.     Open App.Path & "\output.txt" For Output As #1
  138.     For g = 0 To UBound(ho)
  139.         Print #1, ho(g)
  140.     Next g
  141.     Close #1
  142.     
  143.     '-----------------------------
  144.     
  145. End Sub
  146.