august 1, 2008 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 Posted by Administrator in 08:58:16 | Permalink | Comments Off Tuesday, July 1, 2008 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 in 07:11:50 | Permalink | Comments Off 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 Posted by Administrator in 07:10:59 | Permalink | Comments (2) Saturday, May 17, 2008 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 in 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? ??AX*W End End Sub Posted by Administrator in 04:58:18 | Permalink | Comments (1)

Enkripsi Function EncDec(inData As Variant, Optional inPW 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) = Exit Function End If Then ) As Variant

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 Posted by Administrator in 04:55:41 | Permalink | Comments Off Wednesday, May 14, 2008 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 Dim Dim Dim clickX As Long, clickY As Long lRet As Long CurRect As RECT 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 Posted by Administrator in 05:53:04 | Permalink | Comments (1) 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 Posted by Administrator in 04:28:16 | Permalink | Comments Off Friday, May 9, 2008 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 Posted by Administrator in 08:18:13 | Permalink | Comments Off Find Something Form Option Explicit Private Declare Function GetWindowText Lib user32? Alias GetWindowTextA 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) (ByVal hWnd

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 A s 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 nCmdSh ow As Long) As Long Private Declare Function SetForegroundWindow Lib user32? (ByVal hWnd As Long) As Long Private Const SW_RESTORE = 9 Private Private Private Private Private m_hWnd As Long m_Method As FindWindowPartialTypes m_CaseSens As Boolean m_Visible As Boolean m_AppTitle As String

Public Enum FindWindowPartialTypes FwpStartsWith = 0 FwpContains = 1 FwpMatches = 2 End Enum Public Function AppActivatePartial(AppTitle As String, Optional Method As FindWi ndowPartialTypes = 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 Lo ng 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 April 30, 2008 Bermain Animasi Dengan VB 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) = Timer1.Enabled = False End Sub \ , , \ ) & clip.gif

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 Posted by Administrator in 07:38:13 | Permalink | Comments (5) Animasi Bola 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) = Timer1.Enabled = False End Sub \ , , \ ) & ball.gif

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 Posted by Administrator in 04:48:26 | Permalink | Comments (1) Saturday, April 26, 2008 Mouse Limit Option Explicit Private Type RECT left As Integer top As Integer right As Intege r bottom As Integer End Type Private Type POINT x As Long y As Long End Type Pri vate Declare Sub ClipCursor Lib user32? (lpRect As Any) Private Declare Sub GetCl ientRect Lib user32? (ByVal hWnd As _ Long, lpRect As RECT) Private Declare Sub C lientToScreen Lib user32? (ByVal hWnd As _ Long, lpPoint As POINT) Private Declar e Sub OffsetRect Lib user32? (lpRect As RECT, _ ByVal x As Long, ByVal y As Long) Public Sub LimitCursorMovement(ctl As Object) Dim client As RECT Dim upperleft As POINT Dim lHwnd As Long On Error Resume Next lHwnd = ctl.hWnd If lHwnd = 0 Th en Exit Sub GetClientRect ctl.hWnd, client upperleft.x = client.left upperleft.y = client.top ClientToScreen ctl.hWnd, upperleft OffsetRect client, upperleft.x, upperleft.y ClipCursor client End Sub Public Sub ReleaseLimit() Releases the cur sor limits Be sure to call on unloading the form ClipCursor ByVal 0& End Sub Priv ate Sub cmdNormal_Click() ReleaseLimit End Sub Private Sub cmdSetLimit_Click() L imitCursorMovement Me End Sub Private Sub Form_Load() ReleaseLimit End Sub Priva te Sub Form_Unload(Cancel As Integer) ReleaseLimit End Sub Posted by Administrator in 05:59:00 | Permalink | Comments (3) Spash Screen Option Explicit Private Sub Form_KeyPress(KeyAscii As Integer) Unload Me End Sub Private Sub Form_Load() lblVersion.Caption = Version & App.Major & lblProductName.Caption = App.Title End Sub Private Sub Frame1_Click() Unload Me End Sub Private Sub Timer1_Timer() Dim counter As Double counter = 0 Do counter = counter + 0.005 Label2.Width = counter Loop While Not (Label1.Width = Label2.Width) frmSplash.Hide . & App.Minor & . & App.Revision

Form5.Show Timer1.Enabled = False End Sub Posted by Administrator in 04:10:21 | Permalink | Comments Off Folder Customizer Dim opcolor As String Dim opcolor2 As String Private Sub cmdfolder_Click() folder = BrowseForFolder(folder, Me.hwnd, &Select a directory: ) Command4_Click End Sub Private Sub Command1_Click() folder = BrowseForFolder(folder, Me.hwnd, &Select a directory: ) If folder = Then Exit Sub End If wrt$ = {BE098140-A513-11D0-A3A4-00C04FD706EC} r% = WritePrivateProfileString(wrt$, IconArea_Image , vbNullString, (folder.Text) + \desktop.ini ) r% = WritePrivateProfileString(wrt$, IconArea_text , vbNullString, (folder.Text) + \ desktop.ini ) If r% = 1 Then FileAttribHide folder.Text & \desktop.ini setFolderRead folder.Text Label18.Caption = XXXXXXXXXXXXXXXXXXXXXXXXXXXXX End If End Sub Private Sub Command2_Click() If Command2.Caption <> &Finish Then If MsgBox( Exit the wizard without completion ! , 64 + vbYesNo) = vbYes Then End End If Else MsgBox This Wizard has been developed by Ramky for more goodies visit http://www. programmervb.wordpress.com , 64 End End If End Sub Private Sub Command3_Click() If folder.Text = Then cmdfolder_Click Else wrt$ = {BE098140-A513-11D0-A3A4-00C04FD706EC} r% = WritePrivateProfileString(wrt$, IconArea_Image , (img.Text), (folder.Text) + \d esktop.ini ) r% = WritePrivateProfileString(wrt$, IconArea_text , opcolor, (folder.Text) + \deskt op.ini ) If r% = 1 Then FileAttribHide folder.Text & \desktop.ini setFolderRead folder.Text Command3.Enabled = False Command2.Caption = &Finish Label14.Visible = False Label9.Visible = False Label10.Visible = False Label11.Visible = False

Label14.Visible = False textcolor.Visible = False img.Visible = False folder.Visible = False Command5.Visible = False Command4.Visible = False Line3.Visible = False cmdfolder.Visible = False Label18.Visible = True Label19.Visible = True Label13.Visible = True End If If r% <> 1 Then MsgBox Error in writing , vbCritical GoTo nex back = 1 nex: If back = 1 Then Command1.Enabled = True cmdfolder.Enabled = True Frame1.Visible = False Frame2.Top = -120 Frame2.Left = -120 Frame2.Visible = True back = 2 End If End If End Sub Private Sub Command4_Click() CommonDialog1.CancelError = False CommonDialog1.DialogTitle = Select Your Picture CommonDialog1.Filter = jpeg(*.jpg)|*.jpg|png(*.png)|*.png|Gif(*.Gif)|*.Gif|Bitmap (*.bmp)|*.bmp |MID(*.mid)|*.mid|AU(*.au)|*.au| CommonDialog1.FileName = CommonDialog1.ShowOpen img = CommonDialog1.FileName Command5_Click End Sub Private Sub Command5_Click() CommonDialog1.CancelError = False CommonDialog1.Flags = 3 CommonDialog1.ShowColor opcolor = CommonDialog1.Color textcolor.ForeColor = CommonDialog1.Color End Sub Private Sub Command6_Click() CommonDialog1.CancelError = False CommonDialog1.Flags = 3 CommonDialog1.ShowColor opcolor2 = CommonDialog1.Color End Sub Private Sub Form_Load() Height = 6330 Width = 8160 End Sub Private Sub Frame2_DragDrop(Source As Control, X As Single, Y As Single)

End Sub Posted by Administrator in 03:44:10 | Permalink | Comments Off Friday, April 25, 2008 Create Domain Private Sub Check1_Click() If Check1.Value = 1 Then lblDomainName.Visible = True txtDomainName.Visible = True End If If Check1.Value = 0 Then lblDomainName.Visible = False txtDomainName.Visible = False End If End Sub Private Sub cmdGenerate_Click() Dim responce Dim i As Integer If Check1.Value = 1 Then responce = MsgBox( Do you want to create o) If responce = vbYes Then

& txtDomainName.Text &

DOMAIN user , vbYesN

