Friday, March 30, 2012

Generate Unique SIN Numbers

'********************Automation Script Template**************
' Script     : Generate SIN Numbers
' Description   : Generates unique sin numbers from the number of sins you required
' Developed By  : Baba Fakruddin Dudekula
' Development Started On : 28-Mar-2012
' Development Ended On  : 29-Mar-2012
' Input :  Number of SINs you required, TempSin
'*********************************************************
Dim SinsCount, TempSin
SinsCount = Inputbox("Enter the number of SIN's you want", "SINs required count", 1)
TempSin = InputBox("Do you want Temp Sin? Temp SIN starts with 9. (Yes or No)","SIN Type(Temp or Permanent)", "No")

Call Generate_Unique_SIN(SinsCount, TempSin)

Function Generate_Unique_SIN(SinsCount, TempSin)
    Dim allSins(), sins, SIN_ID, i, j, k, l, m, var1, cnt, bln_Flag, add5, verfi(), add1(), add2,     add3, adds, add4, chk_dgt, SINID, objDict, oldArray, val, newArray, xl, cnt_sin, fso
    For sins = 1 to SinsCount
        If UCase(Trim(TempSin)) = UCase(Trim("No")) Then
            Randomize
            SINID = Int((899999999 - 100000000 + 1) * Rnd + 100000000)
        Else
            Randomize
            SINID = Int((999999999 - 900000000 + 1) * Rnd + 900000000)
        End If

        var1 = Cdbl(left((Cstr(SINID)), 8))
        
        cnt = 0
        For i = 2 to Len(var1)
            If (i mod 2) = 0 Then
                ReDim Preserve verfi(cnt)
                verfi(cnt) = Cint(Mid(var1, i, 1))
                cnt = cnt+1
            End If
        Next
      
        For j = 0 to Ubound(verfi)
            ReDim Preserve add1(j)
            add1(j) = Cint(verfi(j)) + Cint(verfi(j))
        Next
      
        add3 = 0
        add2 = 0
        For k = 0 to Ubound(add1)
            If len(Cint(add1(k)))>1 Then
                adds = 0
                For l = 0 to len(Cint(add1(k)))-1
                    adds = adds+Cint(Mid(add1(k), l+1, 1))
                Next
                add2 = adds
            ElseIf len(add1(k)) = 1 Then
                add2 = Cint(add1(k))
            End If
            add3 = add3 + add2
        Next
      
        add4 = 0
        For m = 1 to Len(var1) Step 2
            add4 = add4 + Cint(Mid(var1, m, 1))
        Next
      
        add5 = Cint(add3) + Cint(add4)
      
        chk_dgt = False
        bln_Flag = False
        If (add5 Mod 10) = 0 Then
            If Right(SINID, 1) = 0 Then
                bln_Flag = True
            Else
                bln_Flag = False
                chk_dgt = True
            End If
        End If
      
        If Not bln_Flag Then
            If chk_dgt Then
                SIN_ID = Cstr(var1) & 0
            Else
                chk_dgt = 10 - Cdbl(Right(add5, 1))
                SIN_ID = Cstr(var1) & Cstr(chk_dgt)
            End If
        End If
        
'        print "Actual SIN Number is : "& Cdbl(SIN_ID)
        ReDim Preserve allSins(sins-1)
        allSins(sins-1) = Cdbl(SIN_ID)
    Next
   
    Set xl = CreateObject("Excel.application")
    xl.Visible = true
    xl.Workbooks.Add
  
    xl.ActiveSheet.select
  
    xl.Cells(1,1).value = "SIN_Numbers"
  
    For cnt_sin = 0 to Ubound(allSins)
        xl.Cells(cnt_sin+2, 1) = allSins(cnt_sin)
    Next
  
    ''*  Find the unique SIN's
    xl.Cells(1, 2).value = "Unique_SINs"
    oldArray = allSins
  
    Set objDict = CreateObject("Scripting.Dictionary")
    objDict.CompareMode = vbTextCompare
  
    For each val in oldArray
        objDict(val) = val
    Next
  
    newArray = objDict.Items
    i = 0
    For i = 0 to ubound(newArray)
        xl.Cells(i+2, 2) = newArray(i)
    Next
  
    Set fso = CreateObject("Scripting.FileSystemObject")
  
    If fso.FolderExists("C:\SIN_Numbers") Then
        xl.ActiveWorkbook.SaveAs "C:\SIN_Numbers\SIN_Numbers_"& Replace(Replace(Replace(Now, "/", "_"), ":", "-"), " ", "-") &".xls"
    Else
        fso.CreateFolder("C:\SIN_Numbers")
        Wait 1
        xl.ActiveWorkbook.SaveAs "C:\SIN_Numbers\SIN_Numbers_"& Replace(Replace(Replace(Now, "/", "_"), ":", "-"), " ", "-") &".xls"
    End If
  
    xl.Quit
  
    Set fso = Nothing
    Set xl = Nothing
    Set objDict = Nothing
End Function

No comments:

There was an error in this gadget