MEMBUAT NOMOR URUT OTOMATIS

 =============================================================
 Nomor Urut Berdasarkan Bulan dan Hari
 =============================================================

Dim Mnotrans As String
    Dim mNourut, Mbulan, Mday As String
    Mbulan = CStr(Month(Now))
    Mday = CStr(Day(Now))
    Mday = IIf(Len(Mday) = 1, "0" + Mday, Mday)
    Mnotrans = CStr(Year(Now)) + IIf(Len(Mbulan) = 1, "0" + Mbulan, Mbulan) + Mday
   
    Set RsCari = New ADODB.Recordset
    If RsCari.State = adStateOpen Then RsCari.Close
    RsCari.Open "select * from tbangsuran where notrans like '" & Mnotrans & "%' order by notrans", Conn, adOpenKeyset, adLockOptimistic
    If RsCari.RecordCount > 0 Then
       RsCari.MoveLast
       mNourut = CStr(Val(Right(RsCari!Notrans, 4)) + 1)
       Mnotrans = Mnotrans + IIf(Len(mNourut) = 1, "000" + mNourut, "" _
                  & IIf(Len(mNourut) = 2, "00" + mNourut, IIf(Len(mNourut) = 3, "0" + mNourut, mNourut)))
      Else
       Mnotrans = Mnotrans + MUtama.MKode + "01"
    End If
    TxtNoTrans.Text = Mnotrans
    TxtNoRek.SetFocus

==============================================================
Nomor Urut Berdasarkan Kode
==============================================================

Dim MBKd As String
Dim MNoUrut As String
Dim MOpen As ADODB.Recordset
Dim SQLCari As String

Set MOpen = New ADODB.Recordset
    If MOpen.State = adStateOpen Then MOpen.Close
    MOpen.Open "select * from tbjenis where kddept='" & TxtBKd.Text & "' order by kddept", Conn, adOpenKeyset, adLockOptimistic
    MBKd = MOpen!kddept + "."
    'MsgBox MBKd
    MNoUrut = MBKd

Set RsCari = New ADODB.Recordset
    If RsCari.State = adStateOpen Then RsCari.Close
    RsCari.Open "select * from tbbrg where Bkd like '" & TxtBKd.Text & "%' order by BKd", Conn, adOpenKeyset, adLockOptimistic
    If RsCari.RecordCount > 0 Then
       RsCari.MoveLast
       MNoUrut = CStr(Val(Right(RsCari!bkd, 4)) + 1)
       MBKd = MBKd + IIf(Len(MNoUrut) = 1, "000" + MNoUrut, "" _
            & IIf(Len(MNoUrut) = 2, "00" + MNoUrut, IIf(Len(MNoUrut) = 3, "0" + MNoUrut, MNoUrut)))
    ElseIf RsCari.RecordCount = 1 Then
        MsgBox "Kode Barang sudah ada!!!"
        TxtBKd.SetFocus
    Else
        MBKd = MBKd + "0001"
    End If
    TxtBKd.Text = MBKd

MEMBUAT KARAKTER PASSWORD

============================================================
Contoh From Karakter Password
============================================================


============================================================
Coding di From Password
============================================================
Dim rspwd As ADODB.Recordset

Function CariData()
    Dim SQLCari As String
    If rspwd.State = adStateOpen Then rspwd.Close
    rspwd.CursorLocation = adUseClient
    rspwd.Open " Select * From tbpwd Where password = '" & TxtPwdLama.Text & "' ", Conn, adOpenKeyset, adLockOptimistic
End Function


Private Sub Form_Activate()
    TxtPwdLama.SetFocus
End Sub

Private Sub Form_Load()
    Skn.LoadSkin App.Path + "\skin\new.skn"
    Skn.ApplySkin Me.hwnd
    Set rspwd = New ADODB.Recordset
    rspwd.CursorLocation = adUseClient
End Sub



Private Sub Frame1_Click()
    Unload Me
End Sub


Private Sub TxtPwdBaru_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then
        TxtPwdUlang.SetFocus
    End If