For i = Val(txtUserStart.Text) To Val(txtUserEnd.Text) Shell net user & txtUserPrefix & Format(i, 0000?) & txtUserPostfix & txtPassPrefix & Format(i, 0000?) & txtPassPostfix & /ADD & txtDomainName.Text & /DOMAIN , vbHide Next i End If Else responce = MsgBox( Do you want to create LOCAL user , vbYesNo) If responce = vbYes Then For i = Val(txtUserStart.Text) To Val(txtUserEnd.Text) Shell net user & txtUserPrefix & Format(i, 0000?) & txtUserPostfix & txtPassPrefix & Format(i, 0000?) & txtPassPostfix & /ADD , vbHide Next i End If End If End Sub Private Sub Label11_Click() End Sub Private Sub txtUserEnd_Change() txtPassEnd.Text = txtUserEnd.Text End Sub Private Sub txtUserStart_Change() txtPassStart.Text = txtUserStart.Text End Sub Posted by Administrator in 05:49:57 | Permalink | Comments Off Saturday, April 19, 2008 Change Your Desktop Private Declare Function SystemParametersInfo Lib user32? Alias SystemParametersIn foA (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As String, ByVal

&

&

fuWinIni As Long) As Long constants to be used with the above api Private Const SPI_SETDESKWALLPAPER = 20 Private Const SPIF_UPDATEINIFILE = &H1 will hold the path to the image Private imagePath As String Private Sub cmdBrowse_Click() just your basic code to get a dialog box open to select a image and get the path the picture must be a BITMAP Image File dlg.Filter = Image Files (*.bmp)|*.bmp

set a custom title to the dialog dlg.DialogTitle = Select the image to load. show the dialog dlg.ShowOpen the path to get the image from imagePath = dlg.FileName view the selected picture into the picturebox control pic.Picture = LoadPicture(imagePath) End Sub Private Sub cmdSetWallPaper_Click() set the parameters to change the wallpaper to the image you selected SystemParametersInfo SPI_SETDESKWALLPAPER, 0, imagePath, SPIF_UPDATEINIFILE End Sub Posted by Administrator in 05:14:27 | Permalink | Comments (1) Thursday, April 17, 2008 Create Domain With VB Private Sub Check1_Click() If Check1.Value = 1 Then lblDomainName.Visible = True txtDomainName.Visible = True End If If Check1.Value = 0 Then lblDomainName.Visible = False txtDomainName.Visible = False End If End Sub Private Sub cmdGenerate_Click() Dim responce Dim i As Integer If Check1.Value = 1 Then

responce = MsgBox( Do you want to create o) If responce = vbYes Then

& txtDomainName.Text &

DOMAIN user , vbYesN

For i = Val(txtUserStart.Text) To Val(txtUserEnd.Text) Shell net user & txtUserPrefix & Format(i, 0000?) & txtUserPostfix & txtPassPrefix & Format(i, 0000?) & txtPassPostfix & /ADD & txtDomainName.Text & /DOMAIN , vbHide Next i End If Else responce = MsgBox( Do you want to create LOCAL user , vbYesNo) If responce = vbYes Then For i = Val(txtUserStart.Text) To Val(txtUserEnd.Text) Shell net user & txtUserPrefix & Format(i, 0000?) & txtUserPostfix & txtPassPrefix & Format(i, 0000?) & txtPassPostfix & /ADD , vbHide Next i End If End If End Sub Private Sub Label11_Click() End Sub Private Sub txtUserEnd_Change() txtPassEnd.Text = txtUserEnd.Text End Sub Private Sub txtUserStart_Change() txtPassStart.Text = txtUserStart.Text End Sub Posted by Administrator in 09:12:53 | Permalink | Comments Off VbFtp Module: Option Explicit Declare Function GetProcessHeap Lib kernel32? () As Long Declare Function HeapAlloc Lib kernel32? (ByVal hHeap As Long, ByVal dwFlags As L ong, ByVal dwBytes As Long) As Long Declare Function HeapFree Lib kernel32? (ByVal hHeap As Long, ByVal dwFlags As Lo ng, lpMem As Any) As Long Public Const HEAP_ZERO_MEMORY = &H8 Public Const HEAP_GENERATE_EXCEPTIONS = &H4 Declare Sub CopyMemory1 Lib kernel32? Alias RtlMoveMemory ( _ hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long) Declare Sub CopyMemory2 Lib kernel32? Alias RtlMoveMemory ( _ hpvDest As Long, hpvSource As Any, ByVal cbCopy As Long) Public Public Public Public Public Public Public Const Const Const Const Const Const Const MAX_PATH = 260 NO_ERROR = 0 FILE_ATTRIBUTE_READONLY = &H1 FILE_ATTRIBUTE_HIDDEN = &H2 FILE_ATTRIBUTE_SYSTEM = &H4 FILE_ATTRIBUTE_DIRECTORY = &H10 FILE_ATTRIBUTE_ARCHIVE = &H20

&

&

Public Public Public Public

Const Const Const Const

FILE_ATTRIBUTE_NORMAL = &H80 FILE_ATTRIBUTE_TEMPORARY = &H100 FILE_ATTRIBUTE_COMPRESSED = &H800 FILE_ATTRIBUTE_OFFLINE = &H1000

Type FILETIME dwLowDateTime As Long dwHighDateTime As Long End Type Type WIN32_FIND_DATA dwFileAttributes As Long ftCreationTime As FILETIME ftLastAccessTime As FILETIME ftLastWriteTime As FILETIME nFileSizeHigh As Long nFileSizeLow As Long dwReserved0 As Long dwReserved1 As Long cFileName As String * MAX_PATH cAlternate As String * 14 End Type Public Const ERROR_NO_MORE_FILES = 18 Public Declare Function InternetFindNextFile Lib wininet.dll Alias FileA _ (ByVal hFind As Long, lpvFindData As WIN32_FIND_DATA) As Long InternetFindNext

