home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 5_2007-2008.ISO / data / Zips / Removing_d20310711152006.psc / Form1.frm < prev    next >
Text File  |  2006-11-15  |  8KB  |  231 lines
  1. VERSION 5.00
  2. Begin VB.Form Form1 
  3.    BorderStyle     =   1  'Fixed Single
  4.    Caption         =   "Removing duplicates from an unsorted string array"
  5.    ClientHeight    =   1860
  6.    ClientLeft      =   45
  7.    ClientTop       =   435
  8.    ClientWidth     =   4470
  9.    LinkTopic       =   "Form1"
  10.    MaxButton       =   0   'False
  11.    MinButton       =   0   'False
  12.    ScaleHeight     =   1860
  13.    ScaleWidth      =   4470
  14.    StartUpPosition =   1  'CenterOwner
  15.    Begin VB.TextBox Text1 
  16.       BeginProperty Font 
  17.          Name            =   "Tahoma"
  18.          Size            =   8.25
  19.          Charset         =   0
  20.          Weight          =   400
  21.          Underline       =   0   'False
  22.          Italic          =   0   'False
  23.          Strikethrough   =   0   'False
  24.       EndProperty
  25.       Height          =   1455
  26.       Left            =   0
  27.       Locked          =   -1  'True
  28.       MultiLine       =   -1  'True
  29.       TabIndex        =   0
  30.       Top             =   0
  31.       Width           =   4455
  32.    End
  33.    Begin VB.Label Label1 
  34.       Caption         =   "Copyright ⌐ 2006 by Olof Larsson (kalebeck@hotmail.com)"
  35.       BeginProperty Font 
  36.          Name            =   "Tahoma"
  37.          Size            =   8.25
  38.          Charset         =   0
  39.          Weight          =   400
  40.          Underline       =   0   'False
  41.          Italic          =   0   'False
  42.          Strikethrough   =   0   'False
  43.       EndProperty
  44.       Height          =   255
  45.       Left            =   120
  46.       TabIndex        =   1
  47.       Top             =   1560
  48.       Width           =   4455
  49.    End
  50. End
  51. Attribute VB_Name = "Form1"
  52. Attribute VB_GlobalNameSpace = False
  53. Attribute VB_Creatable = False
  54. Attribute VB_PredeclaredId = True
  55. Attribute VB_Exposed = False
  56. Option Explicit
  57.  
  58. Private Declare Function GetTickCount Lib "kernel32" () As Long 'used to measure the speed, not essential for the code to work
  59.  
  60. Private Sub Form_Load()
  61.  
  62.     '------------------------------------
  63.     '
  64.     '   This project is made by Olof Larsson
  65.     '   ⌐ 2006, kalebeck@hotmail.com
  66.     '
  67.     '   This code contains two different functions which both do the same thing,
  68.     '   but in two very different ways. It more or less demonstrates the power
  69.     '   of using a collection to detect and remove duplicates from an unsorted
  70.     '   string array. But regardless of that fact I decided to include both of the
  71.     '   algorithms, the first one which uses a collection to remove duplicates
  72.     '   from the array. And the second one which uses only the original array and
  73.     '   not any additional memory. The major difference between these two algorithms
  74.     '   doesn't become obvious until you process an array with tens of thousand of
  75.     '   entries. You can edit these functions to support any type of array that
  76.     '   you see fit.
  77.     '
  78.     '   Enjoy!
  79.     '
  80.     '------------------------------------
  81.     
  82.     
  83.     '-----------------------------
  84.     ' The following code demonstrates on how to create your array and populate it using a file
  85.     ' You can of course use any other normal way to populate the array with strings
  86.     '
  87.     ' This code will load a file with 182,193 entries and remove the duplicates, it will
  88.     ' also measure how fast this process is completed on your computer
  89.     '-----------------------------
  90.     
  91.     
  92.     '-----------------------------
  93.     ' Opens the file muff.txt in the application directory and uses it
  94.     ' to populate the array to demonstrate how the code works
  95.  
  96.     Dim ho() As String, g As Long, tim As Long
  97.     ReDim ho(0) As String
  98.     
  99.     Open App.Path & "\muff.txt" For Input As #1
  100.     Dim a As String, total As Long
  101.     Do Until EOF(1)
  102.         Line Input #1, a
  103.         If a <> vbNullString Then
  104.             If g >= UBound(ho) Then
  105.                 ReDim Preserve ho(UBound(ho) + 20000) As String
  106.             End If
  107.             total = total + 1
  108.             ho(g) = a
  109.             g = g + 1
  110.         End If
  111.     Loop
  112.     Close #1
  113.     ReDim Preserve ho(total) As String
  114.     
  115.     g = GetTickCount 'measures the speed of the process
  116.     
  117.     '-------------------------
  118.     ' This is where the function is called that does the trick
  119.     '-------------------------
  120.     ndiusCOL ho 'Uses a collection to remove duplicates
  121.     '-------------------------
  122.     '-------------------------
  123.     'ndius ho 'Uses only the original array to remove duplicates, inferior in speed
  124.     '-------------------------
  125.    
  126.     Text1.Text = total - UBound(ho) - 1 & " duplicates removed in " & Round((GetTickCount - g) / 1000, 10) & " seconds" & vbCrLf & vbCrLf & "Items left in the array: " & (UBound(ho) + 1) & vbCrLf & "Original size: " & total
  127.     
  128.     '-----------------------------
  129.     ' Prints the contents of your array to the file output.txt in the
  130.     ' application directory, after the duplicates have been removed
  131.     
  132.     Open App.Path & "\output.txt" For Output As #1
  133.     For g = 0 To UBound(ho)
  134.         Print #1, ho(g)
  135.     Next g
  136.     Close #1
  137.    
  138.  
  139. End Sub
  140.  
  141. Private Function ndiusCOL(ByRef arr() As String) As String
  142.  
  143.     'pros:    very high processing speed regardless of arraysize
  144.     '
  145.     'cons:    may use a lot of memory to check large arrays with hundreds of thousands of entries
  146.     '         or more where there are few duplicates.
  147.     '
  148.     'comment: i recommend you to use this function if you do not have very specific needs in
  149.     '         memory management.
  150.     
  151.     Dim h As Collection
  152.     Set h = New Collection
  153.     
  154.     Dim g As Long
  155.     Dim arru As Long
  156.     Dim remcount As Long
  157.     Dim colcount As Long
  158.     
  159.     arru = UBound(arr)
  160.     
  161.     For g = 0 To arru
  162.         On Error Resume Next
  163.         h.Add arr(g), arr(g)
  164.         arr(g) = vbNullString
  165.         If Err.Number <> 0 Then remcount = remcount + 1
  166.     Next g
  167.     
  168.     g = 0
  169.     colcount = h.Count
  170.     Do Until colcount = 0
  171.         arr(g) = h.Item(1)
  172.         h.Remove (1)
  173.         colcount = colcount - 1
  174.         g = g + 1
  175.     Loop
  176.     
  177.     ReDim Preserve arr(arru - remcount) As String
  178.     
  179. End Function
  180.  
  181. Private Function ndius(ByRef arr() As String) As String
  182.  
  183.     'pros:    works very good on small arrays with a few thousand items or less, doesn't take any
  184.     '         additional memory to process and remove duplicates from an array
  185.     '
  186.     'cons:    will take forever if you have a large array to check
  187.     '
  188.     'comment: you may find other functions that seemingly do the same thing with a shorter code, but
  189.     '         when you examine them closely you will find that these functions 99% of the time moves
  190.     '         the entries to a new array thereby using up unnecessary memory. this functions only
  191.     '         uses the original array. it assumes that you have a string array and that you do not
  192.     '         have or want to keep any pure vbNullString entries in your array. you can change this
  193.     '         to a different character or a string if you so wish.
  194.     
  195.     Dim arru As Long
  196.     Dim arrl As Long
  197.     Dim g As Long
  198.     Dim g2 As Long
  199.     Dim remcount As Long
  200.     Dim stepback As Boolean
  201.     
  202.     arru = UBound(arr)
  203.     arrl = LBound(arr)
  204.     
  205.     For g = arrl To arru
  206.         For g2 = (g + 1) To arru
  207.             If arr(g) = arr(g2) Then
  208.                 arr(g2) = vbNullString
  209.                 remcount = remcount + 1
  210.             End If
  211.         Next g2
  212.     Next g
  213.     remcount = 0
  214.     
  215.     For g = arrl To arru
  216.         If g + remcount > arru Then Exit For
  217.         If stepback = True Then g = g - 1: stepback = False
  218.         If arr(g) = vbNullString Then
  219.             remcount = remcount + 1
  220.             For g2 = g To arru - 1
  221.                 arr(g2) = arr(g2 + 1)
  222.                 If arr(g2 + 1) = vbNullString Then stepback = True
  223.                 arr(g2 + 1) = vbNullString
  224.             Next g2
  225.         End If
  226.     Next g
  227.     
  228.     ReDim Preserve arr(arru - remcount) As String
  229.     
  230. End Function
  231.