End Sub

Private Sub TxtPwdLama_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then
        CariData
        If rspwd.EOF Then
            MsgBox "Password Tidak Cocok....", vbCritical, "Error...."
            rspwd.Close
            TxtPwdLama.Text = ""
            TxtPwdLama.SetFocus
        Else
            TxtPwdBaru.SetFocus
        End If
    End If
End Sub



Private Sub TxtPwdUlang_KeyPress(KeyAscii As Integer)
Dim jawaban As Integer
    If KeyAscii = 13 Then
        If TxtPwdBaru.Text = TxtPwdUlang.Text Then
            MsgBox "Password Berhasil Diganti"
            Conn.Execute "update tbpwd set Password='" & TxtPwdBaru & "' where " _
            & "'" & TxtPwdBaru.Text & "' = '" & TxtPwdUlang.Text & "'"
           
            Unload Me
        Else
            MsgBox "Password Baru Tidak Sesuai", vbCritical, "Error!!!"
            TxtPwdUlang.Text = ""
            TxtPwdUlang.SetFocus
        End If
    End If
End Sub

Private Sub XPFrame1_Click()
Unload Me
End Sub

MEMBUAT TAMPILAN SKIN dan BACKGROUND

===========================================================
 Coding di Form Menu
 ===========================================================

Dim Addres As String

Private Sub Form_Load()
    Addres = App.Path + "\Backgrounds"
    On Error Resume Next
    ImgBackGound.Picture = LoadPicture(Addres + "\Background.jpg")
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    MnExit_Click
End Sub

Private Sub MnCariB_Click()
  On Error GoTo 1
    Kill App.Path & "foto.jpg"
    DoEvents
1
    On Error Resume Next
  
    cDialog.Filter = "jpg|*.jpg"
    cDialog.ShowOpen
    ImgBackGound = LoadPicture(cDialog.filename)
    SavePicture ImgBackGound.Picture, (Addres + "\Background.jpg")
    Exit Sub
salah:
    MsgBox "Format gambar tidak sesuai" & vbCrLf & "" _
    & "Silakan pilih gambar dengan format GIF,BMP atau JPG", vbCritical, "Proses Pending"
End Sub

Private Sub MnCariS_Click()
    Dim filename As String
    filename = ShowFileDialog
    If filename <> "" Then
        Skn.LoadSkin filename
        Skn.ApplySkin Me.hwnd
    End If
End Sub

Private Sub MnChizh_Click()
If MnChizh.Checked = False Then
    Skn.RemoveSkin (Me.hwnd)
    Skn.LoadSkin App.Path + "\skin\chizh.skn"
    Skn.ApplySkin Me.hwnd
    Skn.SaveSkin App.Path + "\skin\new.skn"
    Sky
    MnChizh.Checked = True
End If
End Sub

Private Sub MnExit_Click()
Dim jawaban As Integer
    jawaban = MsgBox("Apa Anda yakin akan keluar???", vbYesNo + vbQuestion, "Peringatan!!!")
    If jawaban = vbYes Then
    Conn.Execute "update tbuser set status=0 where KdUser='" & MUtama.MKode & "'"
    End
    End If
End Sub

Private Sub MnGalaxy_Click()
If MnGalaxy.Checked = False Then
    Skn.RemoveSkin (Me.hwnd)
    Skn.LoadSkin App.Path + "\skin\GALAXY.skn"
    Skn.ApplySkin Me.hwnd
    Skn.SaveSkin App.Path + "\skin\new.skn"
    Sky
    MnGalaxy.Checked = True
End If
End Sub

Private Sub MnGreen_Click()
If MnGreen.Checked = False Then
    Skn.RemoveSkin (Me.hwnd)
    Skn.LoadSkin App.Path + "\skin\GREEN.skn"
    Skn.ApplySkin Me.hwnd
    Skn.SaveSkin App.Path + "\skin\new.skn"
    Sky
    MnGreen.Checked = True
End If
End Sub