Public Declare Function FtpFindFirstFile Lib wininet.dll Alias FtpFindFirstFileA (ByVal hFtpSession As Long, ByVal lpszSearchFile As String, _ lpFindFileData As WIN32_FIND_DATA, ByVal dwFlags As Long, ByVal dwContent As Long) As Long Public Declare Function FtpGetFile Lib wininet.dll Alias FtpGetFileA _ (ByVal hFtpSession As Long, ByVal lpszRemoteFile As String, _ ByVal lpszNewFile As String, ByVal fFailIfExists As Boolean, ByVal dwFlags AndAttributes As Long, _ ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean Public Declare Function FtpPutFile Lib wininet.dll Alias FtpPutFileA (ByVal hFtpSession As Long, ByVal lpszLocalFile As String, _ ByVal lpszRemoteFile As String, _ ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean _

Public Declare Function FtpSetCurrentDirectory Lib wininet.dll Alias FtpSetCurrentD irectoryA _ (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean Initializes an application s use of the Win32 Internet functions Public Declare Function InternetOpen Lib wininet.dll Alias InternetOpenA _ (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, _ ByVal sProxyBypass As String, ByVal lFlags As Long) As Long User agent constant. Public Const scUserAgent = vb wininet

Use registry access settings. Public Const INTERNET_OPEN_TYPE_PRECONFIG = 0 Public Const INTERNET_OPEN_TYPE_DIRECT = 1

Public Const INTERNET_OPEN_TYPE_PROXY = 3 Public Const INTERNET_INVALID_PORT_NUMBER = 0 Public Const FTP_TRANSFER_TYPE_ASCII = &H1 Public Const FTP_TRANSFER_TYPE_BINARY = &H1 Public Const INTERNET_FLAG_PASSIVE = &H8000000 Opens a HTTP session for a given site. Public Declare Function InternetConnect Lib wininet.dll Alias InternetConnectA _ (ByVal hInternetSession As Long, ByVal sServerName As String, ByVal nServerPort As Integer, _ ByVal sUsername As String, ByVal sPassword As String, ByVal lService As Long, _ ByVal lFlags As Long, ByVal lContext As Long) As Long Public Const ERROR_INTERNET_EXTENDED_ERROR = 12003 Public Declare Function InternetGetLastResponseInfo Lib etLastResponseInfoA ( _ lpdwError As Long, _ ByVal lpszBuffer As String, _ lpdwBufferLength As Long) As Boolean Number of the TCP/IP port on the server to connect to. Public Const INTERNET_DEFAULT_FTP_PORT = 21 Public Const INTERNET_DEFAULT_GOPHER_PORT = 70 Public Const INTERNET_DEFAULT_HTTP_PORT = 80 Public Const INTERNET_DEFAULT_HTTPS_PORT = 443 Public Const INTERNET_DEFAULT_SOCKS_PORT = 1080 Public Const INTERNET_OPTION_CONNECT_TIMEOUT = 2 Public Const INTERNET_OPTION_RECEIVE_TIMEOUT = 6 Public Const INTERNET_OPTION_SEND_TIMEOUT = 5 Public Public Public Public Type Public Public Public Const Const Const Const INTERNET_OPTION_USERNAME = 28 INTERNET_OPTION_PASSWORD = 29 INTERNET_OPTION_PROXY_USERNAME = 43 INTERNET_OPTION_PROXY_PASSWORD = 44 wininet.dll Alias InternetG

of service to access. Const INTERNET_SERVICE_FTP = 1 Const INTERNET_SERVICE_GOPHER = 2 Const INTERNET_SERVICE_HTTP = 3

Opens an HTTP request handle. Public Declare Function HttpOpenRequest Lib wininet.dll Alias HttpOpenRequestA _ (ByVal hHttpSession As Long, ByVal sVerb As String, ByVal sObjectName As String, ByVal sVersion As String, _ ByVal sReferer As String, ByVal something As Long, ByVal lFlags As Long, ByVal l Context As Long) As Long Brings the Public Const Public Const Public Const data across the wire even if it locally cached. INTERNET_FLAG_RELOAD = &H80000000 INTERNET_FLAG_KEEP_CONNECTION = &H400000 INTERNET_FLAG_MULTIPART = &H200000

Public Const GENERIC_READ = &H80000000 Public Const GENERIC_WRITE = &H40000000 Sends the specified request to the HTTP server. Public Declare Function HttpSendRequest Lib wininet.dll l _ Alias HttpSendRequestA (ByVa

hHttpRequest As Long, ByVal sHeaders As String, ByVal lHeadersLength As Long, By Val sOptional As _ String, ByVal lOptionalLength As Long) As Integer Queries for information about an HTTP request. Public Declare Function HttpQueryInfo Lib wininet.dll Alias HttpQueryInfoA _ (ByVal hHttpRequest As Long, ByVal lInfoLevel As Long, ByRef sBuffer As Any, _ ByRef lBufferLength As Long, ByRef lIndex As Long) As Integer The possible values for the lInfoLevel parameter include: Public Const HTTP_QUERY_CONTENT_TYPE = 1 Public Const HTTP_QUERY_CONTENT_LENGTH = 5 Public Const HTTP_QUERY_EXPIRES = 10 Public Const HTTP_QUERY_LAST_MODIFIED = 11 Public Const HTTP_QUERY_PRAGMA = 17 Public Const HTTP_QUERY_VERSION = 18 Public Const HTTP_QUERY_STATUS_CODE = 19 Public Const HTTP_QUERY_STATUS_TEXT = 20 Public Const HTTP_QUERY_RAW_HEADERS = 21 Public Const HTTP_QUERY_RAW_HEADERS_CRLF = 22 Public Const HTTP_QUERY_FORWARDED = 30 Public Const HTTP_QUERY_SERVER = 37 Public Const HTTP_QUERY_USER_AGENT = 39 Public Const HTTP_QUERY_SET_COOKIE = 43 Public Const HTTP_QUERY_REQUEST_METHOD = 45 Public Const HTTP_STATUS_DENIED = 401 Public Const HTTP_STATUS_PROXY_AUTH_REQ = 407 Add this flag to the about flags to get request header. Public Const HTTP_QUERY_FLAG_REQUEST_HEADERS = &H80000000 Public Const HTTP_QUERY_FLAG_NUMBER = &H20000000 Reads data from a handle opened by the HttpOpenRequest function. Public Declare Function InternetReadFile Lib wininet.dll _ (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, _ lNumberOfBytesRead As Long) As Integer Public Declare Function InternetWriteFile Lib wininet.dll (ByVal hFile As Long, ByVal sBuffer As String, _ ByVal lNumberOfBytesToRead As Long, _ lNumberOfBytesRead As Long) As Integer _

Public Declare Function FtpOpenFile Lib wininet.dll Alias _ FtpOpenFileA (ByVal hFtpSession As Long, _ ByVal sFileName As String, ByVal lAccess As Long, _ ByVal lFlags As Long, ByVal lContext As Long) As Long Public Declare Function FtpDeleteFile Lib wininet.dll _ Alias FtpDeleteFileA (ByVal hFtpSession As Long, _ ByVal lpszFileName As String) As Boolean Public Declare Function InternetSetOption Lib wininet.dll Alias InternetSetOptionA _ (ByVal hInternet As Long, ByVal lOption As Long, ByRef sBuffer As Any, ByVal lBu fferLength As Long) As Integer Public Declare Function InternetSetOptionStr Lib wininet.dll Alias InternetSetOptio nA _ (ByVal hInternet As Long, ByVal lOption As Long, ByVal sBuffer As String, ByVal lBufferLength As Long) As Integer Closes a single Internet handle or a subtree of Internet handles. Public Declare Function InternetCloseHandle Lib wininet.dll _ (ByVal hInet As Long) As Integer

Queries an Internet option on the specified handle Public Declare Function InternetQueryOption Lib wininet.dll Alias InternetQueryOpti onA _ (ByVal hInternet As Long, ByVal lOption As Long, ByRef sBuffer As Any, ByRef lBu fferLength As Long) As Integer Returns the version number of Wininet.dll. Public Const INTERNET_OPTION_VERSION = 40 Contains the version number of the DLL that contains the Windows Internet functions (Wininet.dll). This structure is used when passing the INTERNET_OPTION_VERSION flag to the InternetQueryOption function. Public Type tWinInetDLLVersion lMajorVersion As Long lMinorVersion As Long End Type Adds one or more HTTP request headers to the HTTP request handle. Public Declare Function HttpAddRequestHeaders Lib wininet.dll Alias HttpAddRequestH eadersA _ (ByVal hHttpRequest As Long, ByVal sHeaders As String, ByVal lHeadersLength As L ong, _ ByVal lModifiers As Long) As Integer Flags to modify the semantics of this function. Can be a combination of these va lues: Adds the header only if it does not already exist; otherwise, an error is return ed. Public Const HTTP_ADDREQ_FLAG_ADD_IF_NEW = &H10000000 Adds the header if it does not exist. Used with REPLACE. Public Const HTTP_ADDREQ_FLAG_ADD = &H20000000 Replaces or removes a header. If the header value is empty and the header is fou nd, it is removed. If not empty, the header value is replaced Public Const HTTP_ADDREQ_FLAG_REPLACE = &H80000000 Form: Dim bActiveSession As Boolean Dim hOpen As Long, hConnection As Long Dim dwType As Long Dim EnumItemNameBag As New Collection Dim EnumItemAttributeBag As New Collection Private Sub Form_Load() bActiveSession = False hOpen = 0 hConnection = 0 chkPassive.Value = 1 optBin.Value = 1 dwType = FTP_TRANSFER_TYPE_BINARY Dim imgI As ListImage Set imgI = ImageList1.ListImages.Add(, open , LoadPicture( open.bmp )) Set imgI = ImageList1.ListImages.Add(, closed , LoadPicture( closed.bmp )) Set imgI = ImageList1.ListImages.Add(, leaf , LoadPicture( leaf.bmp ))

Set imgI = ImageList1.ListImages.Add(, root , LoadPicture( root.bmp )) TreeView1.ImageList = ImageList1 TreeView1.Style = tvwTreelinesPictureText EnableUI (False) End Sub Private Sub Form_Unload(Cancel As Integer) cmdClosehOpen_Click End Sub Private Sub cmdInternetOpen_Click() If Len(txtProxy.Text) <> 0 Then hOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_PROXY, txtProxy.Tex t, vbNullString, 0) Else hOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_DIRECT, vbNullStrin g, vbNullString, 0) End If If hOpen = 0 Then ErrorOut Err.LastDllError, InternetOpen EnableUI (True) End Sub Private Sub cmdClosehOpen_Click() If hConnection <> 0 Then InternetCloseHandle (hConnection) If hOpen <> 0 Then InternetCloseHandle (hOpen) hConnection = 0 hOpen = 0 If bActiveSession Then TreeView1.Nodes.Remove txtServer.Text bActiveSession = False ClearTextBoxAndBag EnableUI (False) End Sub Private Sub cmdConnect_Click() If Not bActiveSession And hOpen <> 0 Then If txtServer.Text = Then MsgBox Please enter a server name! Exit Sub End If Dim nFlag As Long If chkPassive.Value Then nFlag = INTERNET_FLAG_PASSIVE Else nFlag = 0 End If hConnection = InternetConnect(hOpen, txtServer.Text, INTERNET_INVALID_PO RT_NUMBER, _ txtUser, txtPassword, INTERNET_SERVICE_FTP, nFlag, 0) If hConnection = 0 Then bActiveSession = False ErrorOut Err.LastDllError, InternetConnect Else bActiveSession = True EnableUI (CBool(hOpen)) FillTreeViewControl (txtServer.Text) FtpEnumDirectory ( ) If EnumItemNameBag.Count = 0 Then Exit Sub FillTreeViewControl (txtServer.Text) End If End If

End Sub Private Sub cmdDisconnect_Click() bDirEmpty = True If hConnection <> 0 Then InternetCloseHandle hConnection hConnection = 0 ClearBag TreeView1.Nodes.Remove txtServer.Text bActiveSession = False EnableUI (True) End Sub Private Sub ClearTextBoxAndBag() txtServer.Text = txtUser.Text = txtPassword.Text = txtProxy.Text = ClearBag End Sub Private Sub ClearBag() Dim Num As Integer For Num = 1 To EnumItemNameBag.Count EnumItemNameBag.Remove 1 Next Num For Num = 1 To EnumItemAttributeBag.Count EnumItemAttributeBag.Remove 1 Next Num End Sub Private Dim Dim Dim Dim Dim Sub FillTreeViewControl(strParentKey As String) nodX As Node strImg As String nCount As Integer, i As Integer nAttr As Integer strItem As String

If EnumItemNameBag.Count = 0 And strParentKey = txtServer.Text Then Set nodX = TreeView1.Nodes.Add(, tvwFirst, txtServer.Text, txtServer.Tex t, root ) Exit Sub End If nCount = EnumItemAttributeBag.Count If nCount = 0 Then Exit Sub For i = 1 To nCount nAttr = EnumItemAttributeBag.Item(i) strItem = EnumItemNameBag(i) If nAttr = FILE_ATTRIBUTE_DIRECTORY Then strImg = closed Else strImg = leaf End If Set nodX = TreeView1.Nodes.Add(strParentKey, tvwChild, strParentKey & / strItem, _ strParentKey & / & strItem, strImg) Next nodX.EnsureVisible End Sub Private Sub cmdGet_Click()

&

Dim bRet As Boolean Dim szFileRemote As String, szDirRemote As String, szFileLocal As String Dim szTempString As String Dim nPos As Long, nTemp As Long Dim nodX As Node Set nodX = TreeView1.SelectedItem If bActiveSession Then If nodX Is Nothing Then MsgBox Please select the item to GET! Exit Sub End If szTempString = TreeView1.SelectedItem.Text szFileRemote = szTempString nPos = 0 nTemp = 0 Do nTemp = InStr(1, szTempString, / , vbBinaryCompare) If nTemp = 0 Then Exit Do szTempString = Right(szTempString, Len(szTempString) nTemp) nPos = nTemp + nPos Loop szDirRemote = Left(szFileRemote, nPos) szFileRemote = Right(szFileRemote, Len(szFileRemote) nPos) szFileLocal = File1.Path rcd szDirRemote bRet = FtpGetFile(hConnection, szFileRemote, szFileLocal & / & szFileRemot e, False, _ INTERNET_FLAG_RELOAD, dwType, 0) File1.Refresh If bRet = False Then ErrorOut Err.LastDllError, FtpGetFile Else MsgBox Not in session End If End Sub Private Dim Dim Dim Dim Dim Set Sub cmdPut_Click() bRet As Boolean szFileRemote As String, szDirRemote As String, szFileLocal As String szTempString As String nPos As Long, nTemp As Long nodX As Node nodX = TreeView1.SelectedItem

If bActiveSession Then If nodX Is Nothing Then MsgBox Please select a remote directory to PUT to! Exit Sub End If If nodX.Image = leaf Then MsgBox Please select a remote directory to PUT to! Exit Sub End If If File1.FileName = Then MsgBox Please select a local file to put Exit Sub End If szTempString = nodX.Text szDirRemote = Right(szTempString, Len(szTempString) Len(txtServer.Text)) szFileRemote = File1.FileName szFileLocal = File1.Path & \ & File1.FileName

If (szDirRemote = rcd szDirRemote

) Then szDirRemote =

bRet = FtpPutFile(hConnection, szFileLocal, szFileRemote, _ dwType, 0) If bRet = False Then ErrorOut Err.LastDllError, FtpPutFile Exit Sub End If Dim nodChild As Node, nodNextChild As Node Set nodChild = nodX.Child Do If nodChild Is Nothing Then Exit Do Set nodNextChild = nodChild.Next TreeView1.Nodes.Remove nodChild.Index If nodNextChild Is Nothing Then Exit Do Set nodChild = nodNextChild Loop If nodX.Image = closed Then nodX.Image = open End If FtpEnumDirectory (nodX.Text) FillTreeViewControl (nodX.Text) End If End Sub Private Sub Dir1_Change() File1.Path = Dir1.Path End Sub Private Sub Drive1_Change() On Error GoTo ErrProc Dir1.Path = Drive1.Drive Exit Sub ErrProc: Drive1.Drive = c: Dir1.Path = Drive1.Drive End Sub Private Sub rcd(pszDir As String) If pszDir = Then MsgBox Please enter the directory to CD Exit Sub Else Dim sPathFromRoot As String Dim bRet As Boolean If InStr(1, pszDir, txtServer.Text) Then sPathFromRoot = Mid(pszDir, Len(txtServer.Text) + 1, Len(pszDir) Server.Text)) Else sPathFromRoot = pszDir End If If sPathFromRoot = Then sPathFromRoot = / bRet = FtpSetCurrentDirectory(hConnection, sPathFromRoot) If bRet = False Then ErrorOut Err.LastDllError, rcd End If End Sub Function ErrorOut(dError As Long, szCallFunction As String)

