HIMSISFO

Would you like to react to this message? Create an account in a few clicks or log in to continue.
HIMSISFO

Himpunan Mahasiswa Sistem Informasi Universitas Mercubuana


    VB6 Code Bank: Coding Basics, Arrays, Collections, Lists

    Alen1.1
    Alen1.1
    Alen1.1
    Super Administrator
    Super Administrator


    Male Jumlah posting : 82
    Age : 34
    Fakultas : Fasilkom
    Jurusan : sistem informasi
    Interest in : Visual Basic,xna,C#
    Registration date : 07.01.09
    • Post n°1

    VB6 Code Bank: Coding Basics, Arrays, Collections, Lists Empty VB6 Code Bank: Coding Basics, Arrays, Collections, Lists

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

    Coding Basics


    1. How to use more than one condition in Select case statement

      Code:
      Sub Main()
      Select Case True
      Case Combo1.ListIndex = 0 And List1.ListIndex = 0
          MsgBox "combo listindex = 0 and list.listindex=0"
      Case Combo1.ListIndex = 0 And List1.ListIndex = 1
          MsgBox "combo listindex = 0 and list.listindex=1"
      Case Combo1.ListIndex = 0 And List1.ListIndex = 2
          MsgBox "combo listindex = 0 and list.listindex=2"
      Case Else
          MsgBox "none of the previous"
      End Select
      End Sub



    2. Sendkeys example

      Code:
      Private Sub Command1_Click()
          Dim i As Integer
          Dim retval As Double
          retval = Shell("notepad", vbNormalFocus)
          AppActivate retval
          For i = 0 To 1000
              SendKeys i & " ", True
          Next i
      End Sub



    3. How to find the number of a name, used in a numerology program

      Code:
      Public Function NameNum(namelen, name) As Long
          name2 = LCase(name)
          For letter = 1 To namelen
              Name4 = Mid(name2, letter, 1)
              Debug.Print Name4
              Select Case Name4
              Case "a"
                  Number = Number + 1
              Case "b"
                  Number = Number + 2
              Case "c"
                  Number = Number + 3
              Case "d"
                  Number = Number + 4
              Case "e"
                  Number = Number + 5
              Case "f"
                  Number = Number + 6
              Case "g"
                  Number = Number + 7
              Case "h"
                  Number = Number + 8
              Case "i"
                  Number = Number + 9
              Case "j"
                  Number = Number + 1
              Case "k"
                  Number = Number + 2
              Case "l"
                  Number = Number + 3
              Case "m"
                  Number = Number + 4
              Case "n"
                  Number = Number + 5
              Case "o"
                  Number = Number + 6
              Case "p"
                  Number = Number + 7
              Case "q"
                  Number = Number + 8
              Case "r"
                  Number = Number + 9
              Case "s"
                  Number = Number + 1
              Case "t"
                  Number = Number + 2
              Case "u"
                  Number = Number + 3
              Case "v"
                  Number = Number + 4
              Case "w"
                  Number = Number + 5
              Case "x"
                  Number = Number + 6
              Case "y"
                  Number = Number + 7
              Case "z"
                  Number = Number + 8
              Case " "
                  Number = Number + 0
              End Select
          Next letter
          Debug.Print Number
          Nu = Val(Number)
          Do
              Nu = Val(Mid(CVar(Nu), 1, 1)) + Val(Mid(CVar(Nu), 2, 1))
              Debug.Print Nu
          Loop Until Nu < 10
          NameNum = Nu
      End Function



    4. How to Convert Binary to Decimal

      Code:
      Public Function BinToDec(value As String) As Long
          Dim result As Long, i As Integer, exponent As Integer
          For i = Len(value) To 1 Step -1
              Select Case Asc(Mid$(value, i, 1))
                  Case 48      ' "0", do nothing.
                  Case 49      ' "1", add the corresponding power of 2.
                      result = result + Power2(exponent)
                  Case Else
                      Err.Raise 5  ' Invalid procedure call or argument
              End Select
              exponent = exponent + 1
          Next
          BinToDec = result
      End Function



    5. How to Convert Binary to Octal

      Code:
      Public Function ConvertBinaryToOctal(BinVal As String) As String
          Dim i%, Length%

          Select Case (Len(BinVal) Mod 3)
          Case 1:
              BinVal = "00" + BinVal
          Case 2:
              BinVal = "0" + BinVal
          End Select
          Length = Len(BinVal)

          For i = Length - 2 To 1 Step -3
              ConvertBinaryToOctal = GetValue(Mid(BinVal, i, 3), False) + ConvertBinaryToOctal
          Next i
      End Function

      Private Function GetValue(strBinary As String, blnRemainder As Boolean) As String
          Dim intPwrOfTwo As Integer
          Dim intResult As Integer
          intResult = 0
          intPwrOfTwo = -1
          For i = Len(strBinary) To 1 Step -1
              intPwrOfTwo = intPwrOfTwo + 1
              strChar = Mid(strBinary, i, 1)
              If strChar = "1" Then
                  intResult = intResult + 2 ^ intPwrOfTwo
              End If
          Next
          GetValue = LTrim(Str(intResult))
      End Function



    6. How to Convert Decimal to Hexadecimal

      Code:
      Public Function ConvertDecimalToHexadecimal(Value As Double) As String
          Dim iVal#, temp#, ret%, i%, Str$
          Dim BinVal$()
          iVal = Value
          Do
              temp = iVal / 16
              ret = InStr(temp, ".")
              If ret > 0 Then
                  temp = Left(temp, ret - 1)
              End If
              ret = iVal Mod 16
              ReDim Preserve BinVal(i)
              BinVal(i) = NoToHex(ret)
              i = i + 1
              iVal = temp
          Loop While temp > 0
          For i = UBound(BinVal) To 0 Step -1
              Str = Str + CStr(BinVal(i))
          Next
          ConvertDecimalToHexadecimal = Str
      End Function

      Private Function NoToHex(i As Integer) As String
          Select Case i
          Case 0 To 9
              NoToHex = CStr(i)
          Case 10:
              NoToHex = "A"
          Case 11:
              NoToHex = "B"
          Case 12:
              NoToHex = "C"
          Case 13:
              NoToHex = "D"
          Case 14:
              NoToHex = "E"
          Case 15:
              NoToHex = "F"
          End Select
      End Function



    7. How to Convert from decimal to binary

      Code:
      Function Bin(ByVal value As Long) As String
          Dim result As String, exponent As Integer
          ' This is faster than creating the string by appending chars.
          result = String$(32, "0")
          Do
              If value And Power2(exponent) Then
                  ' We found a bit that is set, clear it.
                  Mid$(result, 32 - exponent, 1) = "1"
                  value = value Xor Power2(exponent)
              End If
              exponent = exponent + 1
          Loop While value
          Bin = Mid$(result, 33 - exponent)  ' Drop leading zeros.
      End Function



    8. How to find a given year is leap year or not

      Code:
      Function IsLeapYear(year As Integer) As Boolean
          ' Are February 29 and March 1 different dates?
          IsLeapYear = DateSerial(year, 2, 29) <> DateSerial(year, 3, 1)
      End Function



    9. How to generate random numbers, with the info

      Code:
      '1) How many values - txtValue
      '2) What the max is - txtMax
      '3) What the min is - txtMin
      '4) If they want duplicate random numbers, or not
      '        - OptionBoxes
      '        - Option1 = Double
      '        - Option2 = No Double

      Option Explicit

      Dim HowMany As Integer
      Dim RndNum As Integer
      Dim Answer As String
      Dim I As Integer
      Dim Search As Integer

      Private Sub cmdGenerate_Click()
          On Error GoTo Problem
          Randomize
          ReDim Ans(TxtValue)
          If Option1.Value = True And TxtMax - TxtMin < TxtValue Then
              MsgBox "It is impossible to generate that amount of random numbers without doubles."
              Exit Sub
          End If
          Answer = ""
          For HowMany = 1 To TxtValue 5
              RndNum = Int(Rnd * TxtMax) + TxtMin
              If RndNum > TxtMax Then GoTo 5
              If Option2.Value = True Then
                  Ans(HowMany) = RndNum
              Else
                  For Search = 1 To HowMany
                      If RndNum = Ans(Search) Then GoTo 5
                  Next Search
                  Ans(HowMany) = RndNum
              End If
          Next HowMany
          For I = 1 To TxtValue
              Answer = Answer & Ans(I)
              If I <> TxtValue Then Answer = Answer & ", "
          Next I
          MsgBox Answer
          Exit Sub

      Problem:
          MsgBox Err.Description
      End Sub



    10. How to converte color value(longint) into RGB value

      Code:
      Public Function rgbcolortovalue(rslt As Long) As String
          Dim tmphasil1 As Byte
          Dim tmphasil2 As Byte
          Dim tmphasil1a As Byte
          Dim tmphasil1b As Byte
          Dim tmphasil1c As Long
          If rslt < 256 Then
              rgbcolortovalue = Trim(Format(rslt, "0##")) + ",000,000"
          ElseIf (rslt > 256) And (rslt < 65536) Then
              tmphasil1 = rslt Mod 256
              tmphasil2 = Int(rslt / 256)
              rgbcolortovalue = Trim(Format(tmphasil1, "0##")) + "," + Trim(Format(tmphasil2, "0##")) + ",000"
          ElseIf rslt > 65535 Then
              tmphasil2 = Int(rslt / 65536)
              tmphasil1c = rslt Mod 65536
              If tmphasil1c < 256 Then
                  rgbcolortovalue = Trim(Format(tmphasil1c, "0##")) + ",000," + Trim(Format(tmphasil2, "0##"))
              Else
                  tmphasil1a = tmphasil1c Mod 256
                  tmphasil1b = Int(tmphasil1c / 256)
                  rgbcolortovalue = Trim(Format(tmphasil1a, "0##")) + "," + Trim(Format(tmphasil1b, "0##")) + "," + _
                      Trim(Format(tmphasil2, "0##"))
              End If
          End If
      End Function



    11. How to accept any number of arguments in a function

      You can implement a routine that accepts any number of arguments using the ParamArray keyword

      Code:
      Function Sum(ParamArray args() As Variant) As Double
          Dim I As Integer
          ' All ParamArrays are zero-based.
          For I = 0 To UBound(args)
              Sum = Sum + args(I)
          Next
      End Function



    12. How to Convert text into the Currency data type

      Code:
      Option Explicit

      ' Convert any value into currency format. If the value does not make sense, return 0.00.
      Public Function cvCur(ByVal Value As Variant) As Currency
          On Error Resume Next
          cvCur = CCur(Value)
          If Err.Number <> 0 Then cvCur = 0
      End Function

      Private Sub cmdConvert_Click()
          lblCurrency.Caption = Format$(cvCur(txtCurrency.Text), "Currency")
      End Sub



    13. How to Convert Hexadecimal to Decimal

      Code:
      Public Function ConvertHexadecimalToDecimal(BinVal As String) As String
          Dim iVal#, temp#, i%, Length%

          Length = Len(BinVal)
          For i = 0 To Length - 1
              temp = HexToNo(Mid(BinVal, Length - i, 1))
              iVal = iVal + (temp * (16 ^ i))
          Next i
          ConvertHexadecimalToDecimal = iVal
      End Function

      Private Function HexToNo(i As String) As Integer
          Select Case i
              Case "0", "1", "2", "3", "4", "5", "6", "7", "8", "9":
                  HexToNo = CInt(i)
              Case "A", "a":
                  HexToNo = 10
              Case "B", "b":
                  HexToNo = 11
              Case "C", "c":
                  HexToNo = 12
              Case "D", "d":
                  HexToNo = 13
              Case "E", "e":
                  HexToNo = 14
              Case "F", "f":
                  HexToNo = 15
          End Select
      End Function



    14. How to use InputBox function and get values

      Code:
       Dim sInput As String
          sInput = InputBox("Test Title", "InputBox", "Some text here")
          If StrPtr(sInput) = 0 Then
              MsgBox "Cancel was pressed"
          Else
              If Len(sInput) = 0 Then
                  MsgBox "OK pressed but nothing entered."
              Else
                  MsgBox "OK pressed: value= " & sInput
              End If
          End If



    15. How to use Like() function

      Code:
      'Like() function used for Pattern-Matching in Code
      Dim strTest  As String

      strTest = "@ciSmith v. Barney, 21 A2d 459, 35 ME2d 256 (1985)@ec"

      'The following comparisons will result in True or False results as indicated:
      Result = strTest Like "*F2d*" '(Result would be False)
      Result = strTest Like "*A2d*" '(Result would be True)
      Result = strTest Like "@ci*@ec" '(Result would be True)

      'One glitch is that It doesn't recognized "[0-9]@" whereas it will recognize
      'particular occurrences of the character class.  "[0-9][0-9][0-9]"



    16. How to convert Octal to Decimal number

      Code:
      Public Function ConvertOctalToDecimal(BinVal As String) As String
          Dim iVal#, temp#, i%, Length%
          Length = Len(BinVal)
          For i = 0 To Length - 1
              temp = CInt(Mid$(BinVal, Length - i, 1))
              iVal = iVal + (temp * (8 ^ i))
          Next i
          ConvertOctalToDecimal = iVal
      End Function



    17. How to copy/cut the content of the text box to the clipboard

      Code:
      Sub cmdCopy_Click()
          Clipboard.SetText Text1.SelText 'Copies only selected text
          'Clipboard.SetText Text1.Text 'Copies whole TextBox content
      End Sub

      Private Sub cmdCut_Click()
          Clipboard.SetText Text1.SelText
          Text1.SelText = ""
      End Sub



    18. What exactly does ByVal and ByRef mean and when do you use it?

      Code:
      'ByVal means to pass just the Value of a Variable, where as
      'ByRef means to pass a Reference to the Variable itself.

      'For Example,

      Function AddOne(ByVal iNum As Integer) As Integer
          iNum = iNum + 1
          AddOne = iNum
      End Function

      Sub Main()
          Dim I As Integer
          I = 1
          Debug.Print AddOne(I)
          Debug.Print I
      End Sub

      'This would Print 2, then 1 as only the Value 1 is passed to
      'the Function so the value of I never actually changes.

      Function AddOne(ByRef iNum As Integer) As Integer
          iNum = iNum + 1
          AddOne = iNum
      End Function

      Sub Main()
          Dim I As Integer
          I = 1
          Debug.Print AddOne(I)
          Debug.Print I
      End Sub

      'This would Print 2, then 2 again as a Refernce to the Actual
      'Variable was passed, so changing iNum was like Changing I itself.

      'If ByVal/ByRef isn't specified, default is ByRef



    19. How to display a message in two lines in MSG Box

      Code:
      Call MsgBox("This is First line." & vbCrLf & "This is Second line.")



    20. How to Check whether the user pressed the Cancel Button on Input Box

      Code:
      Private Sub Command1_Click()
          Dim str As String
          str = InputBox("Press OK or Cancel")
          If StrPtr(str) = 0 Then
            MsgBox "The user pressed the Cancel button"
          End If
      End Sub
    • Kembali Ke Atas
    Alen1.1
    Alen1.1
    Alen1.1
    Super Administrator
    Super Administrator


    Male Jumlah posting : 82
    Age : 34
    Fakultas : Fasilkom
    Jurusan : sistem informasi
    Interest in : Visual Basic,xna,C#
    Registration date : 07.01.09
    • Post n°2

    VB6 Code Bank: Coding Basics, Arrays, Collections, Lists Empty Re: VB6 Code Bank: Coding Basics, Arrays, Collections, Lists

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

    Arrays, Collections, Lists


    1. How to eliminate Duplicates in an Array (assumes prior sort)

      Code:
      OldSelection = ExtractionArray(1) 'This assumes option Base 1
      For i = 2 To UBound(ExtractionArray())
          If ExtractionArray(i) = OldSelection Then
              ExtractionArray(i) = ""
              GoTo LOOP_NEXT
          Else
              OldSelection = ExtractionArray(i)
              GoTo LOOP_NEXT
          End If
      LOOP_NEXT:
      Next I



    2. How to Erase an Array -- removes all of its elements

      Code:
      Erase MyArray()



    3. How to resize an array without losing its contents

      Code:
      'use the ReDim Preserve command:

      ReDim Preserve Customers(2000) As String

      'when you're using ReDim Preserve on a multidimensional array, you can
      'resize only its last dimension:

      ReDim Cells(1 To 100, 10) As Integer

      ReDim Preserve Cells(1 To 100, 20) As Integer    ' This works.
      ReDim Preserve Cells(1 To 200, 20) As Integer    ' This doesn't.



    4. How to evaluate the total number of elements in a two dimensional array

      Code:
      Debug.Print LBound(Cells, 1)  ' Displays 1, lower index of 1st dimension
      Debug.Print LBound(Cells)      ' Same as above
      Debug.Print UBound(Cells, 2)  ' Displays 20, upper index of 2nd dimension
      ' Evaluate total number of elements.
      NumEls = (UBound(Cells) - LBound(Cells) + 1) * (UBound(Cells, 2) - LBound(Cells, 2) + 1)



    5. How to sum all the elements in an array

      Code:
      ' A polymorphic function that sums the values in any array
      Function ArraySum(arr As Variant) As Variant
          Dim I As Long, result As Variant
          For I = LBound(arr) To UBound(arr)
              result = result + arr(I)
          Next
          ArraySum = result
      End Function



    6. How to find out the number of dimensions of the given array

      Code:
      'This routine returns the number of dimensions of the array passed as
      'an argument, or 0 if it isn't an array.
      Function NumberOfDims(arr As Variant) As Integer
          Dim dummy As Long
          On Error Resume Next
          Do
              dummy = UBound(arr, NumberOfDims + 1)
              If Err Then Exit Do
              NumberOfDims = NumberOfDims + 1
          Loop
      End Function



    7. How to sum all the elements in an two dimensional array

      Code:
      Function ArraySum2(arr As Variant) As Variant
          Dim I As Long, j As Long, result As Variant
          ' First check whether we can really work with this array.
          Select Case NumberOfDims(arr)
          Case 1      ' One-dimensional array
              For I = LBound(arr) To UBound(arr)
                  result = result + arr(I)
              Next
          Case 2      ' Two-dimensional array
              For I = LBound(arr) To UBound(arr)
                  For j = LBound(arr, 2) To UBound(arr, 2)
                      result = result + arr(I, j)
                  Next
              Next
          Case Else  ' Not an array, or too many dimensions
              Err.Raise 1001, , "Not an array or more than two dimensions"
          End Select
          ArraySum2 = result
      End Function



    8. How to store all the selected items in a ListBox in an array

      Code:
      ' Returns an array with all the selected items in a ListBox
      Function SelectedListItems(lst As ListBox) As String()
          Dim I As Long, j As Long
          ReDim result(0 To lst.SelCount) As String
          For I = 0 To lst.ListCount - 1
              If lst.Selected(I) Then
                  j = j + 1
                  result(j) = lst.List(I)
              End If
          Next
          SelectedListItems = result
      End Function



    9. How to insert an item in an array

      Code:
      Sub InsertArrayItem(arr As Variant, index As Long, newValue As Variant)
          Dim I As Long
          For I = UBound(arr) - 1 To index Step -1
              arr(I + 1) = arr(I)
          Next
          arr(index) = newValue
      End Sub

      'Or (Using API)

      Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, _
          source As Any, ByVal numBytes As Long)

      Sub InsertArrayItemLong(arr() As Long, index As Long, newValue As Long)
          ' We let VB evaluate the size of each item using LenB().
          If index < UBound(arr) Then
              CopyMemory arr(index + 1), arr(index), (UBound(arr) - index) * LenB(arr(index))
          End If
          arr(index) = newValue
      End Sub



    10. How to delete an item in an array

      Code:
      Sub DeleteArrayItem(arr As Variant, index As Long)
          Dim I As Long
          For I = index To UBound(arr) - 1
              arr(I) = arr(I + 1)
          Next
          ' VB will convert this to 0 or to an empty string.
          arr(UBound(arr)) = Empty
      End Sub

      'Or (Using API)

      Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, _
          source As Any, ByVal numBytes As Long)

      Sub DeleteArrayItemLong(arr() As Long, index As Long)
          If index < UBound(arr) Then
              CopyMemory arr(index), arr(index + 1), (UBound(arr) - index) * LenB(arr(index))
          End If
          arr(index) = Empty
      End Sub



    11. How to check whether an item exists in a collection

      Code:
      'If you pass a numeric index that's either negative or greater than the number
      'of items currently in the collection, you get an error code 9-"Subscript out
      'of range" (exactly as if you were acting on a standard array); if you pass a
      'nonexistent string key, you get error code 5-"Invalid procedure call or
      'argument."

      Function ItemExists(col As Collection, Key As String) As Boolean
          Dim dummy As Variant
          On Error Resume Next
          dummy = col.Item(Key)
          ItemExists = (Err <> 5)
      End Function



    12. How to find out the number of items in the collection

      Code:
      ' Retrieve the last item in the EmployeeNames collection.
      ' Note that collections are one-based.
      Debug.Print EmployeeNames.Item(EmployeeNames.count)



    13. How to remove items from a Collection object

      Code:
      'You can remove items from a Collection object using the Remove method;
      'this method accepts either a numeric index or a string key:

      ' Remove the Marketing Boss.
      EmployeeNames.Remove "Marketing"

      'If the key doesn't exist, the Collection object raises an error 5-"Invalid
      'procedure call or argument."



    14. How to remove all the items in a collection

      Code:
      'collections don't offer a native way to remove all the items in a single
      'operation, so you're forced to write a loop. Here's a general function
      'that does it for you:

      Sub RemoveAllItems(col As Collection)
          Do While col.count
              col.Remove 1
          Loop
      End Sub

      'A faster way to remove all the items in a Collection is to destroy the
      'Collection object itself by setting it to Nothing or to another fresh,
      'new instance:
      'Both these lines destroy the current contents of the Collection.
      Set EmployeeNames = Nothing
      Set EmployeeNames = New Collection

      'This approach works only if there isn't any other object variable pointing
      'to the Collection object, however.



    15. How to replace an item in a collection

      Code:
      'Collections don't allow you to modify the value of an item. If you want to
      'change the value of an item, you must first delete it and then add a new item.
      'Here's generic routine that uses this technique:

      ' INDEX can be either a numeric or a string value.
      Sub ReplaceItem(col As Collection, index As Variant, newValue As Variant)
          ' First remove that item (exits with error if it doesn't exist).
          col.Remove index
          ' Then add it again.
          If VarType(index) = vbString Then
              ' Add a new item with the same string key.
              col.Add newValue, index
          Else
              ' Add a new item in the same position (without any key).
              col.Add newValue, , index
          End If
      End Sub



    16. How to sort data and remove duplicates

      Code:
      'It uses quicksort to sort the data and then scans through the results
      'adding non-duplicated values to a result array.

      Public Function RemoveDups(strings() As String) As String()
          Dim old_i As Integer
          Dim last_i As Integer
          Dim result() As String

          ' Make the result array.
          ReDim result(1 To UBound(strings))

          ' Copy the first item into the result array.
          result(1) = strings(1)

          ' Copy the other items
          last_i = 1
          For old_i = 2 To UBound(strings)
              If result(last_i) <> strings(old_i) Then
                  last_i = last_i + 1
                  result(last_i) = strings(old_i)
              End If
          Next old_i

          ' Remove unused entries from the result array.
          ReDim Preserve result(1 To last_i)

          ' Return the result array.
          RemoveDups = result
      End Function



    17. How to Scramble the order of elements in an array

      Code:
      Public Sub ShuffleArray(ByRef vArray As Variant, Optional startIndex As Variant, _
          Optional endIndex As Variant)
          Dim I As Long
          Dim rndIndex As Long
          Dim Temp As Variant

          If IsMissing(startIndex) Then
              startIndex = LBound(vArray)
          End If

          If IsMissing(endIndex) Then
              endIndex = UBound(vArray)
          End If

          For I = startIndex To endIndex
              rndIndex = Int((endIndex - startIndex + 1) * Rnd() + startIndex)
              Temp = vArray(I)
              vArray(I) = vArray(rndIndex)
              vArray(rndIndex) = Temp
          Next I
      End Sub
    • Kembali Ke Atas
      Waktu sekarang Thu Nov 21, 2024 5:58 am