form1.frm

VBScriptcomplier希望大家喜欢。

Private Sub Form_Load()


On Error Resume Next
If App.PrevInstance = True Then End
'If LCase(Command) <> "vbse007" Then End
fileNew_Click
  KeyWords = txtKeyWords.text
  
  
Set Pic.Font = Text1.Font
Pic.Print "a"
Pic.Print "a"

BL = Pic.CurrentY - Pic.TextHeight("a")
Shp.Height = Pic.TextHeight("a") / 1.5
B = Shp.Height / 2
Shp.Top = BL

Text1_SelChange
Pic.Cls
End Sub

Private Sub Form_Resize()
On Error Resume Next
Text1.Width = Me.Width - 610
Text1.Height = Me.Height - 1050
Toolbar1.Width = Me.Width - 140
Pic.Height = Me.Height - 1050

If mainForm.Width <= 10155 Then
mainForm.Width = 10155
End If

If mainForm.Height <= 3585 Then
mainForm.Height = 3585
End If

End Sub

Private Sub Form_Unload(Cancel As Integer)
    fileExit_Click
    End
End Sub

Private Sub gtli_Click()
Dim LineL
LineL = InputBox("Enter the line number!", "Goto Line")
On Error Resume Next
SetCursorAtLine Val(LineL), Text1
Text1.SetFocus
End Sub

Private Sub hhhhhhhhhhh_Click()
SaveHtml
End Sub

Private Sub List1_DblClick()
If List1.Width <= 3615 Then
Timer3.Enabled = True
Else
List1.Width = 3615
End If

If List2.Width <= 3615 Then
Timer3.Enabled = True
Else
List2.Width = 3615
End If
End Sub

Private Sub List1_LostFocus()
List2.Visible = False
List1.Visible = False
End Sub

Private Sub rada_Click()
On Error GoTo errrrrr
ScriptControl1.AddCode Text1.text
Exit Sub


errrrrr:

SetCursorAtLine Val(ScriptControl1.Error.Line), Text1
Text1.SetFocus
Text1.SelColor = vbRed
Text1.SelText = "'" + Err.Description + " > "

List1.AddItem Err.Description

End Sub

Private Sub rss_Click()
On Error GoTo errrrrr
ScriptControl1.AddCode Text1.SelText
Exit Sub


errrrrr:

SetCursorAtLine Val(ScriptControl1.Error.Line), Text1
Text1.SetFocus
Text1.SelColor = vbRed
Text1.SelText = "'" + Err.Description + " > "

List1.AddItem Err.Description

End Sub

Private Sub ruine_Click()
'    On Error Resume Next
 '   tempscript = Environ("temp") & "\tempscript.vbs"
  '  Open tempscript For Output As #1
   '     Print #1, Text1.Text
    'Close #1
     'nResult = Shell("start.exe " & tempscript, vbHide)
     
     Form5.Show
End Sub

Private Sub ruinex_Click()
'    On Error Resume Next
 '   tempscript = Environ("temp") & "\tempscript.vbs"
  '  Open tempscript For Output As #1
   '     Print #1, Text1.Text
    'Close #1
     'nResult = Shell("start.exe " & tempscript, vbHide)
     
     Form5.Show
End Sub

Private Sub Text1_Change()
    txtChange = True
List2.Visible = False
List1.Visible = False
End Sub

Private Sub Text1_Click()
List2.Visible = False
List1.Visible = False
End Sub

Private Sub Text1_DblClick()
If Text1.text = "666" Then
Text1.text = "999"
Else
If Text1.text = "999" Then
Text1.text = "666"
End If
End If

If Text1.text = "App.Title" Then
Text1.text = "App.Title = " + Label1 + "VBScripter" + Label1
End If

If Text1.text = "App.WhoMadeThis" Then
Text1.text = "App.WhoMadeThis = " + Label1 + "Jan Robas" + Label1
End If

If Text1.text = "Crash" Then
Text1.text = Label1.Caption
Colorize mainForm.Text1, &H8000&, vbRed, &HFF0000
End If
End Sub

Private Sub Text1_KeyPress(KeyAscii As Integer)

 If KeyAscii = vbKeyReturn Then Colorize mainForm.Text1, &H8000&, vbRed, &HFF0000
 Text1.SelColor = vbBlack
  
End Sub

Private Sub Text1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim text, txt



If Button = 2 Then
If Text1.SelLength = 0 Then
Form3.Show
Else
rss_Click
End If
End If
End Sub

Private Sub Text1_SelChange()
Dim CurrIndex As Long
Dim indx As Long

CurrIndex = SendMessage(Text1.hWnd, EM_GEFIRSTVISIBLELINE, 0, 0)
indx = SendMessage(Text1.hWnd, EM_LINEFROMCHAR, -1, 0&)
Shp.Top = BL * (indx - CurrIndex) + B
Pic.CurrentY = 0
Pic.Cls
End Sub

Private Sub Timer1_Timer()
If InStr(1, Text1.text, "ahahahahah") > 1 Then
    toolsEncode.Enabled = True
    toolsDecode.Enabled = True