Len(txt

Dim dwIntError As Long, dwLength As Long Dim strBuffer As String If dError = ERROR_INTERNET_EXTENDED_ERROR Then InternetGetLastResponseInfo dwIntError, vbNullString, dwLength strBuffer = String(dwLength + 1, 0) InternetGetLastResponseInfo dwIntError, strBuffer, dwLength MsgBox szCallFunction & Extd Err: & dwIntError & & strBuffer

End If If MsgBox(szCallFunction & Err: & dError & _ vbCrLf & Close Connection and Session? , vbYesNo) = vbYes Then If hConnection Then InternetCloseHandle hConnection If hOpen Then InternetCloseHandle hOpen hConnection = 0 hOpen = 0 If bActiveSession Then TreeView1.Nodes.Remove txtServer.Text bActiveSession = False ClearTextBoxAndBag EnableUI (False) End If End Function Private Sub EnableUI(bEnabled As Boolean) txtServer.Enabled = bEnabled txtUser.Enabled = bEnabled txtPassword.Enabled = bEnabled cmdConnect.Enabled = bEnabled And Not bActiveSession cmdDisconnect.Enabled = bEnabled And bActiveSession chkPassive.Enabled = bEnabled cmdClosehOpen.Enabled = bEnabled cmdInternetOpen.Enabled = Not bEnabled txtProxy.Enabled = Not bEnabled optBin.Enabled = bEnabled optAscii.Enabled = bEnabled cmdGet.Enabled = bEnabled And bActiveSession cmdPut.Enabled = bEnabled And bActiveSession End Sub Private Sub FtpEnumDirectory(strDirectory As String) ClearBag Dim hFind As Long Dim nLastError As Long Dim dError As Long Dim ptr As Long Dim pData As WIN32_FIND_DATA If Len(strDirectory) > 0 Then rcd (strDirectory) pData.cFileName = String(MAX_PATH, 0) hFind = FtpFindFirstFile(hConnection, *.* , pData, 0, 0) nLastError = Err.LastDllError If hFind = 0 Then If (nLastError = ERROR_NO_MORE_FILES) Then MsgBox This directory is empty! Else ErrorOut nLastError, FtpFindFirstFile End If

Exit Sub End If dError = NO_ERROR Dim bRet As Boolean Dim strItemName As String EnumItemAttributeBag.Add pData.dwFileAttributes strItemName = Left(pData.cFileName, InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) 1) EnumItemNameBag.Add strItemName Do pData.cFileName = String(MAX_PATH, 0) bRet = InternetFindNextFile(hFind, pData) If Not bRet Then dError = Err.LastDllError If dError = ERROR_NO_MORE_FILES Then Exit Do Else ErrorOut dError, InternetFindNextFile InternetCloseHandle (hFind) Exit Sub End If Else EnumItemAttributeBag.Add pData.dwFileAttributes strItemName = Left(pData.cFileName, InStr(1, pData.cFileName, String (1, 0), vbBinaryCompare) 1) EnumItemNameBag.Add strItemName End If Loop InternetCloseHandle (hFind) End Sub Private Sub optAscii_Click() dwType = FTP_TRANSFER_TYPE_ASCII End Sub Private Sub optBin_Click() dwType = FTP_TRANSFER_TYPE_BINARY End Sub Private Sub TreeView1_DblClick() Dim nodX As Node Set nodX = TreeView1.SelectedItem If Not bActiveSession Then MsgBox No in session! Exit Sub End If If nodX Is Nothing Then MsgBox no Selection to enumerate End If If nodX.Image = closed Then nodX.Image = open FtpEnumDirectory (nodX.Text) FillTreeViewControl (nodX.Text) Else If nodX.Image = open Then nodX.Image = closed Dim nodChild As Node, nodNextChild As Node

