POST, Analise dan Share Code di sini - VBers

[positive+]

Tweet

Gmana kalo thread ini jd code bank vb di chip forums ??
POST, Analise dan Share Code di sini

[positive+]

Tweet

ChangeDatabasePassword
Database Utility - Ms. Access Database
Ms. ADO 2.5 Ref

Full Source Code :

Option Explicit

Const NL = vbNewLine
Dim Con As Connection

Function file_exist(iFile As String) As Boolean
Dim a As String
    file_exist = False
    a = Len(Dir(iFile, 0 Or 1 Or 2 Or 32))
    If a > 0 Then file_exist = True
End Function
Function secure(iText As String) As String
    iText = Trim(iText)
    secure = Replace(Replace(iText, "'", "`"), "[", "")
End Function
Function Change_Pass(Dbpath As String, _
                     OldPass As String, _
                     NewPass As String) As Boolean
On Error GoTo Junk
Dim mProv As String, mSql As String
    Change_Pass = False
    If file_exist(Dbpath) = True Then
       mProv = "provider=microsoft.jet.oledb.4.0;Data Source=" & Dbpath
       mSql = "alter database password " & NewPass & " " & OldPass
       Set Con = New Connection
       Con.Mode = adModeShareExclusive
       Con.Open mProv & ";Jet OLEDB:Database Password=" & OldPass & ";"
       Con.Execute mSql
       Con.Close
       Set Con = Nothing
       Change_Pass = True
       Exit Function
    Else
       MsgBox "Database file not found at : " & NL & _
              Dbpath & NL & "Please check the path again", 0 + 64, "File Not Found"
       Exit Function
    End If
Junk:
    If Err.Number <> 0 Then
       MsgBox Err.Description, 0 + 48, "Err Found"
       Set Con = Nothing
       Exit Function
    End If
End Function
Private Sub Form_Load()
    Move (Screen.Width - Width) / 2, (Screen.Height - Height) / 3
    tNew.TabIndex = 0
End Sub
Private Sub cBatal_Click()
    Unload Me
    Set Form1 = Nothing
End Sub
Private Sub cUbah_Click()
Dim sPath As String, sNew As String, sOld As String, ok As Boolean
    sPath = App.Path & "\" & "Test.mdb"
    sNew = secure(tNew.Text)
    sOld = secure(tOld.Text)
    ok = Change_Pass(sPath, sOld, sNew)
    If ok = True Then
       MsgBox "Changes Succeeded ... ", 0 + 64, "Succeeded"
    End If
End Sub

[positive+]

Tweet

DatabaseTips
Menampilkan Record - Undocumented Recordset Property
same functionality with Fields Value Property but more faster

code

Dim Rs As New Recordset
Rs.Open "select * from Publishers;", Con, 1, 2
'/ ref. dengan index column
mvar = Rs.Collect(1)
'/ ref. dengan nama column
mvar = Rs.Collect("Name")

[Harno]

Tweet

TextBox tip.....
clear textbox on form.....

For Each cntl In Form1
    If TypeOf cntl Is TextBox Then cntl.Text = ""
Next

[Harno]

Tweet

Blinking label....

Dim lBlink as Boolean

Private Sub Timer1_Timer()

Label1.Visible = lBlink

Timer1.Interval = 500
   If Label1.Visible = False Then
   lBlink = True 
     Else
   Label1.Visible = True
   lBlink = False
   End If

End Sub

maap masi dalam tahap belajar.... mohon bimbingannya......

[positive+]

Tweet

InputOnlyNumber
Block user input utk selain angka

Dengan menggunakan Function

'// No Message appear to user, but they will know what should they do
'// bila ingin user tidak dapat meng-inputkan angka, jgn beri pesan apa2
'// Just Block it ... ;) 
Function BLOCK_KEY(sAscii As Integer) As Integer
    Select Case sAscii
           Case 13
                BLOCK_KEY = sAscii '/ perbolehkan {ENTER}
           Case 32
                BLOCK_KEY = sAscii '/ perbolehkan {SPACE}
           Case 8
                BLOCK_KEY = sAscii '/ perbolehkan {BACKSPACE}
           Case 44
                BLOCK_KEY = sAscii '/ perbolehkan {,} Comma
           Case 46
                BLOCK_KEY = sAscii '/ perbolehkan {.} Titik
           Case 48 To 57
                BLOCK_KEY = sAscii '/ perbolehkan {NUMBER}
           Case Else
                BLOCK_KEY = 0      '/ Selain dr kriteria di atas block input
    End Select
End Function

Private Sub Text1_KeyPress(KeyAscii As Integer)
'// cara penggunaan - usage
    KeyAscii = BLOCK_KEY(KeyAscii)