Private Sub MnMedia_Click()
If MnMedia.Checked = False Then
    Skn.RemoveSkin (Me.hwnd)
    Skn.LoadSkin App.Path + "\skin\MEDIA.skn"
    Skn.ApplySkin Me.hwnd
    Skn.SaveSkin App.Path + "\skin\new.skn"
    Sky
    MnMedia.Checked = True
End If
End Sub

Private Sub MnMetallic_Click()
If MnMetallic.Checked = False Then
    Skn.RemoveSkin (Me.hwnd)
    Skn.LoadSkin App.Path + "\skin\METALLIC.skn"
    Skn.ApplySkin Me.hwnd
    Skn.SaveSkin App.Path + "\skin\new.skn"
    Sky
    MnMetallic.Checked = True
End If
End Sub

Private Sub MnPaper_Click()
If MnPaper.Checked = False Then
    Skn.RemoveSkin (Me.hwnd)
    Skn.LoadSkin App.Path + "\skin\PAPER.skn"
    Skn.ApplySkin Me.hwnd
    Skn.SaveSkin App.Path + "\skin\new.skn"
    Sky
    MnPaper.Checked = True
End If
End Sub

Private Sub MnPwd_Click()
frmPwd.Show 1
End Sub

Private Sub MnSmart_Click()
    ImgBackGound.Picture = LoadPicture(Addres + "\mahirSmart.jpg")
    SavePicture ImgBackGound.Picture, (Addres + "\Background.jpg")
End Sub

Private Sub MnStatus_Click()
FrmStatus.Show 1
End Sub

Private Sub Sky()
    MnStudio.Checked = False
    MnChizh.Checked = False
    MnGalaxy.Checked = False
    MnGreen.Checked = False
    MnMedia.Checked = False
    MnMetallic.Checked = False
    MnPaper.Checked = False
    MnTopSecret.Checked = False
    MnWeb.Checked = False
    MnWina.Checked = False
    MnZelezo.Checked = False
End Sub

Private Sub MnStudio_Click()
If MnStudio.Checked = False Then
    Skn.RemoveSkin (Me.hwnd)
    Skn.LoadSkin App.Path + "\skin\B-Studio.skn"
    Skn.SaveSkin App.Path + "\skin\new.skn"
    Skn.ApplySkin Me.hwnd
    Sky
    MnStudio.Checked = True
End If

End Sub

Private Sub MnTopSecret_Click()
If MnTopSecret.Checked = False Then
    Skn.RemoveSkin (Me.hwnd)
    Skn.LoadSkin App.Path + "\skin\TOPSECRET.skn"
    Skn.ApplySkin Me.hwnd
    Skn.SaveSkin App.Path + "\skin\new.skn"
    Sky
    MnTopSecret.Checked = True
End If
End Sub

Private Sub MnUser_Click()
frmKar.Show 1
End Sub

Private Sub MnWeb_Click()
If MnWeb.Checked = False Then
    Skn.LoadSkin App.Path + "\skin\WEB-II.skn"
    Skn.ApplySkin Me.hwnd
    Skn.SaveSkin App.Path + "\skin\new.skn"
    Sky
    MnWeb.Checked = True
End If
End Sub

Private Sub MnWina_Click()
If MnWina.Checked = False Then
    Skn.LoadSkin App.Path + "\skin\WINAQUA.skn"
    Skn.ApplySkin Me.hwnd
    Skn.SaveSkin App.Path + "\skin\new.skn"
    Sky
    MnWina.Checked = True
End If
End Sub

Private Sub MnZelezo_Click()
If MnZelezo.Checked = False Then
    Skn.LoadSkin App.Path + "\skin\ZHELEZO.skn"
    Skn.ApplySkin Me.hwnd
    Skn.SaveSkin App.Path + "\skin\new.skn"
    Sky
    MnZelezo.Checked = True
End If
End Sub
============================================================
Coding di Form Lain
============================================================
Private Sub Form_Load()
    Skn.LoadSkin App.Path + "\skin\new.skn"
    Skn.ApplySkin Me.hwnd
End Sub   









============================================================



Contoh Form Menu