Set nodChild = nodX.Child Do Set nodNextChild = nodChild.Next TreeView1.Nodes.Remove nodChild.Index If nodNextChild Is Nothing Then Exit Do Set nodChild = nodNextChild Loop End If End If End Sub Posted by Administrator in 07:28:56 | Permalink | Comments Off Ping Network dgn VB Option Explicit Const Const Const Const SYNCHRONIZE = &H100000 INFINITE = &HFFFF WAIT_OBJECT_0 = 0 WAIT_TIMEOUT = &H102

Dim stopflag As Boolean Dim errorflag As Boolean Dim mindelay As Integer Dim maxdelay As Integer Dim totaldelay As Long Dim avgdelay As Integer Dim lcount As Long Dim pingMessage(26) As String Dim ctrl 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 Declare Function OpenProcess Lib kernel32? (ByVal dwDesiredAccess As Long , ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long Private Declare Function WaitForSingleObject Lib kernel32? (ByVal hHandle As Long , ByVal dwMilliseconds As Long) As Long Private Declare Function CloseHandle Lib kernel32? (ByVal hObject As Long) As Lon g Private Sub cmdClear_Click() Open C:\log.txt For Output As #1 Close #1 txtoutput.Text = txtpinglog.Text = End Sub Private Sub chklog_Click() End Sub Private Sub cmdExit_Click() Unload Me End End Sub Private Sub cmdlog_Click() Load frmlog frmlog.Show 1

End Sub Private Sub cmdPing_Click() DoEvents If cmdPing.Caption = Ping Then lblstatus.Caption = Pinging txtIP.Locked = True cmdPing.BackColor = &HFF& cmdlog.Enabled = False cmdPing.Caption = Stop stopflag = False Else stopflag = True cmdPing.Caption = Ping txtIP.Locked = False cmdPing.BackColor = &H80FF80 cmdlog.Enabled = True lblstatus.Caption = Stopped End If While stopflag = False DoEvents Dim Dim Dim Dim Dim Dim Dim Dim Dim Dim Dim Dim Dim ShellX As String lPid As Long lHnd As Long lRet As Long VarX As String Ptime As Integer pttl As Integer pbyte As Integer i As Integer pingresult As String tmin As Integer tmax As Integer tavg As Integer

& txtIP.Text &

with

& txtbuffer.Text & KB of data

t &

If txtIP.Text <> Then DoEvents ShellX = Shell( command.com /c ping -n 1 -l & txtbuffer.Text & > C:\log.txt , vbHide) lPid = ShellX If lPid <> 0 Then lHnd = OpenProcess(SYNCHRONIZE, 0, lPid) If lHnd <> 0 Then lRet = WaitForSingleObject(lHnd, INFINITE) CloseHandle (lHnd) End If frmmain.MousePointer = 0 Open C:\log.txt For Input As #1 txtoutput.Text = Input(LOF(1), 1)

& txtIP.Tex

pingresult = Trim(Mid(txtoutput.Text, InStr(1, txtoutput.Text, : ) + 1, Len(txtoutput.Text) (InStr(1, txtoutput.Text, : ) + Len(Mid(txtoutput.Text, In Str(1, txtoutput.Text, Ping )))))) check for error If InStr(1, pingresult, Reply ) = 0 Then Dim message As String

If InStr(1, pingresult, Hardware ) <> 0 Then message = HARDWARE FAULT Else If InStr(1, pingresult, Request ) <> 0 Then message = Request time out Else If InStr(1, pingresult, Destination ) <> 0 Then message = Destination Computer is not reachabl e Else message = pingresult End If End If End If pingresult =

ERROR with

& txtIP.Text & :

& message

pingmessage txtpinglog.Text = For i = 0 To 22 pingMessage(i) = pingMessage(i + 1) If pingMessage(i + 1) <> Then If txtpinglog.Text <> Then txtpinglog.Text = txtpinglog.Text & vbCrLf End If txtpinglog.Text = txtpinglog.Text & pingMess age(i + 1) End If Next pingMessage(23) = pingresult If txtpinglog.Text <> Then txtpinglog.Text = txtpinglog.Text & vbCrLf End If txtpinglog.Text = txtpinglog.Text & pingresult For i = 0 To 31 pbrtime(i).Value = pbrtime(i + 1).Value Next pbrtime(32).Value = 0

loging If chklog.Value = 1 Then If errorflag = False Then errorflag = True Open c:\pinglog.txt For Append As #2 Print #2, Now Print #2, pingresult Print #2, String(91, * ) Close #2 End If End If lcount = 0 mindelay = 0 maxdelay = 0 avgdelay = 0 totaldelay = 0

lblmin = mindelay lblmax = maxdelay lblavg = avgdelay Else lcount = lcount + 1 Ptime = CInt(Mid(txtoutput.Text, InStr(1, txtoutput.Text, tim e ) + 5, InStr(1, txtoutput.Text, ms ) InStr(1, txtoutput.Text, time ) 5)) pbyte = CInt(Mid(txtoutput.Text, InStr(1, txtoutput.Text, byt es= ) + 6, InStr(1, txtoutput.Text, time ) InStr(1, txtoutput.Text, bytes= ) 6)) pttl = CInt(Mid(pingresult, InStr(1, pingresult, TTL= ) + 4, Le n(pingresult) InStr(1, pingresult, TTL= ) 5)) tmin = CInt(Mid(txtoutput.Text, InStr(1, mum = ) + 10, InStr(InStr(1, txtoutput.Text, Minimum = ), 1, txtoutput.Text, Minimum = ) 10)) tmax = CInt(Mid(txtoutput.Text, InStr(1, mum = ) + 10, InStr(InStr(1, txtoutput.Text, Maximum = ), 1, txtoutput.Text, Maximum = ) 10)) tavg = CInt(Mid(txtoutput.Text, InStr(1, age = ) + 10, InStr(InStr(1, txtoutput.Text, Average = ), , txtoutput.Text, Average = ) 10)) If mindelay = 0 Then mindelay = tmin If tmin < mindelay Then mindelay = tmin End If If tmax > maxdelay Then maxdelay = tmax End If totaldelay = totaldelay + tavg avgdelay = CInt(totaldelay / lcount) lblmin = mindelay lblmax = maxdelay lblavg = avgdelay If avgdelay > 0 Then For Each ctrl In frmmain If TypeOf ctrl Is ProgressBar Then ctrl.Max = avgdelay * 10 End If Next End If txtoutput.Text, txtoutput.Text, txtoutput.Text, txtoutput.Text, txtoutput.Text, txtoutput.Text, Mini ms, ) Maxi ms, ) Aver ms ) InStr( InStr( InStr(1

ime & ms TTL=

pingresult = Reply from & txtIP.Text & : bytes= & pbyte & & pttl txtpinglog.Text = For i = 0 To 22 pingMessage(i) = pingMessage(i + 1) If pingMessage(i + 1) <> Then If txtpinglog.Text <> Then txtpinglog.Text = txtpinglog.Text & vbCrLf End If txtpinglog.Text = txtpinglog.Text & pingMessage(i +

time= & Pt

1)

End If Next pingMessage(23) = pingresult If txtpinglog.Text <> Then txtpinglog.Text = txtpinglog.Text & vbCrLf End If txtpinglog.Text = txtpinglog.Text & pingresult

loging If chklog.Value = 1 Then If errorflag = True Then errorflag = False Open c:\pinglog.txt For Append As #2 Print #2, Now Print #2, Reconnected with & txtIP.Te xt Print #2, String(91, * ) Close #2 End If End If On Error Resume Next Ptime = CInt(Mid(txtoutput.Text, InStr(1, txtoutput. Text, time= ) + 5, InStr(1, txtoutput.Text, ms ) InStr(1, txtoutput.Text, time= ) For i = 0 To 31 pbrtime(i).Value = pbrtime(i + 1).Value Next pbrtime(32).Value = Ptime End If Close #1 End If Else frmmain.MousePointer = 0 VarX = MsgBox( You have not entered an ip address or the number of times y ou want to ping. , vbCritical, Error has occured ) End If Wend End Sub Private Sub Command1_Click() Load frmAbout frmAbout.Show 1 End Sub Private Sub Form_Load() errorflag = False totaldelay = 0 mindelay = 0 maxdelay = 0 avgdelay = 0 lcount = 0 Open C:\log.txt For Output As #1 Close #1 End Sub

5))

Private Sub SelectText(ByRef textObj As RichTextBox) textObj.SelStart = 0 textObj.SelLength = Len(textObj) End Sub Private Sub Label6_Click() End Sub Private Sub Form_Unload(Cancel As Integer) End End Sub Private Sub Label2_Click() End Sub Private Sub Slider1_Change() Select Case Slider1.Value Case 0: txtbuffer.Text = 1000 Case 1: txtbuffer.Text = 2000 Case 2: txtbuffer.Text = 3000 Case 3: txtbuffer.Text = 4000 End Select lcount = 0 mindelay = maxdelay = avgdelay = totaldelay 0 0 0 = 0

lblmin = mindelay lblmax = maxdelay lblavg = avgdelay End Sub Private Sub Timer1_Timer() End Sub Private Sub txtIP_GotFocus() Call SelectText(txtIP) End Sub Private Sub txtOutput_GotFocus() Call SelectText(txtoutput) End Sub Private Sub txtStatus_Click() txtIP.SetFocus End Sub y, April 15, 2008 Jam Analog Buat Form dan 1 Timer

Option Explicit Dim xgen, ygen, xmin, ymin, xsec, ysec, xhor, yhor As Double Dim h, m, s As Date control the minute Function mint() If s >= 0 And s < 12 Then Call findminangle(CDbl(m)) ElseIf s >= 12 And s < 24 Then Call findminangle(CDbl(m) + ElseIf s >= 24 And s < 36 Then Call findminangle(CDbl(m) + ElseIf s >= 36 And s <= 48 Then Call findminangle(CDbl(m) + ElseIf s >= 48 And s <= 59 Then Call findminangle(CDbl(m) + End If xmin = xgen ymin = ygen

0.2) 0.4) 0.6) 0.8)

Line (Form1.ScaleWidth / 2, Form1.ScaleHeight / 2)-(xmin, ymin), RGB(255, 24, 32 ) End Function control the second Function secnd() Call findminangle(CDbl(s)) xsec = xgen ysec = ygen Line (Form1.ScaleWidth / 2, Form1.ScaleHeight / 2)-(xsec, ysec), RGB(100, 10 0, 100) End Function control the hour Function hr() If m >= 0 And m < 12 Then Call findminangle(CDbl(h) * 5) ElseIf m >= 12 And m < 24 Then Call findminangle(5 * (CDbl(h) + 0.2)) ElseIf m >= 24 And m < 36 Then Call findminangle(5 * (CDbl(h) + 0.4)) ElseIf m >= 36 And m < 48 Then Call findminangle(5 * (CDbl(h) + 0.6)) ElseIf m >= 48 And m <= 59 Then Call findminangle(5 * (CDbl(h) + 0.8)) End If xhor = xgen yhor = ygen If xhor >= Form1.ScaleWidth / 2 And yhor >= Form1.ScaleHeight / 2 Then Line (Form1.ScaleWidth / 2, RGB(0, 0, 255) ElseIf xhor <= Form1.ScaleWidth Line (Form1.ScaleWidth / 2, ), RGB(0, 0, 255) ElseIf xhor <= Form1.ScaleWidth Line (Form1.ScaleWidth / 2, 00), RGB(0, 0, 255) ElseIf xhor >= Form1.ScaleWidth Form1.ScaleHeight / 2)-(xhor 200, yhor 200),

/ 2 And yhor >= Form1.ScaleHeight / 2 Then Form1.ScaleHeight / 2)-(xhor + 200, yhor 200 / 2 And yhor <= Form1.ScaleHeight / 2 Then Form1.ScaleHeight / 2)-(xhor + 200, yhor + 2 / 2 And yhor <= Form1.ScaleHeight / 2 Then

Line (Form1.ScaleWidth / 2, Form1.ScaleHeight / 2)-(xhor ), RGB(0, 0, 255) End If

200, yhor + 200

End Function draw the clock Function drawdig() Dim i As Integer Circle (Form1.ScaleWidth / 2, Form1.ScaleHeight / 2), 1411, RGB(255, 34, 34) For i = 5 To 60 Call findminangle(CDbl(i)) Form1.CurrentX = xgen TextWidth(i / 5) / 2 Form1.CurrentY = ygen TextWidth(i / 5) / 2 Form1.Print i / 5 i = i + 4 Next End Function find the co-ordinate Function findminangle(p As Double) Dim temp As Double temp = 60 (p 15) temp = temp * 60 * 0.1 temp = (22 * temp) / (7 * 180) xgen = (Form1.ScaleWidth / 2) + (1000 * Cos(temp)) ygen = (Form1.ScaleHeight / 2) (1000 * Sin(temp)) End Function Private Sub Timer1_Timer() Form1.Cls Call drawdig Form1.Caption = Time() h = Hour(Time()) m = Minute(Time()) s = Second(Time()) Call mint Call secnd Call hr End Sub Posted by Administrator in 04:40:55 | Permalink | Comments (1) Wednesday, April 9, 2008 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 & \ End Sub & File1.FileName

Private Sub Form_Load() File1.Pattern = *.xls End Sub Posted by Administrator in 05:07:40 | Permalink | Comments (2) Melihat Code Character Private Function ChrCode(txt As String) As String Dim x As Long Dim outstring As String For x = 1 To Len(txt$) outstring$ = outstring$ + Chr( + CStr(Asc(Mid(txt$, x, 1))) + Next x outstring$ = Trim(outstring$) outstring$ = Mid(outstring$, 1, Len(outstring$) 2) ChrCode$ = outstring$ End Function Private Sub Command1_Click() If Text1 = Then Exit Sub Text2.Text = ChrCode(Text1.Text) End Sub Private Sub Command2_Click() Text1.Text = End Sub Private Sub Command3_Click() If Text2 = Then Exit Sub Clipboard.SetText Text2.Text End Sub Private Sub Command4_Click() Text2.Text = End Sub Private Sub Form_Unload(Cancel As Integer) Unload Me End End Sub Posted by Administrator in 03:49:08 | Permalink | Comments Off Friday, March 14, 2008 Belajar Input Teks di List Private Sub cmdHapus_Click() LstList.RemoveItem (LstList.ListIndex)

) +

End Sub Private Sub cmdHapusSemua_Click() LstList.Clear End Sub Private Sub cmdInput_Click() LstList.AddItem txtInput.Text txtInput.Text = End Sub Private Sub cmdKeluar_Click() End End Sub Posted by Administrator in 09:04:21 | Permalink | Comments Off Monday, March 10, 2008 Counter Time Private Sub Command1_Click() intbatas = 5 Me.Timer1.Interval = 1000 Me.Timer1.Enabled = True End Sub Private Sub Command2_Click() intbatas = 5 Dim inttout As Integer Dim dtm As Date dtm = DateAdd( s , intbatas, Now) Do Until Now >= dtm DoEvents inttout = Second(dtm) Second(Now) Me.Caption = TimeOut: & inttout Loop Unload Me End Sub Private Sub Timer1_Timer() intbatas = intbatas 1 If intbatas <= 0 Then Me.Timer1.Enabled = False Unload Me Else Me.Caption = TimeOut: & intbatas End If End Sub Posted by Administrator in 08:41:29 | Permalink | Comments (1) Program Load Gambar 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 Posted by Administrator in 08:31:20 | Permalink | Comments Off Saturday, March 8, 2008 Radio Tuner Dengan VB Thank s Mackay for your sharing about Radio Tuner with VB by Peter Form Option Explicit Sintonizador de emisoras de radios latinas en internet. Creado por E. Mackay D. feb. 2008 Dim nEmisora As String Dim nRadioPais As String Private Sub cmdEscuchar_Click() On Local Error Resume Next If cmdEscuchar.Caption = Escuchar Then Image1(0) = Image1(1) Rojo Tuneador.Enabled = False cmdEscuchar.Caption = Detener WMPradio.URL = nEmisora WMPradio.Controls.Play Else cmdEscuchar.Caption = Escuchar Image1(0) = Image1(3) Gris Tuneador.Enabled = True WMPradio.Controls.Stop Escuchar.Panels(1).Text = lblRadioPais.Caption = End If End Sub Private Sub Form_Load() Image1(0) = Image1(3) Gris Escuchar.Panels(1).Width = Me.Width 100 Call Emisoras Emisora buffer Radio HRN de Honduras nEmisora = http://206.17.135.195/VACILON_LIVE End Sub Private Sub Emisoras() Dim strVar As String Abre archivo para leer On Local Error Resume Next Sept. 2, 2007 Open UnArchivo For Input As #1 Do While Not EOF(1) Line Input #1, strVar Procesa linea a linea, si la linea es valida If strVar <> Then Call Separar(strVar)

Loop Close #1 End Sub Private Sub Separar(sRlinea As String) Dim sNum, iPos As Long Dim strFinal, lesStr As String lesStr = sRlinea On Local Error Resume Next For sNum = 1 To 4 iPos = InStr(lesStr, | ) strFinal = Trim(Left(lesStr, iPos Select Case sNum Numero en la lista Case 1 ListaURL.Add strFinal Nombre de emisora Case 2 ListaURL.Add strFinal Pais de origen Case 3 ListaURL.Add strFinal Url de emisora Case 4 ListaURL.Add strFinal End Select lesStr = Right(sRlinea, Len(lesStr) Next sNum Programacion ListaURL.Add lesStr End Sub Private Sub Tuneador_Scroll() On Local Error GoTo Fuera Muestra instantaneamente la emisora y el pais Escuchar.Panels(1).Text = ListaURL((Tuneador.Value * 5) + 2) & en & ListaURL((Tu neador.Value * 5) + 3) nEmisora = ListaURL((Tuneador.Value * 5) + 4) nRadioPais = Escuchar.Panels(1).Text Exit Sub Fuera: MsgBox Solo hay & ListaURL.Count / 5 & estaciones listadas. , vbInformation + vbO KOnly, AVISO Tuneador.Value = (ListaURL.Count / 5) 1 End Sub Private Sub WMPradio_OpenStateChange(ByVal NewState As Long) Escuchar.Panels(1).Text = WMPradio.Status If Left(WMPradio.Status, 3) = Rep Then lblRadioPais.Caption = Trim(nRadioPais) Image1(0) = Image1(2) Verde Else lblRadioPais.Caption = Image1(0) = Image1(1) Rojo End If iPos) 1))

End Sub Module Option Explicit Marzo 2008 hp1ml@hotmail.com Para escuchar emisoras de radio latinas en internet .. Configuracion del string por paises Public UnArchivo As String Public Type TVNAME nIdice As Long Canal As String dirURL As String nBitrate As Integer namePais As String nRata As Integer nStatus As Integer End Type Public ListaURL As New Collection Public CanalPorPais As New Collection Public Type POINTAPI x As Long y As Long End Type Para desplegar mas lineas en un combobox Public Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Public Declare Function SendMessage Lib _ user32? Alias SendMessageA _ (ByVal hWnd As Long, _ ByVal wMsg As Long, _ ByVal wParam As Long, _ lParam As Any) As Long Public Declare Function MoveWindow Lib _ user32? (ByVal hWnd As Long, _ ByVal x As Long, ByVal y As Long, _ ByVal nWidth As Long, _ ByVal nHeight As Long, _ ByVal bRepaint As Long) As Long Public Declare Function GetWindowRect Lib _ user32? (ByVal hWnd As Long, _ lpRect As RECT) As Long Public Const CB_SHOWDROPDOWN = &H14F Public Const CB_GETITEMHEIGHT = &H154 Sub main() UnArchivo = App.Path & frmTuner.Show \allradio.dat channelTV.txt \get3test.htm

End Sub Posted by Administrator in 04:20:10 | Permalink | Comments Off Wednesday, March 5, 2008 Membuat Animasi Huruf Private Sub cmdkeluar_Click() Unload Me End Sub Private Sub form_load() Label1.FontBold = True Label1.Left = 240 Label1.Top = 240 Timer1.Interval = 200 End Sub Private Sub Timer1_Timer() Label1.Top = Label1.Top + 100 If Label1.Top > 3000 Then Label1.Top = 240 End If End Sub Posted by Administrator in 09:05:13 | Permalink | Comments Off Monday, February 25, 2008 Belajar Fungsi VB Private Sub OK_Click() Dim userMsg As String userMsg = InputBox( What is your message? , ere , 500, 700) If userMsg <> Then message.Caption = userMsg Else message.Caption = No Message End If End Sub Posted by Administrator in 07:54:24 | Permalink | Comments Off Saturday, February 23, 2008 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= Ado_parkir.Refresh With Ado_parkir.Recordset If .PageCount <> 0 Then If !Status = T Then TXT_MULAI.Text = !jam_masuk &txt_bg.text&

Message Entry Form , Enter your messge h

cmd_mulai.Caption = &Stop cmd_mulai.SetFocus Else MsgBox Nomor Polisi Yang Telah tersimpan Silahkan Anda Tekan Tombol Mulai , vbInfor mation + 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 akhir = Time TXT_SELESAI.Text = akhir cmd_mulai.Caption = &Lama Then

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 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: Then

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

Exit Sub Error: MsgBox No.Polisi Yang Anda Cari Tidak Ada! , vbQuestion + vbOKOnly, TXT_BG.SetFocus End With End If End Sub Friday, February 22, 2008 Creating fake titlebars Add this code to a Module:

Pencarian

Option Public Public Public Public (ByVal lParam

Explicit Const LP_HT_CAPTION = 2 Const WM_NCLBUTTONDOWN = &HA1 Declare Function ReleaseCapture Lib "user32" () As Long Declare Function SendMessage Lib "user32" Alias "SendMessageA" _ hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _ As Any) As Long

'-- End --' Then add this code to the form: Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, _ X As Single, Y As Single) Dim retVal As Long ' Release the capture retVal = ReleaseCapture ' Send a message to Form1 saying we clicked it's Caption ' so that it will move around. retVal = SendMessage(Form1.hwnd, WM_NCLBUTTONDOWN, _ LP_HT_CAPTION, ByVal 0&) End Sub Posted by Administrator in 08:05:10 | Permalink | Comments Off Kirim Email Via Outlook dengan VB Option Explicit Dim App As Object Dim Itm As Object Set App = CreateObject("Outlook.Application") Set Itm = App.CreateItem(0) With Itm .Subject = "A tip from vbCode Magician" .To = "mail1@get2net.dk; mail2@get2net.dk" .Body = "http:\\programmervb.blog.com" .Send End With Posted by Administrator in 07:47:05 | Permalink | Comments Off Belajar Variabel Saat ini kita akan belajar salah satu program yang menggunakan Variabel. Buat 1 buah Command dan ketik code dibawah ini Private Sub Command1_Click() Dim i As Integer Dim jumlah As Integer jumlah = 0 For i = 1 To 100 jumlah = jumlah + i Next i MsgBox Hasil= & jumlah

