Listing dalam vb 6.0

Check For a File

Public Function FileExist(asPath as string) as Boolean
If UCase(Dir(asPath))=Ucase(trimPath(asPath)) then
FileExist=true
Else
FileExist=False
End If
End Function
Public Function TrimPath(ByVal asPath as string) as string
if Len(asPath)=0 then Exit Function
Dim x as integer
Do
x=Instr(asPath,”\”)
if x=0 then Exit Do
asPath=Right(asPath,Len(asPath)-x)
Loop
TrimPath=asPath
End Function
Private sub command1_Click()
if fileExist(Text1.text) then
Label1=”YES”
else
Label1=”NO”
End if
End Sub
Private sub form_Load()
End sub

Low and Upper Case

‘add 2 command buttons and 1 text
Private Sub Command1_Click()
    Text1.Text = CapFirst$(Text1.Text)
End Sub
Private Sub Command2_Click()
    Text1.Text = LCase$(Text1.Text)
End Sub
‘add 1 module
Declare Function CapFirst$ Lib “CAPFIRST.DLL” Alias “CAPFIRST” (ByVal St$)

Posted by Administrator at 07:11:50 | Permalink | No Comments »

Show Your IP Address

Add Microsoft Winsock Control 6.0 component
Insert 1 Textbox
Insert 2 Command Buttons Rename Caption as Display and Clear
Private Sub Command1_Click()
If Text1.Text = “” Then
    Command1.Enabled = False
    Text1.Text = Winsock1.LocalIP
Else
    Command1.Enabled = True
End If
End Sub
Private Sub Command2_Click()
Text1.Text = “”
If Text1.Text = “” Then
    Command1.Enabled = True
Else
    Command1.Enabled = False
End If
End Sub
Private Sub Form_Load()
Text1.Text = “”
If Text1.Text = “” Then
    Command1.Enabled = False
Else
    Command1.Enabled = True
End If
Text1.Text = Winsock1.LocalIP
End Sub

Permutasi

Option Explicit
Dim id As Integer
Dim N As Integer
Dim perm() As Integer
Function Engine(i As Integer)
   Dim t As Integer
   Dim j As Integer

   id = id + 1
   perm(i) = id
   If (id = N) Then stampaj
   For j = 1 To N
      If (perm(j) = 0) Then
         Engine (j)
      End If
   DoEvents
   Next j
   id = id - 1
   perm(i) = 0
End Function
Private Sub cmdClear_Click()
  List1.Clear
End Sub
Private Sub cmdGen_Click()
  If Val(txtLength.Text) > Len(txtChar.Text) Then
    MsgBox “Jumlah Permutasi Salah”
    Exit Sub
  End If

  If Len(txtChar.Text) = 0 Or (Val(txtLength.Text) = 0) Then Exit Sub

  Dim i As Integer
  N = Val(txtLength.Text)
  ReDim perm(N)
  For i = 1 To N
     perm(i) = 0
  Next i
  If ChSave.Value = 1 Then
     MsgBox “Disimpan pada hasil.txt”
     Open App.Path + “\hasil.txt” For Output As #1
  End If
  Engine 0
  If ChSave.Value = 1 Then Close #1

End Sub
Sub Form_Load()
   On Error Resume Next
   id = -1

End Sub
Sub stampaj()
   Dim i As Integer
   Dim result As String
   result = “”
   For i = 1 To N
      result = result & CStr(Mid$(txtChar.Text, perm(i), 1))
   Next i
   List1.AddItem result
   If ChSave.Value = 1 Then Print #1, result
End Sub

Posted by Administrator at 05:05:49 | Permalink | Comments (5)

Enkripsi Searah

Public Function Hash(ByVal text As String) As String
a = 1
For i = 1 To Len(text)
    a = Sqr(a * i * Asc(Mid(text, i, 1))) ‘Numeric Hash
Next i
Rnd (-1)
Randomize a ’seed PRNG
For i = 1 To 16
    Hash = Hash & Chr(Int(Rnd * 256))
Next i
End Function
Private Sub Form_Load()
  MsgBox Hash(“EmZ-2509″)    ‘Yang dihasilkan: ‰°’r¿¾ ©Ì¿ÂX*¤W
  End
End Sub

Enkripsi

