Trik VB Source Code

Inilah beberap kumpulan Source Code Visual Basic…

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$)

====================================================================================
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

====================================================================================
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.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