Else
    toolsEncode.Enabled = True
    toolsDecode.Enabled = True
End If
If Len(Text1.SelText) > 0 Then
    editCut.Enabled = True
    editCopy.Enabled = True
Else
    editCut.Enabled = False
    editCopy.Enabled = False
End If
If Len(Text1.text) > 0 Then
    tools.Enabled = True
Else
    tools.Enabled = True
End If
End Sub

Private Sub Timer2_Timer()
If List1.Top <= 290 Then
List1.Top = List1.Top + 280
Else
Timer1.Enabled = False
End If
End Sub

Private Sub Timer3_Timer()
If List1.Width < 7335 Then
List1.Width = List1.Width + 100
Else
Timer3.Enabled = False
End If

If List2.Width < 7335 Then
List2.Width = List1.Width + 100
Else
Timer3.Enabled = False
End If
End Sub

Private Sub Timer4_Timer()
List1.Visible = False
Timer4.Enabled = False
Timer4.Interval = 2000
End Sub

Private Sub Timer5_Timer()
Text1.text = Text1.text + "oOo"
End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button.Index
Case 1
fileNew_Click

Case 2
fileOpen_Click

Case 3
fileSave_Click

Case "5", "20"
ruinex_Click

Case 7
editUndo_Click

Case 8
editCut_Click

Case 9
editCopy_Click

Case 10
editPaste_Click

Case 11
vbsclip_Click



Case 13
Form7.Show

Case 14
    editPaste_Click
    
    Case 16
    PopupMenu tools
    
    Case 18
    werdg_Click
    
    Case 19
    toolsRun_Click
    
    Case 24
    csztm_Click
End Select
End Sub

Private Sub toolsDecode_Click()
Dim ab, ba, aa

toolsRun.Enabled = True
On Error GoTo errmsg
    ab = InStr(1, Text1.text, "ahahahahah(") + 12
    ba = InStr(1, Text1.text, ")")
    aa = Mid(Text1.text, ab, (ba - ab))
    Text1.text = Decode(aa)
    Exit Sub
errmsg:
    MsgBox "Nothing to decode!", vbExclamation, "-VBScripter-"
    

End Sub
Private Sub toolsEncode_Click()
MsgBox "If you use encryption, then the RUN command won't work. To test click on 'Test & Compile' and then click on 'test vbs.vbs'! To compile click on 'compile vbs.vbs' or save file!", vbInformation, "Encryption"

Dim var_stg

    var_stg = "Function ahahahahah(ahahahah): On Error Resume Next: ahahah = Chr(49) & Chr(48) & Chr(48):For I = 1 To Len(ahahahah):ahah = Mid(ahahahah, I, 1):If Asc(ahah) = 15 Then:ahahahahah = ahahahahah & Chr(13):Else:ah = Asc(ahah) - ahahah:ahahahahah = ahahahahah & Chr(ah):End If:Next:End Function"
    Text1.text = "Execute ahahahahah(" & Chr(34) & Encode(Text1.text) & Chr(34) & ")" & vbCrLf & var_stg


End Sub
Private Sub toolsRun_Click()
Dim erline
'    On Error Resume Next
'    tempscript = Environ("temp") & "\tempscript.vbs"
'    Open tempscript For Output As #1
'        Print #1, Text1.Text
'    Close #1
'    nResult = Shell("start.exe " & tempscript, vbHide)

On Error GoTo errrrrr
ScriptControl1.AddCode Text1.text
Exit Sub


errrrrr:
'napaka:___start_of_error_script__
erline = ScriptControl1.Error.Line
SetCursorAtLine Val(ScriptControl1.Error.Line), Text1
Text1.SetFocus
Text1.SelColor = vbRed
Text1.SelText = "'" + Err.Description + " > "

List1.AddItem Err.Description

End Sub

Private Sub toolsruninIE_Click()
Dim sfile
sfile = ShowSave
mainForm.stringbox = sfile
mainForm.stringbox2 = mainForm.stringbox + mainForm.stringbox3

Dim txtHTML, tempHTML
txtHTML = "<HTML>" & vbCrLf
txtHTML = txtHTML & "<HTML>" & vbCrLf
txtHTML = txtHTML & "<TITLE>HTA file</TITLE>" & vbCrLf
txtHTML = txtHTML & "<HEAD>" & vbCrLf
txtHTML = txtHTML & "<SCRIPT LANGUAGE=VBSCRIPT>" & vbCrLf
txtHTML = txtHTML & mainForm.Text1.text
txtHTML = txtHTML & "</SCRIPT>" & vbCrLf
txtHTML = txtHTML & "</HEAD>" & vbCrLf
txtHTML = txtHTML & "</HTML>" & vbCrLf
    On Error Resume Next
    tempHTML = mainForm.stringbox2
    Open tempHTML For Output As #1
        Print #1, txtHTML
    Close #1
End Sub

Private Sub vbsclip_Click()
Form2.Show
End Sub

Private Sub vbscomp_Click()
    SaveAs
End Sub

Private Sub werdg_Click()
List2.Visible = True
List1.Visible = True
List1.Top = -3000
Timer1.Enabled = True
End Sub