Rabu, 07 April 2010

2

[VBS] Membuat Program Command Line Dengan VBS

  • Rabu, 07 April 2010
  • Nurkholish Ardi Firdaus
  • Share
  • Ok, dengan jerih payah, akhirnya q mmbt script ini,he3 idenya adlh membuat sbuah script yang akan bekerja seperti Command Prompt. Ya udah kalo ada yang minat, tinggal copy aja lalu simpen sbg script VBS (.vbs). Ok cuy!!!!!!!!!!!!!!
    Script akan bekerja hampir sama seperti program cmd, namun tidak selengkap cmd. semoga bermanfaat.










    Ok, dengan jerih payah, akhirnya q mmbt script ini,he3 idenya adlh membuat sbuah script yang akan bekerja seperti Command Prompt. Ya udah kalo ada yang minat, tinggal copy aja lalu simpen sbg script VBS (.vbs). Ok cuy!!!!!!!!!!!!!!
    Script akan bekerja hampir sama seperti program cmd, namun tidak selengkap cmd. semoga bermanfaat.



    '+-----------------------------------------+
    '
    ' CROWJA CONSOLE v1.0
    ' CODED BY NURKHOLISH ARDI F.
    ' EMAIL: [email protected]
    ' GO OPEN SOURCE!
    '
    '+-----------------------------------------+


    '###########################################
    '################ MAIN CODE ################
    '###########################################



    Option Explicit
    Dim COM
    Dim Wshell
    Dim FSO
    Dim curr_dir
    Dim line_currdir
    Const BOOLYES=True
    Set Wshell=createobject("Wscript.Shell")
    Set FSO=CreateObject("Scripting.FileSystemObject")
    Set curr_dir=FSO.GetFolder("C:\") 'set home path
    Do Until UCASE(COM)="EXIT" Or UCASE(COM)="EXIT!" 'loop sampai inputbox perintah=exit atau exit!
    If Len(curr_dir)>39 then
    get_cmprs
    Else
    line_currdir=Cstr(curr_dir)
    End If
    COM=Inputbox(line_currdir&">>"&vbnewline&""&vbnewline&""&vbnewline&""_
    &vbnewline&""&vbnewline&"Type help for show help",Window_Title(1))
    If Right(COM,1)=" " then 'Branching jika krakter trkhr COM adlh " "
    Dim loop_com
    For loop_com=Len(COM) to 1 step -1
    If mid(COM,loop_com,1) <> " " then
    COM=Left(COM,loop_com)
    Exit For
    End If
    Next
    End If
    Select Case UCASE(COM)
    Case "CD"
    Dim cd_com
    cd_com=InputBox("SELECT DIR------>"&vbnewline&Dir_List,window_title(14)) 'input akan pndah ke dir mana
    cd(cd_com)
    Case "CD\"
    If len(curr_dir)=3 And mid(curr_dir,2,1)=":" then
    Msgbox "You are current working in root directory",16,"@Root directory"
    Else
    Set curr_dir=curr_dir.Drive.RootFolder 'set curr_dir as curr_dir root folder
    End If
    Case "HOME"
    Set curr_dir=FSO.GetFolder("C:\")
    Case "EXIT"
    Dim ask
    ask=msgbox("Quit From Console",36,window_title(2))
    If ask=vbyes then
    Msgbox "Console Terminated",,"++++++++++"
    Wscript.Quit
    Else
    COM="" 'set var COM <> "EXIT",, krn jka COM="EXIT" maka konsole akan terminasi
    End If
    Case ""
    Dim zero
    zero=msgbox("Quit From Console",36,Window_title(2))
    If zero=vbyes then
    Msgbox "Console Terminated",,"++++++++++"
    Wscript.Quit
    Else
    COM="" 'set var COM <> "EXIT",, krn jka COM="EXIT" maka konsole akan terminasi
    End If
    Case "DIRTREE"
    tree
    Case "SWITCH"
    shost(host())
    Case "DELD"
    Dim dir_del
    dir_del=InputBox("Folder List :"&VbnewLine&"-----------------"&VbNewLine&Dir_List&vbnewline&"Type Folder Name U Want To Delete :"_
    ,window_title(12)) 'inputbox mau dlete folder apa
    Select Case UCASE(dir_del) 'case what u want 2 del
    Case "*" 'jka brupa wildcard,maka ini akan mnghps smua dir
    deld(all) 'call sub deld with all parameter
    Case "" 'do nothing and back if user do nothing
    Case Else 'case lain
    deld(dir_del) 'call sub deld with var dir_del as parameter
    End Select
    Case "DELF"
    Dim file_del
    file_del=InputBox("File List :"&VbnewLine&"---------------"&VbNewLine&File_List&VbNewLine&"Type File Name U Want To Delete :",window_title(13))
    Select Case UCASE(file_del) 'case what u want 2 del
    Case "*"
    delf(all)
    Case "" 'do nothing and back if user do nothing
    Case Else
    delf(file_del)
    End Select
    Case "CD.."
    if Len(curr_dir)=3 then
    Msgbox "You are current working in root directory",16,"@Root directory"
    else
    Set curr_dir=curr_dir.ParentFolder
    End if
    Case "TIME"
    Msgbox time,0,window_title(8)
    Case "DATE"
    Msgbox date,0,window_title(9)
    Case "DIRLIST"
    Msgbox "Directory List:"&vbnewline&"-----------------"&vbnewline&Dir_list(),0,"Directory List On "&curr_dir
    Case "FILELIST"
    Msgbox "File List:"&vbnewline&"-----------"&vbnewline&File_list(),0,"File List On "&curr_dir
    Case "DPART"
    msgbox "Available volumes:"&vbnewline&dpart
    Case "CDP"
    Dim CDPartWhere
    CDPartWhere=inputbox("Available volumes:"&vbnewline&dpart&vbnewline&"Type drive letter:",window_title(14))
    cdp(cdpartwhere)
    Case "HELP"
    help
    Case "MD"
    MD(Inputbox("Type new folder name","Create new folder"))
    Case "HOST"
    Msgbox "This script running on "&host(),0,"Script Host"
    Case "CPF"
    Dim what
    Dim where
    what=Inputbox("File List:"&vbnewline&"-----------"&vbnewline&File_list()&vbnewline&""&vbnewline&"Type filename you want to copy","Copy File")
    If what="" Then 'klo user tdk mngapa2kan inputbox select file maka
    'do nothing
    Elseif what="*" then 'jka user mmsukan wildcard sbg filename
    cpf "all",inputbox("Enter destination folder path")
    Else
    where=inputbox("Enter destination folder path")
    If where="" Then 'jka user do nothing pda inputbox destination dir,maka
    Else
    cpf what,where
    End if
    End If
    Case "EXIT!"
    Wscript.Quit
    Case "OPEN"
    open Inputbox("Enter file name:"&vbnewline&"------------------------"&vbnewline&""&vbnewline&File_list(),"Execute File")
    Case "EXEC"
    exec inputbox("Type program you want to run"&vbnewline&"Example: cmd","Run")
    Case "CMD"
    Dim strCMD,boolDo
    booldo=true
    Do While boolDo
    strCMD=Inputbox("Type Windows CMD Command"&vbnewline&""&vbnewline&""&vbnewline&""_
    &vbnewline&""&vbnewline&"Type help to show CMD help","Windows CMD Command")
    If Ucase(strCMD)="HELP" then
    cmd_help
    ElseIf strCMD="" then
    boolDo=False
    ElseIf UCase(strCMD)="EXIT" Then
    boolDo=False
    Else
    cmd strCMD
    End If
    Loop

    Case "SHUTDOWN"
    shutdown()
    Case "RESTART"
    restart()
    Case "ERROR"
    On Error Goto 0
    err.raise 4693,"stupid_user","coz_user want it!" 'just4fun ;)
    WScript.Quit
    Case "EDITSELF"
    If UCase(Right(Wscript.ScriptFullName,4))=".EXE" Then
    MsgBox "Script was compiled, editing script was imposible when scipt was compiled",vbCritical+vbOKOnly,"[email protected]"
    Else
    Wshell.Run "notepad.exe "&Wscript.ScriptFullName
    End if
    Case "DRIVESTAT"
    drvst("")
    Case "DRIVESSTAT"
    drvst("all")
    Case "BIOSSTAT"
    Dim objBIOS
    Set objBIOS=New objWmiBIOS
    msgbox objBIOS.BIOSstat,vbInformation,"BIOS Statistic"
    Case "PROCINFO"
    Dim objProc
    Set objProc=New objWmiProcessor
    MsgBox objProc.ProcInfo,vbInformation,"Processor Info"
    Case "FWALL"
    scriptingFirewall
    Case "ABOUT"
    about()
    Case Else
    If Len(COM)=2 And Right(COM,1)=":" Then 'jka COM hanya 2 char dan krakter trkhr COM adl ":" maka
    On error resume next
    If FSO.DriveExists(COM) Then 'jika DriveExists COM=BOOLYES maka
    cdp(COM) 'pndah working dir ke drive yang dimaksud
    Else
    msgbox "Drive not exists or ready",16,"Error" 'jka drive tdk ada atau blm siap maka msgbox error mncul
    End If

    Elseif Ucase(Left(COM,3))="CD " Then 'jka diambil 3 krakter dri kiri var COM adl "cd " maka
    If Right(COM,Len(COM)-3)=".." then
    if Len(curr_dir)=3 then
    Msgbox "You are current working in root directory",16,"@Root directory"
    Else
    Set curr_dir=curr_dir.ParentFolder
    End If
    ElseIf Right(COM,1)="\" then
    If len(curr_dir)=3 And mid(curr_dir,2,1)=":" then
    Msgbox "You are current working in root directory",16,"@Root directory"
    Else
    Set curr_dir=curr_dir.Drive.RootFolder 'set curr_dir as curr_dir root folder
    End If
    Else
    cd(Right(COM,Len(COM)-3)) 'pndah dir
    End If
    ElseIf Ucase(Left(COM,5))="DELD " Then 'jka var COM diambil dr kri 5 char adl "deld " maka
    If Right(COM,1)="*" Then
    deld(all)
    Else
    deld(Right(COM,Len(COM)-5))
    End If
    ElseIf Ucase(Left(COM,5))="DELF " then
    If Right(COM,1)="*" Then
    delf(all)
    Else
    delf(Right(COM,Len(COM)-5))
    End If
    Elseif Ucase(Left(COM,3))="MD " then
    md(Right(COM,Len(COM)-3))
    Elseif Ucase(Left(COM,4))="CPF " Then
    Dim nocpf
    Dim getfirst
    Dim getstspc
    Dim getstword
    nocpf=Right(COM,Len(COM)-4) 'mmbuang kakter "cpf " di COM
    For getfirst=1 to len(nocpf) 'looping mndpatkan spasi
    If mid(nocpf,getfirst,1)=" " then
    getstword=Left(nocpf,getfirst-1) 'mndptkan filename dngn cra mngbil (spasi krakter ke berapa-1) karakter dr kiri
    Exit For
    End if
    Next
    If getstword="*" then
    cpf "all",right(nocpf,len(nocpf)-len(getstword)-1)
    ElseIf Instr(getstword,"\")>0 then 'klo ada char \ di source filenya
    cpf_filter getstword,right(nocpf,len(nocpf)-len(getstword)-1)
    Else
    cpf getstword,right(nocpf,len(nocpf)-len(getstword)-1) 'call cpf dgn parameter filenamenya adl getstword,
    'dan prmter destination dir dg cra right(nocpf,len(nocpf)-len(getstword)-1), -1 utk tdk mgikutkan spasi
    End If
    ElseIf Ucase(left(COM,5))="EXEC " then
    exec Right(COM,Len(COM)-5)
    ElseIf Ucase(Left(COM,4))="CMD " then
    If UCASE(right(COM,Len(COM)-4))="HELP" then
    cmd_help()
    Else
    cmd right(COM,Len(COM)-4)
    End If
    ElseIf UCase(Left(COM,9))="FILELIST " then
    Dim curr_temp
    curr_temp=FSO.GetFolder(curr_dir)
    If FSO.FolderExists(Ucase(right(COM,Len(COM)-9))) Or FSO.DriveExists(Ucase(right(COM,Len(COM)-9))) Then
    If FSO.FolderExists(Ucase(right(COM,Len(COM)-9))) then
    Set curr_dir=FSO.GetFolder(Ucase(right(COM,Len(COM)-9)))
    Msgbox "File List:"&vbnewline&"-----------"&vbnewline&File_list(),0,"File List On "&curr_dir
    set curr_dir=FSO.GetFolder(curr_temp)
    ElseIf FSO.DriveExists(Ucase(right(COM,Len(COM)-9))) then
    Set curr_dir=FSO.GetFolder(Ucase(right(COM,Len(COM)-9))&"\")
    Msgbox "File List:"&vbnewline&"-----------"&vbnewline&File_list(),0,"File List On "&curr_dir
    set curr_dir=FSO.GetFolder(curr_temp)
    Else
    Err.Raise 6767,"error_on_file_list","error"
    End If
    End If
    ElseIf UCase(Left(COM,10))="DRIVESTAT " Then
    On Error Resume next
    If FSO.DriveExists(Right(COM,Len(COM)-10)) Then
    Dim x
    Set x=New drvstat
    With x
    .Drive=(Right(COM,Len(COM)-10))
    .GetDrive
    End With
    Set x=Nothing
    Else
    MsgBox "Drive not exists or ready!",vbCritical+vbOKOnly,"Error"
    End if
    Else
    Msgbox "Command "&"'"&COM&"'"&" is not recognized",16,window_title(10) 'error command message
    End If
    End select
    Loop



    '######################################################
    '########## SUBROUTINES--FUNCTIONS--CLASSES ###########
    '######################################################



    Function cd(any)
    If Not FSO.FolderExists(curr_dir&"\"&any) then
    Msgbox "Cannot find folder '"&any&"' in "&curr_dir,16,"Error"
    Else
    Set curr_dir=FSO.GetFolder(curr_dir&"\"&any)
    End If
    end function

    Sub tree
    Dim loopFolders
    Dim strTree
    For Each loopFolders In curr_dir.SubFolders 'loop 4 build folder tree
    strTree=strTree&"|"&vbNewLine&"|---> "&Right(loopFolders,(Len(loopFolders)-Len(curr_dir)-fixstr()))&vbNewLine
    Next
    Msgbox curr_dir&vbNewline&strTree,0,"Folders Tree"
    End Sub

    Sub deld(any)
    If any="all" then 'jka prntahnya del smua dir maka
    Dim sure
    sure=msgbox("Are you sure you want to delete all folders?",52,window_title(4))
    if sure=vbyes then 'sure 2 del
    For Each loop_del in curr_dir.SubFolders 'loop 2 del 2 folders
    loop_del.Delete BOOLYES
    Next
    msgbox "All folders has been deleted!",48,window_title(11) 'success mnghps dir
    Else
    End If
    Else 'tp jka parameternya bkan del smua dir maka
    If FSO.FolderExists(curr_dir&"\"&any) Then 'cek apakah dir yng dmksd ada, jka y
    If (msgbox("Are you sure you want to delete '"&any&"' ?",36,window_title(4)))=vbyes then 'mau del bner g,,klo y
    FSO.GetFolder(curr_dir&"\"&any).Delete BOOLYES
    msgbox "Folder has been deleted",48,window_title(11)
    Else 'klo g
    'do nothing
    End If
    Else
    Msgbox "Folder '"&any&"' not found",37 'jka dir yg dmksd g ada
    End If
    End If
    End Sub

    Function FixStr 'Function akan mengecek apakah ada tanda "\" di akhir curr_dir
    If Right(curr_dir,1)<>"\" Then
    fixStr=1 'mnmbhkan -1 jka tdk ada, hal ini dlakukan utk mbangun folder list
    Else
    fixstr=0 'mnmbahkan -0 jka ada
    End if
    End function

    Sub delf(any)
    Dim loop_del
    If any="*" Then
    Dim sure
    sure=msgbox("Are you sure you want to delete all files?",52)
    if sure=vbyes then 'sure 2 del
    For Each loop_del in curr_dir.Files 'loop 2 del 2 files
    loop_del.Delete BOOLYES
    Next
    msgbox "All files has been deleted!",48
    Else
    'do nothing
    End if
    ElseIf any="" Then 'do nothing and back if user do nothing
    Else
    If FSO.FileExists(curr_dir&"\"&any) Then
    If (msgbox("Are you sure you want to delete '"&any&"' ?",52,"Confirm Delete"))=vbyes then ',w del bner g,,klo y
    FSO.GetFile(curr_dir&"\"&any).Delete BOOLYES
    msgbox "File has been deleted",48,"Success"
    Else
    Msgbox "File not found!",16,"Error"
    End If
    End If
    End If
    End Sub

    Function File_List
    Dim loopFiles
    Dim strList
    For Each loopFiles In curr_dir.Files 'loop 2 build file list
    strList=strList&"- "&Right(loopFiles,Len(loopFiles)-Len(curr_dir)-fixstr())&vbnewline 'fixstr() utk mngmbalikan nilai 1 jka tak ada tnda \ di akhir str curr_dir
    Next 'dan akan mngmbalikan nilai 0 jka ada tnda \ d akhir str curr_dir
    if strList="" Then
    strList=""&vbnewline&"* There is no file *"&vbnewline&""&vbnewline&""&vbnewline 'vbnewline 3 kali, maksudnya agar string "Type*" mndkati bar inputbox,vb newline 1 kali di awal agar str "*There is no file*" brada di tngah
    End If
    File_List=strList
    End Function

    Function Dir_List
    Dim loopFolders
    Dim strList
    For Each loopFolders In curr_dir.SubFolders 'loop 2 build folder list
    strList=strList&"- "&Right(LoopFolders,Len(LoopFolders)-Len(curr_dir)-fixstr())&vbnewline 'fixstr() utk mngmbalikan nilai 1 jka tak ada tnda \ di akhir str curr_dir
    Next 'dan akan mngmbalikan nilai 0 jka ada tnda \ d akhir str curr_dir
    If strList="" Then
    strList=""&vbnewline&"* There is no folder *"&vbnewline&""&vbnewline&""&vbnewline 'vbnewline 3 kali, maksudnya agar string "Type*" mndkati bar inputbox,vb newline 1 kali di awal agar str "*There is no folder*" berada d tngah
    End If
    Dir_List=strList
    End Function

    Function Window_Title(any) 'Set Window Title
    Dim WT
    Select Case any
    Case 1
    WT="Crowja Console"
    Case 2
    WT="Exit"
    Case 3
    WT="About"
    Case 4
    WT="Confirm Delete"
    Case 5
    WT="File List"
    Case 6
    WT="Directory List"
    Case 7
    WT="Directory Tree"
    Case 8
    WT="Time"
    Case 9
    WT="Date"
    Case 10
    WT="Error"
    Case 11
    WT="Success"
    Case 12
    WT="Delete Folder"
    Case 13
    WT="Delete File"
    Case 14
    WT="Change working directory"
    End Select
    Window_Title=WT
    End Function

    Function dpart
    Dim loopPart
    Dim strPart
    For each loopPart in FSO.Drives
    strPart=strPart&vbnewline&loopPart
    Next
    dpart=strPart
    End function

    Function cdp(any)
    On error resume next
    If FSO.GetDrive(any).Isready And FSO.DriveExists(any) then
    set curr_dir=FSO.GetFolder(any&"\")
    Else
    Msgbox "Drive not exists or ready",16,"Error"
    End If
    End Function

    Sub Help
    Dim strHelp
    strHelp="cd"&vbtab&": Change working directory"&vbnewline&"cd.."&vbtab&": Back to parent directory"&vbnewline&_
    "cd\"&vbtab&": Back to root directory"&vbnewline&"home"&vbtab&": Back to home directory"&vbnewline&_
    "dirtree"&vbtab&": View directory tree"&vbnewline&"dirlist"&vbtab&": View directory list"&vbnewline&"filelist"&vbtab&": View file list"_
    &vbnewline&"deld"&vbtab&": Delete directory (wildcard accepted)"&vbnewline&"delf"&vbtab&": Delete file (wildcard accepted)"_
    &vbnewline&"dpart"&vbtab&": View available volumes"&vbnewline&"cdp"&vbtab&": Change working directory to another drive"_
    &vbnewline&"time"&vbtab&": Show current time"&vbnewline&"date"&vbtab&": View current date"&vbnewline&"exit"&vbtab&": Exit from console"_
    &vbnewline&"cpf"&vbtab&": Copy file"&vbnewline&"md"&vbtab&": Make new folder"&vbnewline&"host"&vbtab&": Show script host name"_
    &vbnewline&"exit!"&vbtab&": Exit now"&vbnewline&"open"&vbtab&": Open any file"&vbnewline&"exec"&vbtab&": Run proram"_
    &vbnewline&"shutdown"&vbtab&": Shutdown PC"&vbnewline&"restart"&vbtab&": Restart PC"_
    &vbnewline&"cmd"&vbtab&": Do Windows CMD command"&vbnewline&"editself"&vbtab&": View and edit source code of this script"_
    &vbnewline&"biosstat"&vbTab&": View BIOS Statistic"&vbnewline&"drivestat"&vbTab&": View drive status"&vbnewline&"drivesstat: View all alvailable drives statistics"_
    &vbnewline&"fwall"&vbTab&": Controlling windows firewall"&vbNewLine&"procinfo"&vbTab&": View proccessor information"_
    &vbnewline&"about"&vbTab&": About Coder"
    msgbox strHelp,0,"Help" 'little bit confusing ;)
    End Sub

    Sub MD(any)
    On error resume next
    If any ="" then
    'do nothing
    Else
    curr_dir.Subfolders.Add any
    If FSO.FolderExists(curr_dir&"\'"&any&"'") then
    Msgbox "Folder '"&any&"' has been created.",0,"Success"
    Else
    Msgbox "Error while creating folder "&any,16,"Error"
    End If
    End If
    End sub

    Function Host
    Dim FullHost
    Dim getslash
    FullHost=Wscript.Fullname
    For getslash = len(FullHost) To 1 step -1
    If Mid(FullHost,getslash,1)="\" Then
    Host=Right(FullHost,len(FullHost)-getslash)
    Exit For
    End If
    Next
    End Function

    Function shost(any)
    Dim shell
    set shell=Wshell
    If Ucase(any)="WSCRIPT.EXE" Then
    shell.run "cmd.exe /c cscript.exe "&Wscript.ScriptFullName
    Else
    shell.run "cmd.exe /c Wscript.exe "&Wscript.ScriptFullName
    End If
    End function

    Sub get_cmprs()
    Dim Y,Z,V,build,loopit,temp
    Y=Len(curr_dir)-Len(curr_dir) mod 39 'bnyaknya kta utama
    Z=Left(curr_dir,Y) 'mndptkan kata utma
    V=Right(curr_dir,Len(curr_dir) mod 39) 'mndptkan sisa kata
    for loopit =1 to (Y/39)-1
    Dim int_lp
    If loopit=1 then
    int_lp=1
    Else
    int_lp=((loopit-1)*39)+1
    End If
    If temp="" then
    temp=mid(Z,int_lp,39) 'trjdi pd loop prtama (mmbngun bris prtama)
    End If
    temp=temp&vbnewline&mid(Z,int_lp+39,39) 'mmbngun baris kedua & strusnya
    Next
    temp=temp&vbnewline&V 'mmbngun bris trkhir yang mrpkan kata sisa
    line_currdir=temp
    End Sub

    Sub open(any)
    If any="" then
    'Do Nothing
    Else
    If FSO.FileExists(curr_dir&"\"&any) then
    Wshell.Run(curr_dir&"\"&any)
    Else
    Msgbox "File not found!",16,Error
    End If
    End If
    End sub

    Sub exec(any)
    On Error Resume Next
    If any="" then
    'Do Nothing
    Else
    Wshell.Run(any)
    End If
    On Error goto 0
    End Sub
    '--------------------------
    Sub cpf(any,where)
    Dim source
    Dim des
    Dim loopFiles
    If Ucase(where)=Ucase(COM) then
    End IF
    des=FSO.FolderExists(where) 'get boolean folder exists
    source=FSO.FileExists(curr_dir&"\"&any) 'get boolean file exists
    If any="all" then 'jka any=all,,maka set var source mnjadi true agar tdk mmnculkan error msg
    source=BOOLYES
    End If
    If source and des then 'jka nilai boolen source dan des adl true
    If any="all" and des <> False then 'jka filenamenya all,dan dir tujuan ada maka copy smua file
    For each loopFiles in curr_dir.Files 'loop mndpatkan obj stiap file
    FSO.CopyFile loopFiles,where,BOOLYES 'copy smua obj file ke parameter where
    Next
    Msgbox "All files in "&curr_dir&" successfully copied to "&where
    ElseIf Ucase(FSO.GetFile(any).ParentFolder)=Ucase(where) then
    cpf_2 any,where
    Else 'tp klo any<>"all"
    if source=false then 'klo var source=false
    Msgbox any&" not found in current working directory",16
    elseif des=false then 'klo destinationnya false
    Msgbox "Path "&where&" not exists",16
    Else 'klo source dan des adl True
    FSO.Getfile(curr_dir&"\"&any).copy where,BOOLYES
    Msgbox any&" successfully copied to "&where
    End if
    End If
    End If
    end sub

    Sub cpf_2(any,where)
    Dim ulang
    dim titik
    dim garing
    dim baru
    for ulang=len(any) to 1 step -1
    If mid(any,ulang,1)="." then
    titik=ulang
    ElseIf mid(any,ulang,1)="\" then
    garing=ulang
    End If
    Next
    baru=Left(any,garing)&mid(any,garing+1,titik-1-garing)&"_copy"&right(any,len(any)-titik+1)
    FSO.CopyFile any,baru,BOOLYES
    End Sub

    Sub cpf_filter(any,where)
    If FSO.FileExists(any) <> False And FSO.FolderExists(where) <> False then
    If Ucase(FSO.GetFile(any).parentfolder)=Ucase(where) then
    cpf_2 any,where
    Else
    cpf_uni any,where
    End If
    Else
    Msgbox "File or destintion doesn't exists",16,"Error"
    End If
    End Sub

    Sub cpf_uni(any,where)
    FSO.CopyFile any,where,BOOLYES
    End Sub

    '----------------------------------

    Sub shutdown()
    If Msgbox("Turn Off PC Now ?",VbYesNo,"ShutOff")=VbYes then
    Wshell.Run "CMD.exe /c shutdown -s -f -t 00"
    wscript.quit
    Else
    'Do nothing
    End If
    End Sub

    Sub restart()
    If Msgbox("Restart PC Now ?",VbYesNo,"Restart")=VbYes then
    Wshell.Run "CMD.exe /c shutdown -s -r -t 00"
    wscript.quit
    Else
    'Do nothing
    End If
    End Sub

    Sub cmd(comd)
    Wshell.Run "cmd.exe /c "&comd

    End Sub


    Sub cmd_help()
    Dim strCmd,strCmd2,strCmd3,strCmd4
    strCmd="ASSOC"&vbtab&vbtab&"Displays or modifies file extension associations."&vbnewline&_
    "AT"&vbtab&vbtab&"Schedules commands and programs to run on a computer."&vbnewline&_
    "ATTRIB"&vbtab&vbtab&"Displays or changes file attributes."&vbnewline&_
    "BREAK"&vbtab&vbtab&"Sets or clears extended CTRL+C checking."&vbnewline&_
    "CACLS"&vbtab&vbtab&"Displays or modifies access control lists (ACLs) of files."&vbnewline&_
    "CALL"&vbtab&vbtab&"Calls one batch program from another."&vbnewline&_
    "CD"&vbtab&vbtab&"Displays the name of or changes the current directory."&vbnewline&_
    "CHCP"&vbtab&vbtab&"Displays or sets the active code page number."&vbnewline&_
    "CHDIR"&vbtab&vbtab&"Displays the name of or changes the current directory."&vbnewline&_
    "CHKDSK"&vbtab&vbtab&"Checks a disk and displays a status report."&vbnewline&_
    "CHKNTFS"&vbtab&vbtab&"Displays or modifies the checking of disk at boot time."&vbnewline&_
    "CLS"&vbtab&vbtab&"Clears the screen."&vbnewline&_
    "CMD"&vbtab&vbtab&"Starts a new instance of the Windows command interpreter."&vbnewline&_
    "COLOR"&vbtab&vbtab&"Sets the default console foreground and background colors."&vbnewline&_
    "COMP"&vbtab&vbtab&"Compares the contents of two files or sets of files."&vbnewline&_
    "COMPACT"&vbtab&"Displays or alters the compression of files on NTFS partitions."&vbnewline&_
    "CONVERT"&vbtab&vbtab&"Converts FAT volumes to NTFS. You cannot convert the current drive."
    strCMD2="COPY"&vbtab&vbtab&"Copies one or more files to another location."&vbnewline&_
    "DATE"&vbtab&vbtab&"Displays or sets the date."&vbnewline&_
    "DEL"&vbtab&vbtab&"Deletes one or more files."&vbnewline&_
    "DIR"&vbtab&vbtab&"Displays a list of files and subdirectories in a directory."&vbnewline&_
    "DISKCOMP"&vbtab&"Compares the contents of two floppy disks."&vbnewline&_
    "DISKCOPY"&vbtab&"Copies the contents of one floppy disk to another."&vbnewline&_
    "DOSKEY"&vbtab&vbtab&"Edits command lines, recalls Windows commands, and creates macros."&vbnewline&_
    "ECHO"&vbtab&vbtab&"Displays messages, or turns command echoing on or off."&vbnewline&_
    "ENDLOCAL"&vbtab&"Ends localization of environment changes in a batch file."&vbnewline&_
    "ERASE"&vbtab&vbtab&"Deletes one or more files."&vbnewline&_
    "EXIT"&vbtab&vbtab&"Quits the CMD.EXE program (command interpreter)."&vbnewline&_
    "FC"&vbtab&vbtab&"Compares two files or sets of files, and displays the differences between them."&vbnewline&_
    "FIND"&vbtab&vbtab&"Searches for a text string in a file or files."&vbnewline&_
    "FINDSTR"&vbtab&vbtab&"Searches for strings in files."&vbnewline&_
    "FOR"&vbtab&vbtab&"Runs a specified command for each file in a set of files."&vbnewline&_
    "FORMAT"&vbtab&vbtab&"Formats a disk for use with Windows."&vbnewline&_
    "FTYPE"&vbtab&vbtab&"Displays or modifies file types used in file extension associations."
    strCMD3="GOTO"&vbtab&vbtab&"Directs the Windows command interpreter to a labeled line in a batch program."&vbnewline&_
    "GRAFTABL"&vbtab&"Enables Windows to display an extended character set in graphics mode."&vbnewline&_
    "HELP"&vbtab&vbtab&"Provides Help information for Windows commands."&vbnewline&_
    "IF"&vbtab&vbtab&"Performs conditional processing in batch programs."&vbnewline&_
    "LABEL"&vbtab&vbtab&"Creates, changes, or deletes the volume label of a disk."&vbnewline&_
    "MD"&vbtab&vbtab&"Creates a directory."&vbnewline&_
    "MKDIR"&vbtab&vbtab&"Creates a directory."&vbnewline&_
    "MODE"&vbtab&vbtab&"Configures a system device."&vbnewline&_
    "MORE"&vbtab&vbtab&"Displays output one screen at a time."&vbnewline&_
    "MOVE"&vbtab&vbtab&"Moves one or more files from one directory to another directory."&vbnewline&_
    "PATH"&vbtab&vbtab&"Displays or sets a search path for executable files."&vbnewline&_
    "PAUSE"&vbtab&vbtab&"Suspends processing of a batch file and displays a message."&vbnewline&_
    "POPD"&vbtab&vbtab&"Restores the previous value of the current directory saved by PUSHD."&vbnewline&_
    "PRINT"&vbtab&vbtab&"Prints a text file."&vbnewline&_
    "PROMPT"&vbtab&vbtab&"Changes the Windows command prompt."&vbnewline&_
    "PUSHD"&vbtab&vbtab&"Saves the current directory then changes it."&vbnewline&_
    "RD"&vbtab&vbtab&"Removes a directory."&vbnewline&_
    "RECOVER"&vbtab&vbtab&"Recovers readable information from a bad or defective disk."
    strCmd4="REM"&vbtab&vbtab&"Records comments (remarks) in batch files or CONFIG.SYS."&vbnewline&_
    "REN"&vbtab&vbtab&"Renames a file or files."&vbnewline&_
    "RENAME"&vbtab&vbtab&"Renames a file or files."&vbnewline&_
    "REPLACE"&vbtab&vbtab&"Replaces files."&vbnewline&_
    "RMDIR"&vbtab&vbtab&"Removes a directory."&vbnewline&_
    "SET"&vbtab&vbtab&"Displays, sets, or removes Windows environment variables."&vbnewline&_
    "SETLOCAL"&vbtab&"Begins localization of environment changes in a batch file."&vbnewline&_
    "SHIFT"&vbtab&vbtab&"Shifts the position of replaceable parameters in batch files."&vbnewline&_
    "SORT"&vbtab&vbtab&"Sorts input."&vbnewline&_
    "START"&vbtab&vbtab&"Starts a separate window to run a specified program or command."&vbnewline&_
    "SUBST"&vbtab&vbtab&"Associates a path with a drive letter."&vbnewline&_
    "TIME"&vbtab&vbtab&"Displays or sets the system time."&vbnewline&_
    "TITLE"&vbtab&vbtab&"Sets the window title for a CMD.EXE session."&vbnewline&_
    "TREE"&vbtab&vbtab&"Graphically displays the directory structure of a drive or path."&vbnewline&_
    "TYPE"&vbtab&vbtab&"Displays the contents of a text file."&vbnewline&_
    "VER"&vbtab&vbtab&"Displays the Windows version."&vbnewline&_
    "VERIFY"&vbtab&vbtab&"Tells Windows whether to verify that your files are written correctly to a disk."&vbnewline&_
    "VOL"&vbtab&vbtab&"Displays a disk volume label and serial number."&vbnewline&_
    "XCOPY"&vbtab&vbtab&"Copies files and directory trees."
    Msgbox strCmd,0,"Help Page1"
    Msgbox strCmd2,0,"Help Page2"
    Msgbox strCmd3,0,"Help Page3"
    Msgbox strCmd4,0,"Help Page4"
    End Sub
    '================================================
    Class drvstat
    Private objDrive,strrede,intRed,Inttot,dr
    Public Property Let Drive(drv)
    If drv="" Then
    dr=""
    Else
    dr=drv
    End If
    End Property

    Public Sub GetDrive
    On Error resume Next
    If dr="" then
    On Error resume Next
    For Each objDrive In fso.Drives
    with objDrive
    If objDrive.IsReady Then
    intRed=intRed+1
    Inttot=Inttot+1
    strrede="Ready"
    MsgBox get_drive_spec( .DriveLetter),,"Status "& .VolumeName &" ("& .Path&")"
    Else
    strrede="Not ready"
    Inttot=Inttot+1
    MsgBox "Drive "& .DriveLetter & " "& strrede,,"Not Ready"
    End if
    End With
    Next
    MsgBox "Total Drive: " & Inttot & vbNewLine& "Total Ready Drive: " & intRed & vbNewLine& "Total Unready Drive: "& Inttot-intRed,,"Drives"
    'Clean Var
    Inttot=0
    intRed=0
    strRede=""
    Else
    If fso.DriveExists(dr) Then
    MsgBox get_drive_spec(dr),,"Status "& fso.GetDrive(dr).VolumeName &" ("& fso.GetDrive(dr).Path&")"
    Else
    MsgBox "Drive not exists or ready!",vbCritical+vbOKOnly,"Error"
    End If
    End If
    On Error Goto 0 'Neutrealize On error
    End Sub

    Private Function get_drive_spec(Byval drv)
    Dim strSpec
    With FSO.GetDrive(drv)
    If .IsReady Then strrede="Ready"

    strSpec="Drive Name: " & .VolumeName & vbNewLine& "Status: "& strRede & vbNewLine& "Available Space : " & .AvailableSpace /1000000000 & " GB"& vbNewLine&_
    "Drive Letter: " & .DriveLetter & vbNewLine& "Drive Type: " & getstrDrvType (.DriveType) & vbNewLine& "Filesystem : "& .FileSystem & vbNewLine& _
    "Free Space: " & .FreeSpace/1000000000 & " GB" & vbNewLine& "Path: "& .Path & vbNewLine& "Serial Number: "& .SerialNumber & vbNewLine& _
    "Share Name: "& .ShareName & vbNewLine& "Total Size: "& .TotalSize/1000000000 & " GB"
    End With
    get_drive_spec=strSpec
    End Function

    Private Function getstrDrvType(Byval consType)
    Select Case consType
    Case 0
    getstrDrvType="UnknowType"
    Case 1
    getstrDrvType="Removable"
    Case 2
    getstrDrvType="Fixed"
    Case 3
    getstrDrvType="Remote"
    Case 4
    getstrDrvType="CDRom"
    Case 5
    getstrDrvType="RamDisk"
    End Select
    End Function
    End Class
    '==========================================================

    Class objWmiBIOS
    Private strStat,objItem
    Public Function BIOSstat()
    On Error Resume next
    For Each objItem in GetObject("winmgmts:\\.\root\cimv2").ExecQuery("Select * from Win32_BIOS",,48)
    strStat=strStat& "BiosCharacteristics: " & objItem.BiosCharacteristics & vbnewline
    strStat=strStat& "BIOSVersion: " & objItem.BIOSVersion& vbnewline
    strStat=strStat& "BuildNumber: " & objItem.BuildNumber& vbnewline
    strStat=strStat& "Caption: " & objItem.Caption& vbnewline
    strStat=strStat& "CodeSet: " & objItem.CodeSet& vbnewline
    strStat=strStat& "CurrentLanguage: " & objItem.CurrentLanguage& vbnewline
    strStat=strStat& "Description: " & objItem.Description& vbnewline
    strStat=strStat& "IdentificationCode: " & objItem.IdentificationCode& vbnewline
    strStat=strStat& "InstallableLanguages: " & objItem.InstallableLanguages& vbnewline
    strStat=strStat& "InstallDate: " & objItem.InstallDate& vbnewline
    strStat=strStat& "LanguageEdition: " & objItem.LanguageEdition& vbnewline
    strStat=strStat& "ListOfLanguages: " & objItem.ListOfLanguages& vbnewline
    strStat=strStat& "Manufacturer: " & objItem.Manufacturer& vbnewline
    strStat=strStat& "Name: " & objItem.Name& vbnewline
    strStat=strStat& "OtherTargetOS: " & objItem.OtherTargetOS& vbnewline
    strStat=strStat& "PrimaryBIOS: " & objItem.PrimaryBIOS& vbnewline
    strStat=strStat& "ReleaseDate: " & objItem.ReleaseDate& vbnewline
    strStat=strStat& "SerialNumber: " & objItem.SerialNumber& vbnewline
    strStat=strStat& "SMBIOSBIOSVersion: " & objItem.SMBIOSBIOSVersion& vbnewline
    strStat=strStat& "SMBIOSMajorVersion: " & objItem.SMBIOSMajorVersion& vbnewline
    strStat=strStat& "SMBIOSMinorVersion: " & objItem.SMBIOSMinorVersion& vbnewline
    strStat=strStat& "SMBIOSPresent: " & objItem.SMBIOSPresent& vbnewline
    strStat=strStat& "SoftwareElementID: " & objItem.SoftwareElementID& vbnewline
    strStat=strStat& "SoftwareElementState: " & objItem.SoftwareElementState& vbnewline
    strStat=strStat& "Status: " & objItem.Status& vbnewline
    strStat=strStat& "TargetOperatingSystem: " & objItem.TargetOperatingSystem& vbnewline
    strStat=strStat& "Version: " & objItem.Version& vbnewline
    Next
    BIOSstat=strStat
    End Function
    End Class


    Sub drvst(ByVal sender)
    Dim objDrvstat,inpt,x,strDrvIndex
    Set objDrvstat=New drvstat
    With objDrvstat
    If sender="" Then
    For Each x In FSO.Drives
    strDrvIndex=strDrvIndex & vbNewLine& x
    Next
    inpt=InputBox("Choose drive:" & vbNewLine& "--------------------" & strDrvIndex)
    If FSO.DriveExists(inpt) Then
    .Drive=inpt
    .GetDrive
    Else
    MsgBox "Drive not exists or ready!",vbCritical+vbOKOnly,"Error"
    End If
    Else
    .Drive=""
    .GetDrive
    End If
    End with
    End Sub

    Class objWmiProcessor
    Private objProc,strInfo,objWMIService,colItems,objItem
    Public Function ProcInfo()
    On Error Resume Next
    Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
    Set colItems = objWMIService.ExecQuery("Select * from Win32_Processor")
    For Each objItem in colItems
    strInfo=strInfo & "Address Width: " & objItem.AddressWidth & vbNewLine
    strInfo=strInfo & "Architecture: " & objItem.Architecture & vbNewLine
    strInfo=strInfo & "Availability: " & objItem.Availability & vbNewLine
    strInfo=strInfo & "CPU Status: " & objItem.CpuStatus & vbNewLine
    strInfo=strInfo & "Current Clock Speed: " & objItem.CurrentClockSpeed & vbNewLine
    strInfo=strInfo & "Data Width: " & objItem.DataWidth & vbNewLine
    strInfo=strInfo & "Description: " & objItem.Description & vbNewLine
    strInfo=strInfo & "Device ID: " & objItem.DeviceID & vbNewLine
    strInfo=strInfo & "External Clock: " & objItem.ExtClock & vbNewLine
    strInfo=strInfo & "Family: " & objItem.Family & vbNewLine
    strInfo=strInfo & "L2 Cache Size: " & objItem.L2CacheSize & vbNewLine
    strInfo=strInfo & "L2 Cache Speed: " & objItem.L2CacheSpeed & vbNewLine
    strInfo=strInfo & "Level: " & objItem.Level & vbNewLine
    strInfo=strInfo & "Load Percentage: " & objItem.LoadPercentage & vbNewLine
    strInfo=strInfo & "Manufacturer: " & objItem.Manufacturer & vbNewLine
    strInfo=strInfo & "Maximum Clock Speed: " & objItem.MaxClockSpeed & vbNewLine
    strInfo=strInfo & "Name: " & objItem.Name & vbNewLine
    strInfo=strInfo & "PNP Device ID: " & objItem.PNPDeviceID & vbNewLine
    strInfo=strInfo & "Processor ID: " & objItem.ProcessorId & vbNewLine
    strInfo=strInfo & "Processor Type: " & objItem.ProcessorType & vbNewLine
    strInfo=strInfo & "Revision: " & objItem.Revision & vbNewLine
    strInfo=strInfo & "Role: " & objItem.Role & vbNewLine
    strInfo=strInfo & "Socket Designation: " & objItem.SocketDesignation & vbNewLine
    strInfo=strInfo & "Status Information: " & objItem.StatusInfo & vbNewLine
    strInfo=strInfo & "Stepping: " & objItem.Stepping & vbNewLine
    strInfo=strInfo & "Unique Id: " & objItem.UniqueId & vbNewLine
    strInfo=strInfo & "Upgrade Method: " & objItem.UpgradeMethod & vbNewLine
    strInfo=strInfo & "Version: " & objItem.Version & vbNewLine
    strInfo=strInfo & "Voltage Caps: " & objItem.VoltageCaps
    Next
    ProcInfo=strInfo
    End Function
    End Class

    Class objFirewall
    Private objFirewall,objPolicy

    Private Sub Class_Initialize
    Set objFirewall = CreateObject("HNetCfg.FwMgr")
    Set objPolicy = objFirewall.LocalPolicy.CurrentProfile
    End Sub

    Public Property Let SetF(order)
    If order="on" Then
    objPolicy.FirewallEnabled=True
    MsgBox "Firewall turned ON",vbInformation,"Firewall"
    Else
    objPolicy.FirewallEnabled=False
    MsgBox "Firewall turned OFF",vbInformation,"Firewall"
    End If
    End Property

    Public Property Let ReAdmin(order)
    If order="on" Then
    objPolicy.RemoteAdminSettings.Enable=True
    MsgBox "Remote Administrator Enable",vbInformation,"Remote Administrator"
    Else
    objPolicy.RemoteAdminSettings.Enable=False
    MsgBox "Remote Administrator Disable",vbInformation,"Remote Administrator"
    End If
    End Property

    Public Sub add_port(ByVal PortNum,ByVal PortName)
    Dim objPort,boolActive,colPorts
    If MsgBox("Do you want add port "&Portnum&" to firewall?",vbYesNo,"Add port")=vbyes Then
    Set objPort=CreateObject("HNetCfg.FwOpenPort")
    objPort.Port = PortNum
    objPort.Name = PortName
    If MsgBox("Do You Want Activated Port Now?",vbYesNo,"Active new port")= vbyes Then
    boolActive=True
    MsgBox "Port "&PortNum&" ("&PortName&") successfully added and activated",vbInformation,"Add Port"
    Else
    boolActive=False
    MsgBox "Port "&PortNum&" ("&PortName&") successfully added but not activated",vbInformation,"Add Port"
    End if
    objPort.Enabled = boolActive
    Set colPorts = objPolicy.GloballyOpenPorts
    colPorts.Add(objPort)
    Else
    Exit Sub
    End if
    End Sub

    End Class



    Sub scriptingFirewall()
    Dim strCOM,boolrun,objFw,intPort,strPort
    boolrun=True
    Set objFw=New objFirewall
    Do Until Not boolrun
    strCOM=InputBox("# Scripting Windows Firewall >>","Firewall")
    Select Case UCase(strCOM)
    Case "EXIT"
    boolrun=False
    Exit Sub
    Case "SET-ON"
    objFw.SetF="on"
    Case "SET-OFF"
    objFw.SetF="off"
    Case "REMADMIN-OFF"
    objFw.ReAdmin="off"
    Case "REMADMIN-ON"
    objFw.ReAdmin="on"
    Case ""
    boolrun=False
    Exit Sub
    Case "ADDPORT"
    intPort=CInt(InputBox("Type port number","Add Port"))
    strPort=InputBox("Type port name","Add Port")
    If IsNumeric(intPort) Then
    objFw.add_port intPort,strPort
    Else
    MsgBox "Port number must number",vbCritical,"Error"
    End If
    Case "HELP"
    fwall_help()
    End Select
    Loop
    End Sub

    Sub fwall_help()
    MsgBox "SET-ON | OFF"&vbTab&vbTab&":Change firewall mode"&vbnewline&"REMADMIN-ON | OFF"&vbtab&":Change remote administrator mode"&vbNewLine&_
    "ADDPORT"&vbTab&vbTab&":Add allowed port on firewall",vbInformation,"Help"
    End sub


    Sub about()
    MsgBox "CROWJA CONSOLE v1.0"&vbNewLine&vbNewLine&"Coded By"&vbTab&": Nurkholish Ardi Firdaus"_
    &vbNewLine&"Email"&vbTab&": [email protected]"&vbNewLine&vbNewLine&_
    "Scripters Are Programmer Too!!!!!!!",vbInformation,"About"
    End Sub

















    'Script include 29 Subroutines and functions
    'And 4 Class Objects

    'add & bug fixxed: exit now (add 2 do while too), help with tab, add cd .., add line_currdir, fix error cdp ,fix error md ,add cd \, fix cd\
    'add open,add exec,add COM filter, fix md "" ,add err msg on delf ,add banner, cpf window_title as Copy File
    'add cpf_uni.add cpf_filter,add cpf_2,add cmd com,fix_help,add editself,drivestat,bios,fwall class



    ' Copyleft 2009 CROWJA
    Jangan Lupa Komentar Yaa..
    Related Posts Plugin for WordPress, Blogger...

    2 Komentar Untuk “[VBS] Membuat Program Command Line Dengan VBS”

    Anonim mengatakan...

    Kamis, 20 Januari 2011 15.58.00 WIB Reply To This Comment

    sips....gan!


    Nurkholish Ardi Firdaus mengatakan...
    Kamis, 20 Januari 2011 18.06.00 WIB Reply To This Comment

    @Anonim ok, silahkan di kopas gan...


    Posting Komentar

    Berikan komentar positif tentang artikel yang sederhana ini niscaya sobat akan mendapatkan balasannya. Hehehe

    Subscribe