Function EncDec(inData As Variant, Optional inPW As Variant = “”) As Variant
     On Error Resume Next
     Dim arrSBox(0 To 255) As Integer
     Dim arrPW(0 To 255) As Integer
     Dim Bi As Integer, Bj As Integer
     Dim mKey As Integer
     Dim i As Integer, j As Integer
     Dim x As Integer, y As Integer
     Dim mCode As Byte, mCodeSeries As Variant
 
     EncDec = “”
     If Trim(inData) = “” Then
         Exit Function
     End If
 
     If inPW <> “” Then
         j = 1
         For i = 0 To 255
             arrPW(i) = Asc(Mid$(inPW, j, 1))
             j = j + 1
             If j > Len(inPW) Then
                  j = 1
             End If
         Next i
     Else
         For i = 0 To 255
             arrPW(i) = 0
         Next i
     End If
  
     For i = 0 To 255
         arrSBox(i) = i
     Next i
  
     j = 0
     For i = 0 To 255
         j = (arrSBox(i) + arrPW(i)) Mod 256
         x = arrSBox(i)
         arrSBox(i) = arrSBox(j)
         arrSBox(j) = x
     Next i
  
     mCodeSeries = “”
     Bi = 0: Bj = 0
     For i = 1 To Len(inData)
         Bi = (Bi + 1) Mod 256
         Bj = (Bj + arrSBox(Bi)) Mod 256
         ‘ Tukar
         x = arrSBox(Bi)
         arrSBox(Bi) = arrSBox(Bj)
         arrSBox(Bj) = x
         ’siapkan kunci untuk XOR
         mKey = arrSBox((arrSBox(Bi) + arrSBox(Bj)) Mod 256)
         ‘gunakan operasi XOR
         mCode = Asc(Mid$(inData, i, 1)) Xor mKey
         mCodeSeries = mCodeSeries & Chr(mCode)
     Next i
     EncDec = mCodeSeries