End Sub

Dengan menggunakan IsNumeric Function

'// ini akan sll menampilkan Pesan ke user utk menginputkan angka
'// this is do the job, but not user friendly ... thought ;) 
Private Sub Text1_KeyPress(KeyAscii As Integer)
    If Not IsNumeric(Chr$(KeyAscii)) = True Then
       MsgBox "Please input numerical values", 0 + 48, "Message"
       KeyAscii = 0
    End If
End Sub

[positive+]

Tweet

DateManipulation

Option Explicit

Const NL = vbNewLine
'// Now --> Current system time
Private Sub Command1_Click()
Dim Buffer As String
    Buffer = Buffer & "Short date -> " & Format(Now, "short date") & NL
    Buffer = Buffer & "Long Date -> " & Format(Now, "long date") & NL
    Buffer = Buffer & "Medium Date -> " & Format(Now, "medium date") & NL
    Buffer = Buffer & "Year -> " & Year(Now) & NL
    Buffer = Buffer & "Month -> " & Month(Now) & NL
    Buffer = Buffer & "Day -> " & Day(Now) & NL
    Buffer = Buffer & "Month in Long Date Format -> " & Format(Now, "mmmm") & NL
    Buffer = Buffer & "Day in Long Date Format -> " & Format(Now, "dddd")
    MsgBox Buffer
End Sub

[positive+]

Tweet

Hi Harno, mari kita analise code kamu yg ini ( please, no offence )

Private Sub Timer1_Timer()
'// ini tidak akan pernah di-eksekusi, bila property Interval Timer pd waktu design _
    tetap pada 0
 
   Label1.Visible = lBlink
   '// bila ingin Timer Interval tetap pd 500 ( 0.5 detik )
   Timer1.Interval = 500 '// mengapa ini hrs selalu di-update ?? bukankah lebih baik ditetapkan lgs pd saat design ??
   '// bila ingin Timer Interval di atur dlm coding, Tempatkan -> Timer1.Interval = 500 <- pd event Form_Load
   If Label1.Visible = False Then
      lBlink = True
   Else
      'Label1.Visible = True <-- NOW WE REMOVE THIS LINE
      '// yg kita lakukan hanya update True/False dari var. Boolean lBlink
      '// dgn bgt ini akan sll di-eksekusi oleh line ini -> Label1.Visible = lBlink
      lBlink = False
   End If
   
End Sub

Now, i would prefer to do this

Option Explicit

Dim lBlink As Boolean

Private Sub Form_Load()
    Timer1.Interval = 500 '// set interval ( 0.5 detik )
End Sub
Private Sub Timer1_Timer()
   lBlink = Not lBlink '// update Boolean Value for this Varible tiap 0.5 detik
   Label1.Visible = lBlink
End Sub

Happy coding ...

[positive+]

Tweet

SHELLFUNCTION: Menjalankan executable program - basic usage

sample code

Private Sub Command1_Click()
    Shell "explorer", vbNormalFocus '// jalankan Explorer
    Shell "explorer C:\", vbNormalFocus '// jalankan Explorer dgn memberi parameter path C:\
    Shell "explorer mailto:", vbNormalFocus '// email
    Shell "cmd", vbNormalFocus '// command prompt
    Shell "control", vbNormalFocus '// control panel
End Sub

[positive+]

Tweet

FileManipulation
Read File Content - Noobs

Option Explicit

'Form dgn sebuah Textbox ( Set property Multiline = True,Scrollbar = 2 - Vertical _
 dan sebuah CommandButton

Enum OpenType
     ByAscii
     ByBinary
End Enum

Function OpenFile(mFile As String, iType As OpenType, Obj As TextBox)
'Description : Read File contents _
 mFile       : File Path yang akan dibaca _
 iType       : Tipe Pembacaan ( Ascii / Binary ) _
 Obj         : ByRef Parameter, Isikan dgn nama dr object
Dim iContent As String, buff As String
    If mFile = "" Then Exit Function
    Select Case iType
           Case ByAscii
                Open mFile For Input As #1
                     Do Until EOF(1) '// loop s/d end of file
                        Line Input #1, buff '// fill buffer
                        iContent = iContent & buff
                     Loop
                Close #1
                Obj.Text = iContent '// show result
           Case ByBinary
                Open mFile For Binary Access Read As #1
                     iContent = Space(Fix(LOF(1))) '// create space buffer
                     Get #1, , iContent '// get contents of file
                Close #1
                Obj.Text = iContent '// show result
    End Select
End Function
Private Sub Command1_Click()
'Usage :
     OpenFile "C:\Logfile.txt", ByBinary, Text1
End Sub