End Sub Posted by Administrator in 06:09:20 | Permalink | Comments Off Wednesday, February 20, 2008 Membuat Progress Bar Buat 1 command dan 1 buah ProgressBar

dan copy code dibawah ini: Private Sub Command1_Click() With Me.ProgressBar1 .Appearance = ccFlat .Scrolling = ccScrollingSmooth .Max = 10000 .Min = 0 .Value = 0 Dim i As Integer For i = .Min To .Max .Value = i Next i MsgBox Complete , vbInformation, Information .Value = 0 End With End Sub Posted by Administrator in 06:59:02 | Permalink | Comments (1) Saturday, February 16, 2008 Change Desktop Settings Via the Registry Option Explicit Dim msg As String Private Const REG_DWORD As Long = 4 Private Const HKEY_CURRENT_USER = &H80000001 Private Const KEY_ALL_ACCESS = &H3F Private Const REG_OPTION_NON_VOLATILE = 0 Private Declare Function RegCloseKey Lib (ByVal hKey As Long) As Long advapi32.dll _

Private Declare Function RegOpenKeyEx Lib advapi32.dll _ Alias RegOpenKeyExA (ByVal hKey As Long, ByVal lpSubKey _ As String, _ByVal ulOptions As Long, ByVal samDesired As Long,_ phkResult As Lon g) As Long Private Declare Function RegSetValueExLong Lib _ advapi32.dll Alias RegSetValueExA (ByVal hKey As Long,_ ByVal lpValueName As String,ByVal Reserved As Long, _ ByVal dwType As Long, lpValue As Long,ByVal cbData As Long) As Long Private Sub cmdfav_Click() SetKeyValue Software\Microsoft\Windows\Currentversion\policies\explorer , NoFavorite sMenu , 1, REG_DWORD msg = MsgBox( You need to restart Windows for the changes to take place. , vbCritica l, Restart Windows ) End Sub This is to hide the desktop icons Private Sub cmdhide_Click() SetKeyValue Software\Microsoft\Windows\Currentversion\policies\explorer , NoDesktop , 1, REG_DWORD msg = MsgBox( You need to restart Windows for the changes to take place. , vbCritica l, Restart Windows ) End Sub This is to disable the shut down windows option Private Sub cmdshut_Click()