End Function
Private Sub Form_Load()
  Dim Encrypt As String, Decrypt As String

  Encrypt = EncDec(“admin”, “win”)
  Decrypt = EncDec(“™D`­>”, “win”)
  MsgBox “Hasil enkripsi : ” & Encrypt & _
    vbCrLf & “Hasil dekripsi : ” & Decrypt
  End
End Sub

Menu Pop Up

Option Explicit
Private Declare Function SendMessage Lib “user32″ Alias _
   “SendMessageA” (ByVal hwnd As Long, ByVal wMsg As Long, _
    ByVal wParam As Long, lParam As Any) As Long
Private Const LB_GETITEMRECT = &H198
Private Const LB_ERR = (-1)
Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type
Public Function GetRClickedItem(MyList As Control, _
   X As Single, Y As Single) As Long
  ‘PURPOSE: Determine which item was right clicked in a list
  ‘box, from the list_box’s mouse down event.  YOU MUST CALL THIS
  ‘FROM THE MOUSEDOWN EVENT, PASSING THE X AND Y VALUES FROM THAT
  ‘EVENT TO THIS FUNCTION
    ‘MYLIST: ListBox Control
    ‘X, Y: X and Y position from MyList_MouseDown
    ‘RETURNS:  ListIndex of selected item, or -1 if
    ‘a) There is no selected item, or b) an error occurs.
    Dim clickX As Long, clickY As Long
    Dim lRet As Long
    Dim CurRect As RECT
    Dim l As Long
    ‘Control must be a listbox
    If Not TypeOf MyList Is ListBox Then
        GetRClickedItem = LB_ERR
        Exit Function
    End If
    ‘get x and y in pixels
    clickX = X Screen.TwipsPerPixelX
    clickY = Y Screen.TwipsPerPixelY
    ‘Check all items in the list to see if it was clicked on
    For l = 0 To MyList.ListCount - 1
      ‘get current selection as rectangle
      lRet = SendMessage(MyList.hwnd, LB_GETITEMRECT, l, CurRect)
      ‘If the position of the click is in the this list item
       ‘then that’s  our Item
     If (clickX >= CurRect.Left) And (clickX <= CurRect.Right) _
       And (clickY >= CurRect.Top) And _
          (clickY <= CurRect.Bottom) Then
            GetRClickedItem = l
            Exit Function
        End If
    Next l
End Function
Private Sub Form_Load()
  List1.AddItem “Merah”
  List1.AddItem “Kuning”
  List1.AddItem “Hijau”
  mnuPopUp.Visible = False
End Sub
Private Sub List1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim lItem As Long
If Button = vbRightButton Then
    lItem = GetRClickedItem(List1, X, Y)
                                      
        If lItem <> -1 Then
            List1.ListIndex = lItem
            PopupMenu mnuPopUp
        End If
End If
End Sub

Load Picture

Private Sub Command1_Click()
With Me.CommonDialog1
.DialogTitle = “Ambil Gambar”
.Filter = “JPEG|*.jpg”
.ShowOpen
If .FileName <> “” Then
Set Me.Picture1.Picture = Nothing
Me.Picture1.Picture = LoadPicture(.FileName)
End If
End With
End Sub
‘Private Sub Form_Load()
‘Me.Picture1.Picture = LoadPicture(“D:\gbr_motor\bikes_honda_01.jpg”)
‘End Sub

Sleep With Visual Basic

Option Explicit
Private Declare Sub Sleep Lib “kernel32″ (ByVal dwMilliseconds As Long)
Private Sub Form_Click()
   Me.Caption = “Sleeping”
   Call Sleep(20000)
   Me.Caption = “Awake”
End Sub
Private Sub Label1_Click()
   Me.Caption = “Sleeping”
   Call Sleep(20000)
   Me.Caption = “Awake”
End Sub

Find Something

Form
Option Explicit
Private Declare Function GetWindowText Lib “user32″ Alias “GetWindowTextA” (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Sub cmdActivate_Click()
   Dim nRet As Long
   Dim Title As String
   nRet = AppActivatePartial(Trim(txtTitle.Text), _
          Val(frmMethod.Tag), CBool(chkCase.Value))
   If nRet Then
      lblResults.Caption = “Found: &&H” & Hex$(nRet)
      Title = Space$(256)
      nRet = GetWindowText(nRet, Title, Len(Title))
      If nRet Then
         lblResults.Caption = lblResults.Caption & _
            “, “”" & Left$(Title, nRet) & “”"”
      End If
   Else
      lblResults.Caption = “Search Failed”
   End If
End Sub
Private Sub Form_Load()
   txtTitle.Text = “”
   lblResults.Caption = “”
   optMethod(0).Value = True
End Sub
Private Sub optMethod_Click(Index As Integer)
   frmMethod.Tag = Index
End Sub
Module
Option Explicit
Private Declare Function EnumWindows Lib “user32″ (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Private Declare Function GetClassName Lib “user32″ Alias “GetClassNameA” (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetWindowText Lib “user32″ Alias “GetWindowTextA” (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function IsIconic Lib “user32″ (ByVal hWnd As Long) As Long
Private Declare Function IsWindowVisible Lib “user32″ (ByVal hWnd As Long) As Long
Private Declare Function ShowWindow Lib “user32″ (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function SetForegroundWindow Lib “user32″ (ByVal hWnd As Long) As Long
Private Const SW_RESTORE = 9
Private m_hWnd As Long
Private m_Method As FindWindowPartialTypes
Private m_CaseSens As Boolean
Private m_Visible As Boolean
Private m_AppTitle As String
Public Enum FindWindowPartialTypes
   FwpStartsWith = 0
   FwpContains = 1
   FwpMatches = 2
End Enum
Public Function AppActivatePartial(AppTitle As String, Optional Method As FindWindowPartialTypes = FwpStartsWith, Optional CaseSensitive As Boolean = False) As Long
   Dim hWndApp As Long

   hWndApp = FindWindowPartial(AppTitle, Method, CaseSensitive, True)
   If hWndApp Then
  
      If IsIconic(hWndApp) Then
         Call ShowWindow(hWndApp, SW_RESTORE)
      End If
      Call SetForegroundWindow(hWndApp)
      AppActivatePartial = hWndApp
   End If
End Function
Public Function FindWindowPartial(AppTitle As String, _
   Optional Method As FindWindowPartialTypes = FwpStartsWith, _
   Optional CaseSensitive As Boolean = False, _
   Optional MustBeVisible As Boolean = False) As Long

   m_hWnd = 0
   m_Method = Method
   m_CaseSens = CaseSensitive
   m_AppTitle = AppTitle

   If m_CaseSens = False Then
      m_AppTitle = UCase$(m_AppTitle)
   End If

   Call EnumWindows(AddressOf EnumWindowsProc, MustBeVisible)
   FindWindowPartial = m_hWnd
End Function
Private Function EnumWindowsProc(ByVal hWnd As Long, ByVal lParam As Long) As Long
   Static WindowText As String
   Static nRet As Long
   If lParam Then
      If IsWindowVisible(hWnd) = False Then
         EnumWindowsProc = True
         Exit Function
      End If
   End If
   WindowText = Space$(256)
   nRet = GetWindowText(hWnd, WindowText, Len(WindowText))
   If nRet Then
 
      WindowText = Left$(WindowText, nRet)
      If m_CaseSens = False Then
         WindowText = UCase$(WindowText)
      End If

      Select Case m_Method
         Case FwpStartsWith
            If InStr(WindowText, m_AppTitle) = 1 Then
               m_hWnd = hWnd
            End If
         Case FwpContains
            If InStr(WindowText, m_AppTitle) <> 0 Then
               m_hWnd = hWnd
            End If
         Case FwpMatches
            If WindowText = m_AppTitle Then
               m_hWnd = hWnd
            End If
      End Select
   End If

   EnumWindowsProc = (m_hWnd = 0)
End Function