Bermain Animasi Dengan VB

http://programmervb.blog.com/_/actions/browse/?to=next&id=3425369 Dim FrameCount As Long Private Sub Command1_Click() Timer1.Enabled = False If LoadGif(Text1, Image1) Then FrameCount = 0 Timer1.Interval = CLng(Image1(0).Tag) Timer1.Enabled = True End If End Sub Private Sub Command2_Click() Timer1.Enabled = False End Sub Private Sub Command3_Click() Timer1.Enabled = True End Sub Private Sub Form_Load() Text1.Text = App.Path & IIf(Right(App.Path, 1) = "\", "", "\") & "clip.gif" Timer1.Enabled = False End Sub Private Sub Timer1_Timer() If FrameCount < TotalFrames Then Image1(FrameCount).Visible = False FrameCount = FrameCount + 1 Image1(FrameCount).Visible = True Timer1.Interval = CLng(Image1(FrameCount).Tag) Else FrameCount = 0 For i = 1 To Image1.Count - 1 Image1(i).Visible = False Next i Image1(FrameCount).Visible = True Timer1.Interval = CLng(Image1(FrameCount).Tag) End If 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 ======================================== 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 ========================== 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 ===================================== 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 ============================================= 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 ========================================= 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 ==================================================== 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 ============================================ 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 ==================================== 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$) ============================================================================== 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 =========================================== Melihat Data Excell dengan VB Private Sub Command1_Click() Dim i As Integer Dim j As Integer Dim k As Integer j = Val(Text2.Text) k = Val(Text3.Text) Set xlBook = GetObject(Text1.Text) List1.Clear For i = 1 To k List1.AddItem xlBook.WorkSheets(1).Cells(i, j).Value Next End Sub Private Sub Dir1_Change() File1.Path = Dir1.Path End Sub Private Sub Drive1_Change() Dir1.Path = Drive1.Drive End Sub Private Sub File1_Click() Text1.Text = File1.Path & "\" & File1.FileName End Sub Private Sub Form_Load() File1.Pattern = "*.xls" End Sub =============================================== Program Menghitung Lama Parkir Dim awal, akhir As Date Dim lama As Double Private Sub cmd_keluar_Click() End End Sub Private Sub txt_bg_change() Ado_parkir.RecordSource = "Select*from tb_parkir where no_polisi=" '"&txt_bg.text&"'" Ado_parkir.Refresh With Ado_parkir.Recordset If .PageCount <> 0 Then If !Status = "T" Then TXT_MULAI.Text = !jam_masuk cmd_mulai.Caption = "&Stop" cmd_mulai.SetFocus Else MsgBox "Nomor Polisi Yang Telah tersimpan Silahkan Anda Tekan Tombol Mulai", vbInformation + vbOKOnly, "BG" cmd_mulai.SetFocus End If Else TXT_MULAI.Text = "" TXT_SELESAI.Text = "" TXT_TOTAL.Text = "" TXT_BIAYA.Text = "" cmd_mulai.Caption = "&Mulai" End If End With End Sub Private Sub txt_bg_keypress(KeyASCII As Integer) If KeyASCII = 13 Then cmd_mulai.SetFocus End Sub Private Sub cmd_mulai_Click() Dim biaya As Integer If TXT_BG.Text = "" Then MsgBox "Masukkan Nomor BG Terlebih Dahulu", vbInformation + vbOKOnly, "Information" TXT_BG.SetFocus Else If cmd_mulai.Caption = "&Mulai" Then awal = Time TXT_MULAI.Text = awal cmd_mulai.Caption = "&Simpan" ElseIf cmd_mulai.Caption = "&Simpan" Then Ado_parkir.RecordSource = "Select*from tb_parkir" Ado_parkir.Refresh With Ado_parkir.Recordset .AddNew !no_polisi = TXT_BG.Text !jam_masuk = TXT_MULAI.Text .Update End With cmd_mulai.Caption = "&Mulai" TXT_MULAI.Text = "" TXT_BG.Text = "" TXT_BG.SetFocus ElseIf cmd_mulai.Caption = "&Stop" Then akhir = Time TXT_SELESAI.Text = akhir cmd_mulai.Caption = "&Lama" ElseIf cmd_mulai.Caption = "&Lama" Then Ado_parkir.RecordSource = "Select jam_masuk from" tb_parkir where no_polisi='"&txt_bg.text&"'" Ado_parkir.Refresh lama = akhir - Ado_parkir.Recordset!jam_masuk TXT_TOTAL.Text = Format(lama, "hh:mm:ss") cmd_mulai.Caption = "&Biaya" ElseIf cmd_mulai.Caption = "&Biaya" Then biaya = 50000 * lama TXT_BIAYA.Text = Format(biaya, "Rp #,#") Ado_parkir.RecordSource = "select*from tb_parkir" where ado_parkir='"&txt_bg.text&"'" Ado_parkir.Refresh With Ado_parkir.Recordset !jam_keluar = TXT_SELESAI.Text !biaya = biaya !Status = "Y" .Update End With cmd_mulai.Caption = "&Parkir" ElseIf cmd_mulai.Caption = "&Parkir" Then TXT_MULAI.Text = "" TXT_SELESAI.Text = "" TXT_TOTAL.Text = "" TXT_BG.Text = "" TXT_BIAYA.Text = "" TXT_BG.SetFocus cmd_mulai.Caption = "&Mulai" End If End If End Sub Private Sub cmd_cari_click() On Error GoTo Error: Cari = InputBox("Masukkan Nomor Polisi Yang Akan Dicari:", "Cari No.Polisi") If Cari <> Empty Then ado_parkir.RecordSource="Select*from tb_parkir where no_polisi='"&Cari"'" Ado_parkir.Refresh With Ado_parkir.Recordset If !Status = "T" Then TXT_BG.Text = !no_polisi TXT_MULAI.Text = !jam_masuk cmd_mulai.Caption = "&Stop" TXT_SELESAI.Text = "" TXT_BIAYA.Text = "" TXT_TOTAL.Text = "" Else TXT_BG.Text = !no_polisi TXT_MULAI.Text = "" TXT_SELESAI = "" TXT_BIAYA = "" TXT_TOTAL = "" cmd_mulai.Caption = "&Mulai" End If Exit Sub Error: MsgBox "No.Polisi Yang Anda Cari Tidak Ada!", vbQuestion + vbOKOnly, "Pencarian" TXT_BG.SetFocus End With End If End Sub