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                                              =
==============================