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

MEMBUAT FORM LOGIN DENGAN VB 6.0

======================> ISI MODULE <=====================

Public Conn As New ADODB.Connection

Public RsCari As New ADODB.Recordset

Public mRs As New ADODB.Recordset

Public RsUser As New ADODB.Recordset

Public strConn As String

Public MUser As String

Public MKode As String

Public MOtoritas As String

Public MAlamatFoto As String

Public sQl As String
-------------------------------------------------------------------------------------

Private Sub Main()

Dim Strs As String

Set mRs = New ADODB.Recordset

Strs = "DSN=dsnsimpin"

Set Conn = New ADODB.Connection

Conn.CursorLocation = adUseClient

Conn.Open Strs

FrmLogin.Show

End Sub
-------------------------------------------------------------------------------------

======================> LOGIN ç========================

Option Explicit

Public M_oper As String

Public m_Lokasi As String

Dim ri, gi, bi, Rc, bc, gc, X

==================> MENCARI PASSWORD <=================

Function CariData()

 Dim SQLCari As String

 If RsUser.State = adStateOpen Then RsUser.Close

 RsUser.CursorLocation = adUseClient

 RsUser.Open “ Select * From tbuser Where NmUser = ‘” & TxtKsr.Text & “’ “, Conn, adOpenKeyset, adLockOptimistic

End Function

Private Sub cmdOK_Click()

CariData

==========> MENCARI USER MSH ONLINE / OFFLINE <==========

If Not RsUser.EOF Then

If RsUser!Status = 1 Then

MsgBox “User Sedang OnLine..”, , “Info....”

TxtKsr.SetFocus

Exit Sub

End If

==============> MENCOCOKAN PASSWORD <================

If TxtPassword.Text = RsUser!Password Then

Mutama.Motoritas = RsUser!Otoritas

Mutama.MKsr = TxtKsr.Text

Mutama.Mkode = RsUser!KdUser

Unload Me

Mutama.MalamatFoto = App.Path + “\Foto”

       

==================> UPDATE STATUS <======================

Conn.Execute “update tbuser set status=1 where KdUser=’” & Mutama.Mkode & “’”

FrmMenu.Show

Else

MsgBox “Pwd Salah .... , Coba lagi!”, , “Login”

TxtPassword.Text = “”

TxtPassword.SetFocus

End If

End If

End Sub

Private Sub Form_Load()

Set RsUser = New ADODB.Recordset

RsUser.CursorLocation = adUseClient

 Dim Mpath As String

Mpath = “C:\Windows\system\mysis.sys”

On Error Resume Next

If Dir(Mpath, vbNormal Or vbReadOnly Or vbHidden Or vbSystem Or vbArchive) = “” Then

Unload Me

End If

End Sub

Private Sub TxtUser_KeyPress(KeyAscii As Integer)

KeyAscii = Asc(Ucase(Chr(KeyAscii))) ==è MENGUBAH HURUF MJD BESAR

If KeyAscii = 13 Then

CmdOk.Enabled = False

CariData

==========> MENCARI USER MSH ONLINE / OFFLINE <===========

If Not RsUser.EOF Then

If RsUser!Status = 1 Then

MsgBox “User Sedang OnLine..”, , “Info....”

TxtUser.SetFocus

Exit Sub

End If

                                RsUser.Close

                                TxtPassword.SetFocus

                Else

                                MsgBox “Data User tidak ditemukan”, , “Info....”

                                RsUser.Close

                                TxtUser.Text = “”

TxtUser.SetFocus

                 End If

End If

End Sub

Sup Bayi Manusia Di China Dan Proses Pembuatannya

 Aneh Tapi Nyata

Sebetulnya informasi ini sudah lama sih dan sebagian dari kalian pasti sudah pada tau. Buat yang belum tau, sekarang deh saya kasi tau yaa
Kalau sup buntut, sup kikil, sip kambing, sup ayam, sup jagung.. Wajar dan sudah biasalah kita dengan sehari-hari. Sup kelinci, sup ular, sup kuda, sup kalajengking, yaa… walaupun aneh tapi masih sanggup di terima mata dan telinga. Tapi, kalau Sup Bayi Manusia ? Jangan bilang aneh, di China Sup Bayi Manusia bukanlah hal yang aneh.
Manusia yang dibilang sebagai mahluk paling mulia dan paling tinggi derajatnya, tapi ternyata ada juga yang tidak mempunyai hati nurani. Bahkan melebihi binatang.