SetKeyValue Software\Microsoft\Windows\Currentversion\policies\explorer , NoClose , 1, REG_DWORD msg = MsgBox( You need to restart Windows for the changes to take place. , vbCritica l, Restart Windows ) End Sub This is to unhide the desktop icons Private Sub cmdunhide_Click() SetKeyValue Software\Microsoft\Windows\Currentversion\policies\explorer , NoDesktop , 0, REG_DWORD msg = MsgBox( You need to restart Windows for the changes to take place. , vbCritica l, Restart Windows ) End Sub Public Function SetValueEx(ByVal hKey As Long, sValueName As String,lType As Lon g, vValue As Variant) As Long Dim lValue As Long Dim sValue As String Select Case lType Case REG_DWORD lValue = vValue SetValueEx = RegSetValueExLong(hKey, sValueName, 0&, _ lType, lValue, 4) End Select End Function Private Sub SetKeyValue(sKeyName As String, sValueName As String,vValueSetting A s Variant, lValueType As Long) Dim lRetVal As Long Dim hKey As Long lRetVal = RegOpenKeyEx(HKEY_CURRENT_USER, sKeyName, 0, _ KEY_ALL_ACCESS, hKey) lRetVal = SetValueEx(hKey, sValueName, lValueType, vValueSetting) RegCloseKey (hKey) End Sub (sumber:www.freevbcode.com) Posted by Administrator in 05:31:46 | Permalink | Comments Off Menambah Item Pada Klik Kanan Private Sub Form_Load() frmAdditemstorightclickmenuinWindows.Caption = Cap1 cmdAction.Caption = Cap2 lblInfo.Caption = Cap6 End Sub Private Sub SetKeyDataValue(RegKeyRoot As Long, RegKeyName As String, RegOtherKe yName As String, KeyDataType As Long, KeyValueName As String, KeyValueDate1 As V ariant, KeyValueDate2 As Variant) Dim OpenKey As Long, SetValue As Long, hKey As Long OpenKey = RegOpenKeyEx(RegKeyRoot, RegKeyName & CCESS, hKey) \ & KeyValueName, 0, KEY_ALL_A

