HIMSISFO

Himpunan Mahasiswa Sistem Informasi Universitas Mercubuana


    VB Code Bank : String Manipulation

    Share
    avatar
    Alen1.1
    Super Administrator
    Super Administrator

    Male Jumlah posting : 82
    Age : 28
    Fakultas : Fasilkom
    Jurusan : sistem informasi
    Interest in : Visual Basic,xna,C#
    Registration date : 07.01.09

    VB Code Bank : String Manipulation

    Post by Alen1.1 on Sat Jan 17, 2009 3:33 am

    String Manipulation 1


    1. How to Remove unwanted characters from a string

      Code:
      'This code removes unwanted characters from a string.
      Function PurgeString(OldStr As String) As String
          Dim NewStr As String
          Dim l As Long
          For l = 1 To Len(OldStr)
            If Asc(Mid(OldStr, l, 1)) > 31 Then
                NewStr = NewStr & Mid(OldStr, l, 1)
            End If
          Next
          PurgeString = NewStr
      End Function




    2. How to Test if a character is Alpha Numeric

      Code:
      Public Function IsAlphaCharacter(ByVal sChar As String) As Boolean
          'Returns true if the input letter is alphabetical in any code page or language.
          IsAlphaCharacter = (Not (UCase$(sChar) = LCase$(sChar))) Or (sChar = " ")
      End Function




    3. How to convert Numbers to words i.e., 44 = fourty four

      Code:
      Option Explicit

      'Return a string of words to represent the integer part of this value.
      Public Function NumbersToWords(ByVal num As Currency) As String
          Dim power_value(1 To 5) As Currency
          Dim power_name(1 To 5) As String
          Dim digits As Integer
          Dim result As String
          Dim i As Integer
          ' Initialize the power names and values.
          power_name(1) = "trillion": power_value(1) = 1000000000000#
          power_name(2) = "billion": power_value(2) = 1000000000
          power_name(3) = "million": power_value(3) = 1000000
          power_name(4) = "thousand": power_value(4) = 1000
          power_name(5) = "": power_value(5) = 1
          For i = 1 To 5
              ' See if we have digits in this range.
              If num >= power_value(i) Then
                  ' Get the digits.
                  digits = Int(num / power_value(i))
                  ' Add the digits to the result.
                  If Len(result) > 0 Then result = result & ", "
                  result = result & Words_1_999(digits) & " " & power_name(i)
                  ' Get the number without these digits.
                  num = num - digits * power_value(i)
              End If
          Next i
          NumbersToWords = Trim$(result)
      End Function

      ' Return words for this value between 1 and 999.
      Public Function Words_1_999(ByVal num As Integer) As String
          Dim hundreds As Integer
          Dim remainder As Integer
          Dim result As String
          hundreds = num \ 100
          remainder = num - hundreds * 100
          If hundreds > 0 Then
              result = Words_1_19(hundreds) & " hundred "
          End If
          If remainder > 0 Then
              result = result & Words_1_99(remainder)
          End If
          Words_1_999 = Trim$(result)
      End Function

      ' Return a word for this value between 1 and 19.
      Public Function Words_1_19(ByVal num As Integer) As String
          Select Case num
          Case 1
              Words_1_19 = "one"
          Case 2
              Words_1_19 = "two"
          Case 3
              Words_1_19 = "three"
          Case 4
              Words_1_19 = "four"
          Case 5
              Words_1_19 = "five"
          Case 6
              Words_1_19 = "six"
          Case 7
              Words_1_19 = "seven"
          Case 8
              Words_1_19 = "eight"
          Case 9
              Words_1_19 = "nine"
          Case 10
              Words_1_19 = "ten"
          Case 11
              Words_1_19 = "eleven"
          Case 12
              Words_1_19 = "twelve"
          Case 13
              Words_1_19 = "thirteen"
          Case 14
              Words_1_19 = "fourteen"
          Case 15
              Words_1_19 = "fifteen"
          Case 16
              Words_1_19 = "sixteen"
          Case 17
              Words_1_19 = "seventeen"
          Case 18
              Words_1_19 = "eightteen"
          Case 19
              Words_1_19 = "nineteen"
          End Select
      End Function

      ' Return a word for this value between 1 and 99.
      Public Function Words_1_99(ByVal num As Integer) As String
          Dim result As String
          Dim tens As Integer
          tens = num \ 10
          If tens <= 1 Then
              ' 1 <= num <= 19
              result = result & " " & Words_1_19(num)
          Else
              ' 20 <= num
              ' Get the tens digit word.
              Select Case tens
              Case 2
                  result = "twenty"
              Case 3
                  result = "thirty"
              Case 4
                  result = "forty"
              Case 5
                  result = "fifty"
              Case 6
                  result = "sixty"
              Case 7
                  result = "seventy"
              Case 8
                  result = "eighty"
              Case 9
                  result = "ninety"
              End Select
              ' Add the ones digit number.
              result = result & " " & Words_1_19(num - tens * 10)
          End If
          Words_1_99 = Trim$(result)
      End Function




    4. How to count the number of occurrences of a substring inside another string

      Code:
      Function InstrCount(Source As String, Search As String) As Long
          ' You get the number of substrings by subtracting the length of the
          ' original string from the length of the string that you obtain by
          ' replacing the substring with another string that is one char longer.
          InstrCount = Len(Replace(Source, Search, Search & "*")) - Len(Source)
      End Function




    5. How to replace only the LAST occurrence of a substring

      Code:
      Function ReplaceLast(Source As String, Search As String, ReplaceStr As String) As String
          ReplaceLast = StrReverse(Replace(StrReverse(Source), StrReverse(Search), _
              StrReverse(ReplaceStr), , 1))
      End Function




    6. How to use Replace function for VB5

      Code:
      'If you are using VB5 and need Replace function that's available only in VB6,
      'here is my version of it. Please let me know what you think.

      Function fnReplace(ByVal InWhat As String, What As String, WithWhat As String) As String
          Dim Pos As Long
          Pos = InStr(InWhat, What)
          While Pos
              fnReplace = fnReplace & Left(InWhat, Pos - 1) & WithWhat
              InWhat = Right(InWhat, Len(InWhat) - Pos - Len(What) + 1)
              Pos = InStr(InWhat, What)
          Wend
          fnReplace = fnReplace & InWhat
      End Function




    7. How to Scramble Word - Guaranteed different every time

      Code:
      Public Function ScrambleWord(Word)
          Randomize
          Length = Len(Word)
          ReDim Letter(Length)
          For I = 1 To Length 5
              RndSlot = Int(Rnd * Length) + 1
              If RndSlot = Length + 1 Or Letter(RndSlot) <> "" Then
                  GoTo 5
              Else
                  Letter(RndSlot) = Mid$(Word, I, 1)
              End If
          Next I
          For I = 1 To Length
              Scrambled = Scrambled & Letter(I)
          Next I
          ScrambleWord = Scrambled
      End Function




    8. How to return a substring between two delimiters in a string

      Code:
      'A simple parse function which returns in an array all words between two delimiters.

      'if you have a string like strText="this is 'a test ' in order to'test'
      'the function syntaxe'll be
      'rs=Delimiter(strText,"'","'") if you want to get everything between the "'"

      Dim rs() As String

      Private Sub Form_Load()
          Dim I As Integer
          Dim strText As String
          strText = "this is 'a test ' in order to'test'"
          rs = Delimiter(strText, "'", "'")
          For I = LBound(rs) To UBound(rs)
              Debug.Print rs(I)
          Next I
      End Sub

      Private Function Delimiter(ByVal texte As String, ByVal delimiter1 As String, ByVal delimiter2 As String) As Variant
          Dim interne() As String
          Dim cpt As Integer
          Dim Flag1 As Boolean
          Dim flag2 As Boolean

          ReDim Preserve interne(1)    'initialisation  du tableau à 1

          qte = 1    'le premier composant du tableau en sortie aura l'index 1
          Do While cpt < Len(texte)
              cpt = cpt + 1
              If Mid$(texte, cpt, 1) = delimiter1 And Not Flag1 Then
                  Flag1 = True
                  GoTo lenext
              End If
              If Mid$(texte, cpt, 1) = delimiter2 And Flag1 = True Then
                  Flag1 = False
                  flag2 = True
                  qte = qte + 1
                  ReDim Preserve interne(qte + 1)
                  GoTo lenext
              End If

              If Flag1 Then interne(qte) = interne(qte) & Mid$(texte, cpt, 1)

      lenext:
          Loop
          Delimiter = interne
      End Function




    9. How To Capitalize The First Character Of Each Word In A String/Phrase

      Code:
      'Example Usage:
      'Dim strTest As String
      'strTest = "microsoft access 97"
      '
      'MakeInitialCaps strTest
      'Debug.Print strTest  'Displays: "Microsoft Access 97"

      Public Function MakeInitialCaps(ByRef strArg As String)
          Const strSpace As String = " "
          Dim ID As Long
          'Remove Leading and Trailing Spaces
          strArg = Trim$(strArg)
          'Capitalize first letter in String
          strArg = UCase(Left(strArg, 1)) & Mid(strArg, 2)
          'Loop through string looking for spaces and
          'Capitalizing the next Character
          ID = 1 'Set index into string
          Do
              ID = InStr(ID, strArg, strSpace, _
                        vbBinaryCompare)
              If ID > 0 Then
                  strArg = Left$(strArg, ID) & UCase$(Left$(Right$(strArg, Len(strArg) - ID), 1)) & Mid$(strArg, ID + 2)
                  ID = ID + 1
              Else
                  Exit Do
              End If
          Loop
      End Function




    10. How to Convert Dollar Amounts into Words

      Code:
      Option Explicit

      Dim Arr1 As Variant
      Dim Arr10 As Variant

      ' Code good for 0 to 99999.99
      Private Sub GetWords(Amt As Currency)
          Dim d1 As Long
          Dim d10 As Long
          Dim d100 As Long
          Dim d1000 As Long
          Dim c1 As Long
          Dim c10 As Long
          Dim Words As String
          Dim Amount As Double
          Dim tmpAmt As Double
          ' Dollar Processing
          Amount = Amt
          d1000 = Int(Amount / 1000): Amount = Amount - (d1000 * 1000)
          d100 = Int(Amount / 100): Amount = Amount - CDbl(d100 * 100)
          d10 = Int(Amount / 10): Amount = Amount - CDbl(d10 * 10)
          d1 = Int(Amount): Amount = Amount - d1
          ' Cents Processing
          Amount = Amount * 100
          c10 = Int(Amount / 10): Amount = Amount - (c10 * 10)
          c1 = Int(Amount): Amount = Amount - c1
          Words = ""
          ' Dollars Words Processing
          If d1000 > 19 Then
              Amount = d1000
              Words = Words & Arr10(Int(d1000 / 10)): Amount = (d1000 Mod 10)
              If Amount > 0 Then Words = Words & " " & Arr1(Amount)
              Words = Words & " Thousand "
          Else
              If d1000 > 0 Then Words = Words & Arr1(d1000) & " Thousand "
          End If
          Words = Words & GetHundreds(d100)
          'If d100 > 0 Then Words = Words & Arr1(d100) & " Hundred "
          Words = Words & GetTens(d1, d10, " Dollars")
          ' Cents Words Processing
          Words = Words & " and " & GetTens(c1, c10, " Cents")
          MsgBox Words
          Text1.Text = ""
      End Sub

      Function GetTens(iones As Long, itens As Long, stype As String) As String
          Dim ones, tens As Integer
          ones = iones
          tens = itens
          If ones > 0 And tens = 1 Then
              GetTens = GetTens & Arr1(ones + (tens * 10)) & " "
              ones = 0
          Else
              GetTens = GetTens & Arr10(tens) & " "
          End If
          If ones > 0 Then
              GetTens = GetTens & Arr1(ones) & stype
          Else
              GetTens = "Zero" & stype
          End If
      End Function

      Function GetHundreds(iHundreds As Long) As String
          If iHundreds > 0 Then GetHundreds = Arr1(iHundreds) & " Hundred "
      End Function

      Private Sub Command1_Click()
          GetWords CCur(Val(Text1.Text))
      End Sub

      Private Sub Form_Load()
          Arr1 = Array("", "One", "Two", "Three", "Four", "Five", "Six", "Seven", "Eight", "Nine", _
                      "Ten", "Eleven", "Twelve", "Thirteen", "Fourteen", "Fifteen", "Sixteen", _
                      "Seventeen", "Eighteen", "Ninteen")
          Arr10 = Array("", "Ten", "Twenty", "Thirty", "Fourty", "Fifty", "Sixty", "Seventy", "Eighty", "Ninety")
      End Sub
    avatar
    Alen1.1
    Super Administrator
    Super Administrator

    Male Jumlah posting : 82
    Age : 28
    Fakultas : Fasilkom
    Jurusan : sistem informasi
    Interest in : Visual Basic,xna,C#
    Registration date : 07.01.09

    Re: VB Code Bank : String Manipulation

    Post by Alen1.1 on Sat Jan 17, 2009 3:35 am

    String Manipulation 2


    1. How To Capitalize The First Character Of Each Word In A String/Phrase

      Code:
      'Example Usage:
      'Dim strTest As String
      'strTest = "microsoft access 97"
      '
      'MakeInitialCaps strTest
      'Debug.Print strTest  'Displays: "Microsoft Access 97"

      Public Function MakeInitialCaps(ByRef strArg As String)
          Const strSpace As String = " "
          Dim ID As Long
          'Remove Leading and Trailing Spaces
          strArg = Trim$(strArg)
          'Capitalize first letter in String
          strArg = UCase(Left(strArg, 1)) & Mid(strArg, 2)
          'Loop through string looking for spaces and
          'Capitalizing the next Character
          ID = 1 'Set index into string
          Do
              ID = InStr(ID, strArg, strSpace, _
                        vbBinaryCompare)
              If ID > 0 Then
                  strArg = Left$(strArg, ID) & UCase$(Left$(Right$(strArg, Len(strArg) - ID), 1)) & Mid$(strArg, ID + 2)
                  ID = ID + 1
              Else
                  Exit Do
              End If
          Loop
      End Function




    2. How to count number of words in a given string

      Code:
      'How to create a list of each word, and how many times it appears in the source string.

      Option Explicit

      Public Function WORD_COUNT(ByVal StringToCount As String) As String
          Dim WordsToCount As Variant
          Dim intIndex As Integer
          Dim ScanCount As Integer
          Dim CurrentWord As String
          Dim WordCount As Integer
          Dim FinishedText As String
          WordCount = 0
          WordsToCount = Split(StringToCount, Chr(32))

          Debug.Print "Total No. of words: " & UBound(WordsToCount) - LBound(WordsToCount)

          For intIndex = 0 To UBound(WordsToCount)
              CurrentWord = WordsToCount(intIndex)
              WordCount = 1
              For ScanCount = 0 To UBound(WordsToCount)
                  If ScanCount <> intIndex Then
                      If WordsToCount(ScanCount) = CurrentWord Then
                          WordCount = WordCount + 1
                      End If
                  End If
              Next
              If InStrRev(FinishedText, CurrentWord & "(" & WordCount & ")") = 0 Then
                  FinishedText = FinishedText & CurrentWord & "(" & WordCount & ")" & vbCrLf
              End If
          Next
          WORD_COUNT = FinishedText
      End Function




    3. How to make Sentence Case

      Code:
      Public Function MakeSentenceCase(ByVal strString As String) As String
          Dim strText() As String
          Dim strTemp As String
          Dim I As Integer
          strText = Split(strString)
          For I = 0 To UBound(strText)
              If I = 0 Then
                  strTemp = strTemp & StrConv(strText(0), vbProperCase)
              ElseIf Right$(strText(I - 1), 1) Like "[.!?]" Then
                  strTemp = strTemp & StrConv(strText(I), vbProperCase)
              Else
                  strTemp = strTemp & StrConv(strText(I), vbLowerCase)
              End If
              strTemp = strTemp & Space$(1)
          Next I
          MakeSentenceCase = strTemp
      End Function
      'How to call this function:
      'MSgBox MakeSentenceCase("thIs is A TesT. JUSt a tESt.")
      'You will get: This is a test. Just a test.

      'Another way:

      Private Function SentenceCase(ByVal sText As String)
          Dim b() As Byte, N As Long, bChange As Boolean
          b = sText
          bChange = True
          For N = 0 To UBound(b) Step 2
              Select Case b(N)
                  Case 33, 46, 58, 63  ' !.:?
                      bChange = True
                  Case 97 To 122 ' a-z
                      If bChange Then b(N) = b(N) - 32: bChange = False
                  Case 32
                  Case Else
                      bChange = False
              End Select
          Next N
          SentenceCase = b
      End Function

      'How to call this function:
      'MSgBox SentenceCase("thIs is A TesT. JUSt a tESt.")
      'You will get: ThIs is A TesT. JUSt a tESt.




    4. How to find the next word in a sub string

      Code:
      Public Function FindNextWord(ByRef sText As String, ByRef sFind As String) As String
          Dim sWord() As String
          Dim lX As Long

          sWord = Split(sText, " ")
          For lX = 0 To UBound(sWord)
              If sWord(lX) = sFind Then
                  If lX < UBound(sWord) Then
                      FindNextWord = sWord(lX + 1)
                      Exit For
                  End If
              End If
          Next
      End Function




    5. First Name, Last Name swaping in a string - Example

      Code:
      Public Function StringManipulation(ByVal strFileName As String) As String
          Dim strTemp() As String
          Dim strFinal As String
          Dim intCount As Integer
          Dim intLastWordPos As Integer
          Dim intLastWordLength As Integer
          Dim strLastWord As String

          Debug.Print strFileName
          strFileName = Replace(strFileName, ".zip", "")
          strTemp = Split(strFileName)

          For intCount = LBound(strTemp) To UBound(strTemp)
              If Right$(strFinal, 1) = "," Then
                  intLastWordPos = InStrRev(strFinal, " ")
                  intLastWordLength = Len(strFinal) - intLastWordPos
                  strLastWord = Mid$(strFinal, intLastWordPos + 1, intLastWordLength - 1)
                  strFinal = Left$(strFinal, intLastWordPos)
                  strFinal = Trim$(strFinal & strTemp(intCount)) & " " & strLastWord
              Else
                  strFinal = Trim$(strFinal & " " & strTemp(intCount))
              End If
          Next intCount
          strFinal = strFinal & ".zip"
          StringManipulation = strFinal
          Debug.Print strFinal
      End Function
      'How can I call this function:
      'MsgBox StringManipulation("ka1000-10 - killers, the - song, the.zip")
      'MsgBox StringManipulation("ka1000-10 - bon jovi & killers, the - song, the.zip")
      'MsgBox StringManipulation("ka1000-10 - jovi, bon & killers, the - song, the.zip")




    6. How to Check whether the given string has only numbers

      Code:
      Public Function isTypeNumberWithChar(ByVal strTestString As String) As Boolean
          Dim intCount As Integer
          isTypeNumberWithChar = True
          For intCount = 1 To Len(strTestString)
              If Not IsNumeric(Mid$(strTestString, intCount, 1)) Then Exit Function
          Next intCount
          isTypeNumberWithChar = False
      End Function

      'How can I call this function:
      'Debug.Print isTypeNumberWithChar("06040031")
      'Debug.Print isTypeNumberWithChar("0604d0031")




    7. How to Replace a string on first line of a text box

      Code:
      Private Sub Command1_Click()
          Dim lPos As Long
          lPos = InStr(Text1.Text, vbCrLf)
          If lPos = 0 Then lPos = Len(Text1.Text) + 1
          Text1.Text = Replace(Left$(Text1.Text, lPos - 1), "a", "b") & Mid$(Text1.Text, lPos)
      End Sub




    8. How to delete a string in another comma delimited string

      Code:
      Public Function DeleteElement(ByVal strtext As String, strDelimiter As String, _
          Optional ByVal intRemoveElementNo As Integer = 0)
          Dim strFinalText As String
          Dim strElements() As String
          Dim I As Integer

          strElements = Split(strtext, strDelimiter)

          For I = LBound(strElements) To UBound(strElements)
              If Not I = intRemoveElementNo Then
                  If Not I = UBound(strElements) Then
                      strFinalText = strFinalText & strElements(I) & strDelimiter
                  Else
                      strFinalText = strFinalText & strElements(I)
                  End If
              End If
          Next I

          DeleteElement = strFinalText
          'Debug.Print DeleteElement
      End Function
      'How to call this procedure:
      'msgbox DeleteElement ("1, 12, 55, 5,4" , ",", 0)




    9. How to replace a character in middle of the string

      Code:
      Sub ReplaceCharacterInMiddle()
          Dim strTestString As String
          strTestString = "Progromming"
          Mid$(strTestString, 6, 1) = "a"
          Debug.Print strTestString
      End Sub




    10. How to count the number of spaces in a string

      Code:
      ' NOTE: this function might not work with non-Latin alphabets.
      Function CountSpaces(Text As String) As Long
          Dim b() As Byte, I As Long
          b() = Text
          For I = 0 To UBound(b) Step 2
              ' Consider only even-numbered items.
              ' Save time and code using the function name as a local variable.
              If b(I) = 32 Then CountSpaces = CountSpaces + 1
          Next
      End Function

      Waktu sekarang Sun Jul 22, 2018 4:23 am