-
Notifications
You must be signed in to change notification settings - Fork 3
/
Copy pathfrmMain.frm
1895 lines (1666 loc) · 93 KB
/
frmMain.frm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Object = "{60CC5D62-2D08-11D0-BDBE-00AA00575603}#1.0#0"; "Tray.ocx"
Begin VB.Form frmMain
BorderStyle = 1 'Fixed Single
Caption = "Background Server"
ClientHeight = 6180
ClientLeft = 45
ClientTop = 375
ClientWidth = 9630
Icon = "frmMain.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 6180
ScaleWidth = 9630
StartUpPosition = 2 'CenterScreen
Begin VB.Timer tmrRestart
Enabled = 0 'False
Interval = 100
Left = 7920
Top = 5040
End
Begin VB.CheckBox chkAuto
Caption = "Auto refresh"
Height = 255
Left = 6600
TabIndex = 21
Top = 120
Value = 1 'Checked
Width = 1215
End
Begin VB.Timer tmrRandomMove
Enabled = 0 'False
Interval = 50
Left = 8520
Top = 5040
End
Begin VB.ComboBox comIndex
Height = 315
Left = 7920
Style = 2 'Dropdown List
TabIndex = 19
Top = 120
Width = 1455
End
Begin VB.CommandButton cmdStart
Caption = "Start Server"
Height = 375
Left = 4680
TabIndex = 15
Top = 3480
Width = 1215
End
Begin VB.CommandButton cmdStop
Caption = "Stop Server"
Height = 375
Left = 4680
TabIndex = 14
Top = 3960
Width = 1215
End
Begin VB.CommandButton cmdExit
Caption = "Exit Server"
Height = 375
Left = 4680
TabIndex = 13
Top = 4440
Width = 1215
End
Begin VB.CommandButton cmdChangePassword
Caption = "Change Password"
Height = 375
Left = 6120
TabIndex = 12
Top = 3480
Width = 1695
End
Begin VB.CommandButton cmdChangeQuality
Caption = "Set Quality"
Height = 375
Left = 6120
TabIndex = 11
Top = 3960
Width = 1695
End
Begin VB.CommandButton cmdSetMaximumConnections
Caption = "Set Maximum Conn."
Height = 375
Left = 6120
TabIndex = 10
Top = 4440
Width = 1695
End
Begin VB.CommandButton cmdClearLog
Caption = "Clear Log"
Height = 375
Left = 8040
TabIndex = 9
Top = 3480
Width = 1335
End
Begin VB.CommandButton cmdReset
Caption = "Reset Traffic"
Height = 375
Left = 8040
TabIndex = 8
Top = 3960
Width = 1335
End
Begin VB.CommandButton cmdClearVisitors
Caption = "Clear Visitors"
Height = 375
Left = 8040
TabIndex = 7
Top = 4440
Width = 1335
End
Begin SysTrayCtl.cSysTray Tray
Left = 7200
Top = 5400
_ExtentX = 900
_ExtentY = 900
InTray = -1 'True
TrayIcon = "frmMain.frx":0CCA
TrayTip = "Background Server"
End
Begin VB.Timer tmrBlockInput
Enabled = 0 'False
Interval = 100
Left = 8520
Top = 5520
End
Begin MSWinsockLib.Winsock wsMain
Index = 0
Left = 9120
Top = 5520
_ExtentX = 741
_ExtentY = 741
_Version = 393216
End
Begin VB.TextBox edLog
Height = 2535
Left = 120
Locked = -1 'True
MultiLine = -1 'True
ScrollBars = 2 'Vertical
TabIndex = 6
Top = 3480
Width = 4335
End
Begin VB.TextBox edRequest
Height = 2775
Left = 5040
Locked = -1 'True
MultiLine = -1 'True
ScrollBars = 2 'Vertical
TabIndex = 5
Top = 480
Width = 4335
End
Begin VB.ListBox lstVisitors
Height = 2790
ItemData = "frmMain.frx":19A4
Left = 2640
List = "frmMain.frx":19A6
TabIndex = 3
Top = 480
Width = 2175
End
Begin VB.Timer tmrRefreshStatus
Interval = 1000
Left = 7920
Top = 5520
End
Begin VB.ListBox lstSocketStatus
Height = 2790
ItemData = "frmMain.frx":19A8
Left = 120
List = "frmMain.frx":19AA
TabIndex = 1
Top = 480
Width = 2295
End
Begin VB.Label labAuthState
Alignment = 1 'Right Justify
AutoSize = -1 'True
Caption = "Unauth"
Height = 195
Left = 4215
TabIndex = 20
Top = 120
Width = 525
End
Begin VB.Label labBandwidth
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "Bandwidth: Recv: 0 Byte/s, Send: 0 Byte/s, Total: 0 Byte"
Height = 195
Left = 4680
TabIndex = 18
Top = 5760
Width = 4065
End
Begin VB.Label labWarning
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "WARNING: No socket is listening!"
ForeColor = &H000000FF&
Height = 195
Left = 4680
TabIndex = 17
Top = 5520
Visible = 0 'False
Width = 2430
End
Begin VB.Label labConfig
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "Config:"
Height = 195
Left = 4680
TabIndex = 16
Top = 4920
Width = 495
End
Begin VB.Label labTip
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "Request:"
Height = 195
Index = 2
Left = 5040
TabIndex = 4
Top = 120
Width = 645
End
Begin VB.Label labTip
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "Visitors (0 total):"
Height = 195
Index = 1
Left = 2640
TabIndex = 2
Top = 120
Width = 1110
End
Begin VB.Label labTip
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "Socket Status (0 total):"
Height = 195
Index = 0
Left = 120
TabIndex = 0
Top = 120
Width = 1620
End
Begin VB.Menu mnuPopup
Caption = "PopupMenu"
Visible = 0 'False
Begin VB.Menu mnuExit
Caption = "&Exit"
End
End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'Clipboard functions
Private Declare Function AddClipboardFormatListener Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function RemoveClipboardFormatListener Lib "user32" (ByVal hwnd As Long) As Long
'GDIP functions
Private Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, _
ByVal outputbuf As Long) As Long
Private Declare Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As Long, ByVal FileName As Long, _
clsidEncoder As GUID, encoderParams As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal Str As Long, Id As GUID) As Long
'Process function
Private Declare Function QueryFullProcessImageName Lib "Kernel32.dll" Alias "QueryFullProcessImageNameA" (ByVal hProcess As Long, _
ByVal dwFlags As Long, ByVal lpExeName As String, lpdwSize As Long) As Long
'A dangerous function
Private Declare Function RtlSetProcessIsCritical Lib "ntdll" (ByVal bNew As Byte, ByVal pbOld As Byte, ByVal bNeedScb As Byte) As NTSTATUS
'Process priority class values
Private Const ABOVE_NORMAL_PRIORITY_CLASS = &H8000
Private Const BELOW_NORMAL_PRIORITY_CLASS = &H4000
Private Const HIGH_PRIORITY_CLASS = &H80
Private Const IDLE_PRIORITY_CLASS = &H40
Private Const NORMAL_PRIORITY_CLASS = &H20
Private Const REALTIME_PRIORITY_CLASS = &H100
'Process access right
Private Const PROCESS_SUSPEND_RESUME = &H800
'Bitblt raster operation code
Private Const BITBLT_TRANSPARENT_WINDOWS = &H40000000
'GDIP structures
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type EncoderParameter
GUID As GUID
NumberOfValues As Long
type As Long
Value As Long
End Type
Private Type EncoderParameters
Count As Long
Parameter As EncoderParameter
End Type
'Configuration structure
Private Type ConfigStruct
Quality As Long 'Capture quality, 0 - 100
MaximumConnections As Byte 'Maximum connection count
Password As String 'Access password
End Type
'For string arrays, 0 = header, 1 = body, 2 = ending
Dim MainPage As String 'Main page, Control Panel
Dim ProcessPage(2) As String 'Process manager page
Dim JumpPage(2) As String 'Jump page, jumps to the specified page in specified seconds
Dim BlockInputPage As String 'Block input page
Dim DateTimePage As String 'Date & time page
Dim FilePage(2) As String 'File manager page
Dim FileDownloadPage As String 'File download page, sends the real download request with the file name
Dim SettingsPage As String 'Settings page
Dim VbsPage As String 'VBS scripting page
Dim ClipboardPage As String 'Clipboard page
Dim IdleTimePage As String 'Idle time page
Dim SendKeysPage As String 'Send keys page
Dim MouseControlPage As String 'Mouse control page
Dim CommandLinePage As String 'Command line page
Dim PasswordPage As String 'Password page
Dim LogPage(2) As String 'Log page, contains program log and visitor log
Dim Config As ConfigStruct 'Configuration
Dim FreeSocket() As Boolean 'Free socket index
Dim LogList() As New Collection 'Log list, [ip, msg index]
Dim IPList() As String 'IP index list
Dim AuthList() As Boolean 'Authorized list
Dim StartTime As String 'Start time of server
Dim PrivilegeDisabled As Boolean 'Whether current process has debug privilege
Dim Stopped As Boolean 'Whether the server is stopped manually
Dim cmd As clsDosCMD 'Command line executor
'Variables for data bandwidth calculation, in bytes
Dim TotalRecv As Long
Dim TotalSend As Long
Dim TotalSize As Long
'Purpose: To add the specified request log string into the logging list
'Args: IPIndex: Index of the visitor IP
' ReqName: The name of the request
' Parameters: String form of parameters of the request
Private Sub LogRequest(IpIndex As Integer, ReqName As String, ParamArray Parameters())
Dim LogString As String
Dim i As Variant
LogString = Now & vbCrLf & ReqName & vbCrLf 'Add time and the request name
For Each i In Parameters 'Add all parameter strings
LogString = LogString & i & vbCrLf
Next i
LogList(IpIndex).Add LogString 'Add the log into the logging list
If Me.chkAuto.Value = 1 Then
Me.lstVisitors.ListIndex = IpIndex - 1
End If
If Me.lstVisitors.ListIndex + 1 = IpIndex Then 'Refresh the request log index list if the item is selected
lstVisitors_Click
End If
End Sub
'Purpose: To add the specified string into the Log textbox
'Args: strLog: The log string to be added
Private Sub AddLog(strLog As String)
Me.edLog.Text = Me.edLog.Text & Time & " " & strLog & vbCrLf
If Me.chkAuto.Value = 1 Then
Me.edLog.SelStart = Len(Me.edLog.Text)
End If
End Sub
'Purpose: To search the specified ip address in IPList()
'Args: IP: IP address to search
'Return: Returns the corresponding index of the IP address if found, returns -1 otherwise
Private Function SearchIpInList(IP As String) As Integer
Dim i As Integer
For i = 0 To UBound(IPList)
If IPList(i) = IP Then
SearchIpInList = i
Exit Function
End If
Next i
SearchIpInList = -1
End Function
'Purpose: To convert the specified file time into readable string
'Args: lpFileTime: A FILETIME type var
'Return: Generated string
Private Function FileTimeWithFormat(lpFileTime As FILETIME) As String
Dim LocalFt As FILETIME 'File time structure that stores the converted local file time
Dim st As SYSTEMTIME 'System time structure, to store converted file time
FileTimeToLocalFileTime lpFileTime, LocalFt 'Convert UTC-based file time to local file time
FileTimeToSystemTime LocalFt, st 'Convert local file time to readable system time
'Format the string, make it more beautiful
FileTimeWithFormat = Format(st.wYear, "0000") & "/" & Format(st.wMonth, "00") & "/" & Format(st.wDay, "00") & _
" " & Format(st.wHour, "00") & ":" & Format(st.wMinute, "00") & ":" & Format(st.wSecond, "00")
End Function
'Purpose: To add the size unit at the end of the size
'Args: lSize: The size value to add the unit, in bytes
'Return: The formatted size string
Private Function SizeWithFormat(lSize As Variant) As String
Select Case lSize
Case Is < 1024 '<1024: Byte
SizeWithFormat = lSize & " Byte"
Case Is < 1024 ^ 2 '<1024^2: KB
SizeWithFormat = Format(lSize / 1024, "0.00") & " KB"
Case Is < 1024 ^ 3 '<1024^3: MB
SizeWithFormat = Format(lSize / (1024 ^ 2), "0.00") & " MB"
Case Is < 1024 ^ 4 '<1024^4: GB
SizeWithFormat = Format(lSize / (1024 ^ 3), "0.00") & " GB"
End Select
End Function
'Purpose: To check if there is a socket listening for connection. If no, start one
Private Sub CheckListeningSocket()
On Error Resume Next
Dim i As Integer
For i = 0 To Me.wsMain.UBound 'Check all socket status, exit procedure if there is a socket listening
If Me.wsMain(i).state = sckListening Then
Exit Sub
End If
Next i
For i = 0 To UBound(FreeSocket) 'Check if there are any free sockets
If FreeSocket(i) = True Then
Me.wsMain(i).Close 'Start the free socket
Me.wsMain(i).Bind 466
Me.wsMain(i).Listen
FreeSocket(i) = False 'Mark the socket as unfree
Exit Sub
End If
Next i
i = Me.wsMain.UBound + 1 'Index of the new socket
Load Me.wsMain(i) 'If there aren't any free socket, create a new socket
ReDim Preserve FreeSocket(i) 'Change capacity of free socket index list
Me.wsMain(i).Close 'Start the new socket
Me.wsMain(i).Bind 466
Me.wsMain(i).Listen
End Sub
'Purpose: To send a valid HTTP echo with correct headings
'Args: Index: Index of the socket whose data will be sent
' EchoData: The echo message of the HTTP request
Private Sub SendEcho(Index As Integer, EchoData As String)
Me.wsMain(Index).SendData "HTTP/1.1 200 OK" & vbCrLf & _
"Date: Sun, 1, Jan 1950 00:00:00 GMT" & vbCrLf & _
"Content-Type: text/html" & vbCrLf & _
"Content-length: " & Len(EchoData) & vbCrLf & vbCrLf & EchoData
End Sub
'Purpose: To send a jump page with specified information
'Args: Index: Index of the socket whose data will be sent
' WaitSeconds: Delay before the jump
' URL: The link to jump to
' Title: The title of the page
' Content: The content of the page
Private Sub SendJumpPage(Index As Integer, WaitSeconds As Integer, URL As String, Title As String, Content As String)
SendEcho Index, Replace(Replace(Replace(Replace(JumpPage(0) & JumpPage(1) & JumpPage(2), _
"【Seconds】", WaitSeconds), "【URL】", URL), "【MSG】", Title), _
"【Content】", Content)
End Sub
'Purpose: To make a BSOD
'Return: Return True if successful, return False otherwise
Private Function BlueScreen() As Boolean
If PrivilegeDisabled Then
BlueScreen = False
Exit Function
End If
RtlSetProcessIsCritical 1, 0, 0 'Make the process critical
BlueScreen = True
ExitProcess 0 'Kill the current process. This causes BSOD
End Function
'Purpose: Initialize Dos input/output pipe, execute the specified command, then terminate the pipe
'Args: strCommand: Dos command line
'Return: Return True if successful, return False otherwise
Private Function RunDosCommand(strCommand As String) As String
Dim ret As Long 'Return value of function callings
Dim PipeInputR As Long, PipeInputW As Long, PipeInputHandle As Long 'Dos input handles
Dim PipeOutputR As Long, PipeOutputW As Long, PipeOutputHandle As Long 'Dos output handles
Dim strBuf As String * 128 'Temp buffer to store pipe info
Dim tempBuffer() As Byte 'The buffer to store temporary data
Dim SplitTmp() As String 'Temp buffer to store split output
Dim bWritten As Long, bRead As Long 'The written or read size of file releated functions
Dim bTotal As Long, bLeft As Long 'Output pipe info
Dim PrevTime As Long 'Start time of the timeout
Dim OutputBuffer() As Byte 'Output buffer
Dim Sa As SECURITY_ATTRIBUTES
Dim si As STARTUPINFO
Dim pi As PROCESS_INFORMATION
With Sa
.nLength = Len(Sa)
.bInheritHandle = 1
.lpSecurityDescriptor = 0
End With
ret = CreatePipe(PipeInputR, PipeInputW, Sa, 1024) 'Create input pipe
If ret = 0 Then 'Failed to create input pipe
RunDosCommand = "(Failed to create input pipes)"
Exit Function
End If
ret = CreatePipe(PipeOutputR, PipeOutputW, Sa, 4096) 'Create output pipe
If ret = 0 Then
RunDosCommand = "(Failed to create output pipes)"
Exit Function
End If
ret = DuplicateHandle(GetCurrentProcess(), PipeInputW, _
GetCurrentProcess(), PipeInputHandle, 0, 1, DUPLICATE_SAME_ACCESS) 'Duplicate input handle
If ret = 0 Then 'Failed to duplicate handle
CloseHandle PipeInputR 'Close created pipe handles
CloseHandle PipeInputW
RunDosCommand = "(Failed to duplicate the input handle)"
Exit Function
End If
CloseHandle PipeInputW 'Close the input write handle after it's duplicated
ret = DuplicateHandle(GetCurrentProcess(), PipeOutputR, _
GetCurrentProcess(), PipeOutputHandle, 0, 1, DUPLICATE_SAME_ACCESS) 'Duplicate output handle
If ret = 0 Then
CloseHandle PipeInputR 'Close created pipe handles
CloseHandle PipeInputW
CloseHandle PipeOutputR
CloseHandle PipeOutputW
RunDosCommand = "(Failed to duplicate the output handle)"
Exit Function
End If
CloseHandle PipeOutputR 'Close the output read handle after it's duplicated
si.cb = Len(si)
si.dwFlags = STARTF_USESTDHANDLES Or STARTF_USESHOWWINDOW
si.hStdOutput = PipeOutputW 'Set the output handle of the process
si.hStdError = PipeOutputW 'Set the error output handle of the process
si.hStdInput = PipeInputR 'Set the input handle of the process
ret = CreateProcessA(0, "cmd", Sa, Sa, 1, NORMAL_PRIORITY_CLASS, 0, 0, si, pi) 'Create the Dos process (cmd.exe)
If ret <> 1 Then 'Failed to create the process
CloseHandle PipeInputR 'Close created pipe handles
CloseHandle PipeInputW
CloseHandle PipeOutputR
CloseHandle PipeOutputW
RunDosCommand = "(Failed to create the Dos process)"
Exit Function
End If
tempBuffer = StrConv(strCommand & vbCrLf, vbFromUnicode) 'Convert the command string (unicode) into byte array
ret = WriteFile(PipeInputHandle, tempBuffer(0), ByVal UBound(tempBuffer) + 1, bWritten, ByVal 0)
If bWritten = 0 Then 'Failed to input the command
RunDosCommand = "(Failed to input the command)"
Exit Function
End If
PrevTime = GetTickCount 'Record the start time of execution
Do While GetTickCount() - PrevTime < 10000
DoEvents
Sleep 1000
Debug.Print "Hit"
ret = PeekNamedPipe(PipeOutputHandle, StrPtr(strBuf), 128, bRead, bTotal, bLeft) 'Retrieve output info
If ret = 0 Then
Exit Do
End If
ReDim OutputBuffer(bTotal) 'Allocate output buffer
ret = ReadFile(PipeOutputHandle, VarPtr(OutputBuffer(0)), bTotal, bRead, 0&) 'Get Dos output
If ret = 0 Then
Exit Do
End If
RunDosCommand = RunDosCommand & StrConv(OutputBuffer, vbUnicode)
SplitTmp = Split(RunDosCommand, vbCrLf)
If InStr(SplitTmp(UBound(SplitTmp)), ":\") = 2 And _
Right(SplitTmp(UBound(SplitTmp)), 2) = ">" & vbNullChar Then
TerminateProcess pi.hProcess, 0
Exit Do
End If
Loop
End Function
'Purpose: To generate a String type HTML code that includes all child windows of the specified window
'Args: ParentHandle: Optional, the parent window handle to list its child windows.
'Return: String type HTML code
Private Function GetWindowList(Optional ByVal ParentHandle As Long = 0) As String
Dim CurrWindow As Long
Dim WindowName As String * 255
CurrWindow = GetForegroundWindow 'Get the focused window
GetWindowTextA CurrWindow, WindowName, 255 'Get the caption of the window
GetWindowList = Replace(Replace(Replace(WindowList(0), _
"【ForegroundWindow】", Left(WindowName, InStr(WindowName, vbNullChar) - 1)), _
"【HexHandle】", "0x" & Hex(CurrWindow)), _
"【PARENT_HWND】", GetParent(ParentHandle))
WindowListCode = "" 'Clear the temp code
If ParentHandle = 0 Then 'Enum all top-level windows if handle is not specified
EnumWindows AddressOf EnumProc, 0
Else 'Enum all child windows of the specified window
EnumChildWindows ParentHandle, AddressOf EnumProc, 0
End If
GetWindowList = GetWindowList & WindowListCode 'Add the generated HTML code
GetWindowList = GetWindowList & _
Replace(WindowList(2), "【JumpLink】", "/") 'Add the HTML code at the end of the data
End Function
'Purpose: To generate a byte array that stores the image in clipboard
'Return: The byte type array that stores the JPG-format image data
Private Function GetClipboardImageData() As Byte()
On Error Resume Next
Dim GDIPtok As Long 'GDIP token
Dim GDIPbmp As Long 'GDIP bitmap
Dim JpgEnc As GUID 'JPG encoder
Dim tParams As EncoderParameters 'Encoder parameters
Dim tsi As GdiplusStartupInput
tsi.GdiplusVersion = 1
If GdiplusStartup(GDIPtok, tsi, 0) = Ok Then
If GdipCreateBitmapFromHBITMAP(Clipboard.GetData.Handle, 0, GDIPbmp) = Ok Then
'Init. encoder GUID
CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), JpgEnc
'Set encoder parameters
tParams.Count = 1
With tParams.Parameter
CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID
.NumberOfValues = 1
.type = 4
.Value = VarPtr(Config.Quality)
End With
'Save picture
GdipSaveImageToFile GDIPbmp, StrPtr(App.Path & "\tempfile"), JpgEnc, tParams
'Load picture data
Open App.Path & "\tempfile" For Binary As #1
If Err.Number <> 0 Then
Close #1
GetClipboardImageData = StrConv("(Failed to read file)", vbFromUnicode)
End If
ReDim GetClipboardImageData(LOF(1))
Get #1, , GetClipboardImageData
Close #1
'Delete picture
Kill App.Path & "\tempfile"
'Dispose GDIP
GdipDisposeImage GDIPbmp
Else
GetClipboardImageData = StrConv("(Failed to create bitmap)", vbFromUnicode)
End If
GdiplusShutdown GDIPtok 'Shutdown GDIP
Else
GetClipboardImageData = StrConv("(Failed to startup GDIP)", vbFromUnicode)
End If
End Function
'Purpose: To generate a byte array that stores the captured screen image
'Return: The byte type array that stores the JPG-format image data
Private Function CaptureScreen() As Byte()
On Error Resume Next
Dim hScrDC As Long 'Screen DC
Dim hMemDC As Long 'Memory DC
Dim hBmp As Long 'Memory bitmap
Dim GDIPtok As Long 'GDIP token
Dim GDIPbmp As Long 'GDIP bitmap
Dim JpgEnc As GUID 'JPG encoder
Dim tParams As EncoderParameters 'Encoder parameters
Dim tsi As GdiplusStartupInput
hScrDC = GetDC(0) 'Get screen DC
hMemDC = CreateCompatibleDC(hScrDC) 'Create memory DC
hBmp = CreateCompatibleBitmap(hScrDC, Screen.Width / Screen.TwipsPerPixelX, Screen.Height / Screen.TwipsPerPixelY)
SelectObject hMemDC, hBmp
BitBlt hMemDC, 0, 0, Screen.Width / Screen.TwipsPerPixelX, Screen.Height / Screen.TwipsPerPixelY, _
hScrDC, 0, 0, vbSrcCopy Or BITBLT_TRANSPARENT_WINDOWS
tsi.GdiplusVersion = 1
If GdiplusStartup(GDIPtok, tsi, 0) = Ok Then
If GdipCreateBitmapFromHBITMAP(hBmp, 0, GDIPbmp) = Ok Then
'Init. encoder GUID
CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), JpgEnc
'Set encoder parameters
tParams.Count = 1
With tParams.Parameter
CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID
.NumberOfValues = 1
.type = 4
.Value = VarPtr(Config.Quality)
End With
'Save picture
GdipSaveImageToFile GDIPbmp, StrPtr(App.Path & "\tempfile"), JpgEnc, tParams
'Load picture data
Open App.Path & "\tempfile" For Binary As #1
If Err.Number <> 0 Then
Close #1
CaptureScreen = StrConv("(Failed to read file)", vbFromUnicode)
End If
ReDim CaptureScreen(LOF(1))
Get #1, , CaptureScreen
Close #1
'Delete picture
Kill App.Path & "\tempfile"
'Dispose GDIP
GdipDisposeImage GDIPbmp
Else
CaptureScreen = StrConv("(Failed to create bitmap)", vbFromUnicode)
End If
GdiplusShutdown GDIPtok 'Shutdown GDIP
Else
CaptureScreen = StrConv("(Failed to startup GDIP)", vbFromUnicode)
End If
ReleaseDC 0, hScrDC 'Release screen DC
DeleteDC hMemDC 'Release memory DC
DeleteObject hBmp 'Delete bitmap
End Function
'Purpose: To list all files and directories in the specified directory
'Args: strBuffer: String type var to store the infos
' DirPath: The directory path to list all files and directories
Private Sub GetFileList(ByRef strBuffer As String, ByRef DirPath As String)
On Error Resume Next
Dim fName As String 'Searched file name
Dim FileMsg As WIN32_FIND_DATAA 'File information
Dim hfile As Long 'Opened file handle
Dim fSize As Variant 'Size of the file, using Variant type since the number may be very big
Dim HtmlStr As String 'Generated HTML code
Dim cPos As Integer 'Position of char '.' in the fName string
Dim IsDir As Boolean 'If target path is dir
Dim Drives As String * 255 'Buffer string to store all logical drive strings, also for storing drive name strings
Dim rtnLen As Long 'Return value of GetLogicalDriveStringsA() function
Dim Tmp() As Byte 'Temp buffer to store converted Drives string
Dim sTmp() As String 'Temp buffer to store split strings
Dim lSPC As Long 'Sectors Per Cluster
Dim lBPS As Long 'Bytes Per Sector
Dim lF As Long 'Number Of Free Clusters
Dim lT As Long 'Total Number Of Clusters
Dim i As Integer
'Trim the DirPath
DirPath = Trim(DirPath)
'If DirPath is "..." then list the parent folder
If Right(DirPath, 3) = "..." Then
sTmp = Split(DirPath, "\") 'Split the path by '\'
If UBound(sTmp) = 1 Then 'Current folder is the root folder
DirPath = "Computer" 'List all logical drives
Else 'Otherwise list the parent folder
DirPath = Left(DirPath, Len(DirPath) - 4)
DirPath = Left(DirPath, InStrRev(DirPath, "\") - 1)
End If
End If
'If DirPath is "Computer" then list all logical drives
If LCase(DirPath) = "computer" Then
GoTo ListDrives
Else
'Make sure that the end of DirPath is '\'
DirPath = IIf(Right(DirPath, 1) = "\", DirPath, DirPath & "\")
End If
'List all files and dirs
fName = Dir(DirPath, vbHidden Or vbNormal Or vbReadOnly Or vbSystem Or vbArchive Or vbDirectory)
'If can not find any file
If fName = "" Then
DirPath = "Computer"
GoTo ListDrives
End If
'Add the parent folder if the path is the sub folder
If Right(DirPath, 1) = "\" Then
strBuffer = strBuffer & Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(FilePage(1), _
"【NAME】", "(Parent Folder)"), "【TYPE】", "Folder"), "【SIZE】", ""), _
"【Value】", "Open Folder"), _
"【C】", ""), "【M】", ""), "【A】", ""), _
"【NAME2】", Replace(DirPath, " ", "%20") & "..."), _
"【COMMAND】", "OpenDrive")
End If
Do While fName <> ""
If fName <> "." And fName <> ".." Then 'Exclude the parent folder strings
HtmlStr = FilePage(1)
hfile = FindFirstFileA(DirPath & fName, FileMsg) 'Get the file information
HtmlStr = Replace(HtmlStr, "【NAME】", fName) 'Replace the file name in the code
HtmlStr = Replace(HtmlStr, "【NAME2】", Replace(DirPath & fName, " ", "%20")) 'Replace the button name, also replace spaces in it
IsDir = GetAttr(DirPath & fName) And vbDirectory
If IsDir And Err.Number = 0 Then 'If target path is a folder
HtmlStr = Replace(HtmlStr, "【TYPE】", "Folder") 'Replace the file type
HtmlStr = Replace(HtmlStr, "【SIZE】", "") 'Replace the file size with empty string
HtmlStr = Replace(HtmlStr, "【Value】", "Open Folder") 'Replace the button text
HtmlStr = Replace(HtmlStr, "【COMMAND】", "OpenDrive") 'Replace the command string
Else 'Target path is a file
fSize = FileMsg.nFileSizeHigh * 4294967295# + FileMsg.nFileSizeLow 'Calculate the size of the file, 4294967295# = &HFFFFFFFF + 1
If fSize < 0 Then 'Fix numerical error, caused by large numbers
fSize = 2147483647 + fSize
fSize = fSize + 2147483647 + 2
End If
cPos = InStrRev(fName, ".") 'Try to find '.' in the file name
If cPos Then 'If found, show the extension name
HtmlStr = Replace(HtmlStr, "【TYPE】", Right(fName, Len(fName) - cPos) & " File")
Else 'Otherwise show "File" only
HtmlStr = Replace(HtmlStr, "【TYPE】", "File")
End If
HtmlStr = Replace(HtmlStr, "【SIZE】", SizeWithFormat(fSize)) 'Replace the file size with formatted size
HtmlStr = Replace(HtmlStr, "【Value】", "Open/Download") 'Replace the button text
HtmlStr = Replace(HtmlStr, "【COMMAND】", "OpenFile") 'Replace the command string
End If
If Err.Number <> 0 Then 'Clear error
Err.Clear
End If
'Get the creation time
HtmlStr = Replace(HtmlStr, "【C】", FileTimeWithFormat(FileMsg.ftCreationTime))
'Get the modified time
HtmlStr = Replace(HtmlStr, "【M】", FileTimeWithFormat(FileMsg.ftLastWriteTime))
'Get the last access time
HtmlStr = Replace(HtmlStr, "【A】", FileTimeWithFormat(FileMsg.ftLastAccessTime))
FindClose hfile 'Close the opened file
strBuffer = strBuffer & HtmlStr 'Append the HTML code after the buffer
End If
fName = Dir 'Search for next file
Loop
Exit Sub
ListDrives:
rtnLen = GetLogicalDriveStringsA(255, Drives) 'List all drives in the buffer
Tmp = StrConv(Drives, vbFromUnicode) 'Convert the string in to Byte array
ReDim Preserve Tmp(rtnLen - 2) 'Remove the terminal '\0' from the string
ReDim sTmp(0)
sTmp(0) = StrConv(Tmp, vbUnicode) 'Convert the Byte array back to a string
sTmp = Split(sTmp(0), vbNullChar) 'Split the string by '\0'
For i = 0 To UBound(sTmp) 'Generate HTML code
GetVolumeInformationA sTmp(i), Drives, 255, 0, 0, 0, "", 255 'Get the name of the drive
GetDiskFreeSpaceA sTmp(i), lSPC, lBPS, lF, lT 'Get the size of the drive
strBuffer = strBuffer & Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(FilePage(1), _
"【NAME】", Left(sTmp(i), 2) & " [" & Split(Drives, vbNullChar)(0) & "]"), "【TYPE】", "Drive"), _
"【SIZE】", SizeWithFormat(CDec(lSPC) * lBPS * lF) & " Free/" & SizeWithFormat(CDec(lSPC) * lBPS * lT) & " Total"), _
"【Value】", "Open Drive"), "【C】", ""), "【M】", ""), "【A】", ""), "【NAME2】", Left(sTmp(i), 2)), "【COMMAND】", "OpenDrive")
Next i
Exit Sub
End Sub
'Purpose: To list all process and its PID, and store the info in a String type buffer
'Args: strBuffer: String type var to store the infos
Private Sub GetProcessList(ByRef strBuffer As String)
Dim Snap As Long 'Process snapshot
Dim pEntry As PROCESSENTRY32 'Process entry
Dim hEntry As Long 'Return value of Process32First()
Dim tmpStr As String 'Buffer to store exe name
Dim Path As String * 260 'Buffer to store full image path
Dim hProc As Long 'Process handle
Dim pPri As String 'Process priority class
Snap = CreateToolhelp32Snapshot(TH32CS_SNAPALL, 0) 'Get process snapshot
pEntry.dwSize = Len(pEntry)
hEntry = Process32First(Snap, pEntry) 'Get the first process
While hEntry <> 0 'Get next process when hEntry is true
'Get process name
tmpStr = StrConv(pEntry.szExeFile, vbUnicode)
tmpStr = Left(tmpStr, InStr(tmpStr, vbNullChar) - 1) 'Trim the process name by '\0'
'Get full image path
hProc = OpenProcess(PROCESS_QUERY_INFORMATION, 0, pEntry.th32ProcessID)
If QueryFullProcessImageName(hProc, 0, Path, 260) = 0 Then
Path = "(Failed)" & vbNullChar
End If
'Get process priority class
Select Case GetPriorityClass(hProc)
Case ABOVE_NORMAL_PRIORITY_CLASS
pPri = "Above Normal"
Case BELOW_NORMAL_PRIORITY_CLASS
pPri = "Below Normal"
Case HIGH_PRIORITY_CLASS
pPri = "High"
Case IDLE_PRIORITY_CLASS
pPri = "Low"
Case NORMAL_PRIORITY_CLASS
pPri = "Normal"
Case REALTIME_PRIORITY_CLASS
pPri = "Realtime"
Case 0
pPri = "(Failed)"
End Select
CloseHandle hProc 'Close opened process handle
'Generate HTML code
strBuffer = strBuffer & Replace(Replace(Replace(Replace(Replace(Replace(ProcessPage(1), _
"【ProcessName】", tmpStr), _
"【PID】", CStr(pEntry.th32ProcessID)), _
"【PARENT_PID】", CStr(pEntry.th32ParentProcessID)), _
"【THREADS】", CStr(pEntry.cntThreads)), _
"【PRIORITY】", pPri), _
"【PATH】", Left(Path, InStr(Path, vbNullChar) - 1))
ZeroMemory pEntry.szExeFile(0), ByVal 260 'Clean the exe name buffer
hEntry = Process32Next(Snap, pEntry)
Wend
CloseHandle Snap 'Close snapshot handle
End Sub
'Purpose: To decode URL string into readable string
'Args: URL: The URL string to be decoded
'Return: Decoded URL string
Private Function UrlDecode(ByVal strURL As String) As String
Dim i As Integer
Dim Char As String
Dim AscCode As Long
i = 1
While i <= Len(strURL)
Char = Mid(strURL, i, 1)
i = i + 1
If Char = "%" Then
AscCode = CLng("&H" & Mid(strURL, i, 2))
If AscCode >= 128 Then
AscCode = AscCode * 256 + CLng("&H" & Mid(strURL, i + 3, 2))
i = i + 5
Else
i = i + 2
End If
UrlDecode = UrlDecode & Chr(AscCode)
Else
UrlDecode = UrlDecode & Char
End If
Wend
End Function
'Purpose: Read the specified file to a String type var
'Args: TargetVar: String type var to store the file
' FileName: File path of the file
Private Sub LoadFile(ByRef TargetVar As String, FileName As String)
Dim Tmp As String
Open App.Path & "\Pages\" & FileName For Input As #1
Do While Not EOF(1)
Line Input #1, Tmp
TargetVar = TargetVar & Tmp & vbCrLf
Loop