Di China, gosipnya kaldu dari janin/orok/bayi manusia dapan menambah kekuatan dan stamina tubuh pria. Bahkan karena itu, di China, Sup Bayi Manusia ini diberi nama “Healthy Soup”. Seakan-akan Sup yang terbuat dari janin bayi manusia berumur 6–8 bulan ini adalah halal.
Menurut testimoni dari salah seorang pengusaha pemilik pabrik di daerah Tong Wan, Taiwan, berumur 62 tahun yang mengaku sebagai pengkonsumsi tetap “Healthy Soup”, menjelaskan khasiat “Healthy Soup” ini dapat mempertahankan kemampuannya untuk dapat berhubungan seks beberapa kali dalam semalam. Wew…
Pengusaha itu tidak menyebutkan berapa harga belinya. Hanya saja dia bilang harga tergantung besar kecilnya bayi, serta bayi hidup atau mati dan sebagainya.
Salah satu restoran yang menyediakan “Healthy Soup” ada di kota Fu San-Canton. Dan jika ingin memesan “Healthy Soup” tersebut di restoran tersebut harus menggunakan kata sandi BAIKUT.
Kabarnya, bahan makanan “Healthy Soup” ini disajikan secara fresh, bukan frozen. Yang artinya, benar-benar bayi yang baru di aborsikan…. Yaiks…. Selain menggunakan bayo sebagai bahan sup, restoran ini juga menyediakanari-ari bayi (plasenta) sebagai bahan sup, yang dipercaya dapat meningkatkan gairah seksual dan juga obat awet muda.
Cara pembuatan “Healthy Soup”

Gambar diatas adalah salah satu janin yang siap dijadikan santapan “Healthy Soup”. Janin yang berumur 5 bulan tersebut, setelah dicuci, di taruh diatas papan potong. Bumbu-bumbu seperti Pachan, Tongseng, Tongkui, Keichi, Jahe, daging ayam dan Baikut, sudah disiapkan. Dan kalian lihat sendiri saja di gambar itu bagaimana prosesnya.

Menurut beberapa sumber lainnya, janin yang dikonsumsi sebagai “Healthy Soup” itu, semuanya adalah janin bayi perempuan. Apakah ini merupakan akibat kebijaksanaan pemerintah China untuk mewajibkan satu anak dalam satu keluarga yg berlaku sampai sekarang atau hanya karena kegemaran orang akan makanan sehat sudah mencapai kondisi yang sangat terkutuk. Yang jelas tindakan ini adalah tindakan tidak beradab.

Contoh Surat Lamaran Pekerjaan

                                                                                  Purwokerto, 09 Januari 2011

Kepada Yth,

PT. DURORINDO SURYA GEMILANG

Di tempat,

Dengan hormat,

Sebagai aktualisasi diri atas keterampilan dan pengetahuan yang saya miliki, saya mengajukan permohonan untuk menjadi salah satu karyawan di perusahaan Bapak. Bersama ini saya lampirkan beberapa berkas sebagai bahan pertimbangan lebih lanjut.

Besar harapan saya bisa menjadi bagian dari komunitas di perusahaan Bapak. Hanya dengan dedikasi tinggi, saya yakin bisa bekerja dengan baik di perusahaan Bapak dan pantang menyerah adalah prinsip hidup yang saya yakini. Semoga perusahaan Bapak selalu sukses ke depan. 

 

                                                                                           Hormat saya,



                                                                                           MIFTAHUDDIN
                                                                                        (Kandidat karyawan)

Lampiran : 

1. Foto berwarna ukuran 3x4
2. Foto Copy KTP
3. Foto Copy Keterangan Sehat
4. Foto Copy SKCK
5. Fotocopy IJAZAH
6. Fotocopy Transkrip Nila
7. Daftar Riwayat Hidup
8. Surat Rekomendasi