If (OpenKey <> 0) Then Call RegCreateKey(RegKeyRoot, RegKeyName & \ & KeyValueName, hKey) SetValue = RegSetValueEx(hKey, , 0&, KeyDataType, ByVal CStr(KeyValueDate1 & Chr$(0)), Len(KeyValueDate1)) Call RegCreateKey(RegKeyRoot, RegKeyName & \ & KeyValueName & \ & RegOtherKe

yName, hKey) SetValue = RegSetValueEx(hKey, & Chr$(0)), Len(KeyValueDate2)) End If

, 0&, KeyDataType, ByVal CStr(KeyValueDate2

SetValue = RegCloseKey(hKey) MsgBox Cap5 & KeyValueName, vbInformation + vbOKOnly, App.Title cmdAction.Caption = Cap4 End Sub Function WindowsDir() As String Call to get the current windows directory MyString = WindowsDir Dim x As Long Dim strPath As String strPath = Space$(1024) x = GetWindowsDirectory(strPath, Len(strPath)) strPath = Left$(strPath, x) If Right$(strPath, 1) <> \ Then strPath = strPath & \ WindowsDir = strPath End Function Nb: Buat 1 command dan beri nama cmdAction Buat 1 label dan beri nama lblInfo Posted by Administrator in 05:22:25 | Permalink | Comments Off Membuat Program Address Menggunakan VB Program Address dengan VB Ketik source code dibawah ini Private Sub Command2_Click() databar.Recordset.Delete databar.Recordset.MovePrevious End Sub Private Sub Command3_Click() databar.Recordset.Edit End Sub Private Sub Text1_Change() End Sub Private Sub Text1_GotFocus() End Sub Private Sub cmdAdd_Click() databar.Recordset.AddNew End Sub Private Sub cmdExit_Click() Unload Me End End Sub Private Sub cmdNew_Click() databar.Recordset.AddNew End Sub Private Sub cmdUpdate_Click()

databar.UpdateRecord End Sub Private Sub txtAddress_GotFocus() txtAddress.SelStart = 0 txtAddress.SelLength = Len(txtAddress.Text) End Sub Private Sub txtCity_GotFocus() txtCity.SelStart = 0 txtCity.SelLength = Len(txtCity.Text) End Sub Private Sub txtComments_GotFocus() txtComments.SelStart = 0 txtComments.SelLength = Len(txtComments.Text) End Sub Private Sub txtEmail_GotFocus() txtEmail.SelStart = 0 txtEmail.SelLength = Len(txtEmail.Text) End Sub Private Sub txtFirst_GotFocus() txtFirst.SelStart = 0 txtFirst.SelLength = Len(txtFirst.Text) End Sub Private Sub txtLast_GotFocus() txtLast.SelStart = 0 txtLast.SelLength = Len(txtLast.Text) End Sub Private Sub txtPhone_GotFocus() txtPhone.SelStart = 0 txtPhone.SelLength = Len(txtPhone.Text) End Sub Private Sub txtState_GotFocus() txtState.SelStart = 0 txtState.SelLength = Len(txtState.Text) End Sub Private Sub txtZip_GotFocus() txtZip.SelStart = 0 txtZip.SelLength = Len(txtZip.Text) End Sub Private Sub txtHp_GotFocus() txtHp.SelStart = 0 txtHp.SelLength = Len(txtHp.Text) End Sub Nb: Buat programm database (table) di MsAccess Field Name Data Type fname Text lname Text address Text city Text

state Text zip Text phone Text hp Text comments Text extra text simpan dan beri nama :AddressDatabase Posted by Administrator in 03:51:07 | Permalink | Comments (1) Shut Down dan Restart dengan VB Membuat Program Shotdown,Restart dan LogOff dengan menggunakan VB Buat 3 buah command dan beri nama command tersebut: cmdLogOff,cmdRestart,cmdShutdown dan ketik source code dibawah ini: Private sub cmdLogOff_Click() Log off windows XP Shell shutdown -l -f -t 0? End sub Private sub cmdRestart_click() shell shutdown -r -f -t 0? end sub Private sub cmdShutdown_click() shell shutdown -s -f -t 0? end sub Posted by Administrator in 03:11:55 | Permalink | Comments Off Friday, February 15, 2008 Belajar Fungsi Label, Text dan command Kita buat 1 buah label, 1 buah text dan 1 buah command dan ketik source code dibawah ini: Private sub command1_click() Me.label1.caption=text1 end sub Posted by Administrator in 07:23:32 | Permalink | Comments Off Membuat Animasi Jam dan Fungsi Timer Sekarang kita belajar membuat animasi jam dan belajar fungsi Timer Buat 1 buah label dan timer dan ketik source code dibawah ini: Private Sub Form_Load() Me.Label1.FontBold = True Me.Label1.FontSize = 24 Me.Timer1.Interval = 1000 End Sub Private Sub Timer1_Timer() Me.Label1.Caption = Format(Now, End Sub Friday, February 15, 2008 hh:mm:ss )

Membuat Animasi Jam Sekarang kita akan belajar membuat animasi jam digital Buat 1 buah label dan timer dan ketik source code dibawah ini Private sub form_load() me.label1.fontbold=true me.label1.fontsize=24 me.timer1.interval=1000 end sub private sub timer_timer() me.label1.caption=format(now, hh:mm:ss ) end sub Posted by Administrator in 06:59:41 | Permalink | Comments Off Visual Basic Script Kita sekarang coba membuat scipt VBS dengan menggunakan Notepad 1. Klik Start | Run | Notepad 2. Tulis script dibawah ini sub script msgbox Ini adalah script pertamaku ,0, Sciprt end sub script 3. Simpan dengan nama script.vbs 4. Lalu jalankan file dengan mengklik 2x Posted by Administrator in 01:49:10 | Permalink | Comments Off Wednesday, February 13, 2008 Langkah Pertama Belajar Visual Basic Mari kita membuat program VB pertama kita: 1. 2. 3. 4. 5. 6. Buat Form1 Simpan file tersebut dengan nama latihan1.frm Buat 1 CommandButton. Label1 Ganti nama Labelnya menjadi Program Pertamaku Ketik Run | Start

nb: Ganti penamaan Label1 menjadi Program Pertamaku caranya sbb: a.Pada Properties pilih caption b. Lalu tulisan Label1 pada caption ganti menjadi Program Pertamaku