-
Notifications
You must be signed in to change notification settings - Fork 5
/
frmRemoteControl.frm
1333 lines (1249 loc) · 53.8 KB
/
frmRemoteControl.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 = "{A8E5842E-102B-4289-9D57-3B3F5B5E15D3}#12.0#0"; "Controls.ocx"
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Begin VB.Form frmRemoteControl
BackColor = &H00FFFFFF&
Caption = "远程控制"
ClientHeight = 5592
ClientLeft = 120
ClientTop = 456
ClientWidth = 10860
Icon = "frmRemoteControl.frx":0000
LinkTopic = "Form1"
ScaleHeight = 5592
ScaleWidth = 10860
StartUpPosition = 2 '屏幕中心
Begin VB.Timer tmrDataPerSecond
Enabled = 0 'False
Interval = 1000
Left = 7440
Top = 4920
End
Begin XtremeSuiteControls.TabControl TabMain
Height = 3732
Left = 0
TabIndex = 1
Top = 760
Width = 9132
_Version = 786432
_ExtentX = 16113
_ExtentY = 6588
_StockProps = 68
Appearance = 10
Color = 32
ItemCount = 6
Item(0).Caption = "屏幕控制"
Item(0).ControlCount= 1
Item(0).Control(0)= "ResizerPicture"
Item(1).Caption = "进程管理"
Item(1).ControlCount= 4
Item(1).Control(0)= "lstTask"
Item(1).Control(1)= "labTaskTotal"
Item(1).Control(2)= "cmdRefreshTasks"
Item(1).Control(3)= "cmdKillTasks"
Item(2).Caption = "文件管理"
Item(2).ControlCount= 4
Item(2).Control(0)= "lstFile"
Item(2).Control(1)= "labTip"
Item(2).Control(2)= "edPath"
Item(2).Control(3)= "cmdOpenDir"
Item(3).Caption = "运行VBS脚本"
Item(3).ControlCount= 2
Item(3).Control(0)= "edVBS"
Item(3).Control(1)= "cmdRunVBS"
Item(4).Caption = "命令行"
Item(4).ControlCount= 3
Item(4).Control(0)= "edCommandLine"
Item(4).Control(1)= "cmdRunCommandline"
Item(4).Control(2)= "edCommandlineEnter"
Item(5).Caption = "系统信息"
Item(5).ControlCount= 1
Item(5).Control(0)= "edInformation"
Begin XtremeSuiteControls.ListView lstFile
Height = 2775
Left = -69880
TabIndex = 14
Top = 840
Visible = 0 'False
Width = 8895
_Version = 786432
_ExtentX = 15690
_ExtentY = 4895
_StockProps = 77
BackColor = 16777152
Checkboxes = -1 'True
View = 3
FullRowSelect = -1 'True
HotTracking = -1 'True
BackColor = 16777152
Appearance = 6
UseVisualStyle = -1 'True
End
Begin XtremeSuiteControls.ListView lstTask
Height = 2775
Left = -69880
TabIndex = 2
Top = 360
Visible = 0 'False
Width = 8535
_Version = 786432
_ExtentX = 15055
_ExtentY = 4895
_StockProps = 77
BackColor = 16777152
Checkboxes = -1 'True
View = 3
FullRowSelect = -1 'True
BackColor = 16777152
Appearance = 6
UseVisualStyle = -1 'True
End
Begin VB.TextBox edCommandlineEnter
BackColor = &H00FFFFC0&
Height = 372
Left = -69880
TabIndex = 13
Top = 3240
Visible = 0 'False
Width = 7452
End
Begin VB.TextBox edCommandLine
BackColor = &H00FFFFC0&
BeginProperty Font
Name = "宋体"
Size = 10.8
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 2775
Left = -69880
Locked = -1 'True
MultiLine = -1 'True
ScrollBars = 2 'Vertical
TabIndex = 11
Top = 360
Visible = 0 'False
Width = 8895
End
Begin VB.TextBox edVBS
BackColor = &H00FFFFC0&
BeginProperty Font
Name = "宋体"
Size = 10.8
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 2775
Left = -69880
MultiLine = -1 'True
TabIndex = 9
Top = 360
Visible = 0 'False
Width = 8895
End
Begin XtremeSuiteControls.PushButton cmdRefreshTasks
Height = 375
Left = -69880
TabIndex = 6
Top = 3240
Visible = 0 'False
Width = 1335
_Version = 786432
_ExtentX = 2355
_ExtentY = 661
_StockProps = 79
Caption = "点我刷新~"
ForeColor = 16777215
BackColor = 16416003
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 10.8
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Appearance = 3
DrawFocusRect = 0 'False
ImageGap = 1
End
Begin VB.TextBox edInformation
BackColor = &H00FFFFC0&
BeginProperty Font
Name = "宋体"
Size = 14.4
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 1215
Left = -69880
Locked = -1 'True
MultiLine = -1 'True
ScrollBars = 2 'Vertical
TabIndex = 5
Text = "frmRemoteControl.frx":0CCA
Top = 360
Visible = 0 'False
Width = 2055
End
Begin XtremeSuiteControls.Resizer ResizerPicture
Height = 2055
Left = 0
TabIndex = 3
Top = 360
Width = 4095
_Version = 786432
_ExtentX = 7223
_ExtentY = 3625
_StockProps = 1
BackColor = 0
Begin VB.PictureBox picKeyboard
Appearance = 0 'Flat
BackColor = &H80000005&
ForeColor = &H80000008&
Height = 375
Left = 840
ScaleHeight = 348
ScaleWidth = 348
TabIndex = 21
Top = 120
Width = 375
End
Begin VB.PictureBox picMain
AutoRedraw = -1 'True
Height = 612
Left = 0
ScaleHeight = 564
ScaleWidth = 564
TabIndex = 4
Top = 0
Visible = 0 'False
Width = 612
End
Begin VB.Image imgMain
BorderStyle = 1 'Fixed Single
Height = 1215
Left = 0
Stretch = -1 'True
Top = 0
Width = 1575
End
End
Begin XtremeSuiteControls.PushButton cmdKillTasks
Height = 372
Left = -68320
TabIndex = 8
Top = 3240
Visible = 0 'False
Width = 1332
_Version = 786432
_ExtentX = 2355
_ExtentY = 661
_StockProps = 79
Caption = "点我结束~"
ForeColor = 16777215
BackColor = 16416003
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 10.8
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Appearance = 3
DrawFocusRect = 0 'False
ImageGap = 1
End
Begin XtremeSuiteControls.PushButton cmdRunVBS
Height = 375
Left = -69880
TabIndex = 10
Top = 3240
Visible = 0 'False
Width = 1335
_Version = 786432
_ExtentX = 2355
_ExtentY = 661
_StockProps = 79
Caption = "点我执行~"
ForeColor = 16777215
BackColor = 16416003
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 10.8
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Appearance = 3
DrawFocusRect = 0 'False
ImageGap = 1
End
Begin XtremeSuiteControls.PushButton cmdRunCommandline
Height = 372
Left = -62320
TabIndex = 12
Top = 3240
Visible = 0 'False
Width = 1332
_Version = 786432
_ExtentX = 2355
_ExtentY = 661
_StockProps = 79
Caption = "点我执行~"
ForeColor = 16777215
BackColor = 16416003
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 10.8
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Appearance = 3
DrawFocusRect = 0 'False
ImageGap = 1
End
Begin XtremeSuiteControls.PushButton cmdOpenDir
Height = 375
Left = -61960
TabIndex = 16
Top = 360
Visible = 0 'False
Width = 975
_Version = 786432
_ExtentX = 1720
_ExtentY = 661
_StockProps = 79
Caption = "转到"
ForeColor = 16777215
BackColor = 16416003
Appearance = 3
DrawFocusRect = 0 'False
ImageGap = 1
End
Begin XtremeSuiteControls.FlatEdit edPath
Height = 375
Left = -68800
TabIndex = 17
Top = 360
Visible = 0 'False
Width = 6735
_Version = 786432
_ExtentX = 11880
_ExtentY = 661
_StockProps = 77
BackColor = 16777152
Text = "根目录"
BackColor = 16777152
Appearance = 4
UseVisualStyle = -1 'True
End
Begin VB.Label labTip
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "当前目录："
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 240
Left = -69880
TabIndex = 15
Top = 400
Visible = 0 'False
Width = 1200
End
Begin VB.Label labTaskTotal
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "共0个进程。"
BeginProperty Font
Name = "宋体"
Size = 10.8
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 216
Left = -66760
TabIndex = 7
Top = 3360
Visible = 0 'False
Width = 1152
End
End
Begin XtremeSuiteControls.Resizer ResizerMain
Height = 765
Left = 0
TabIndex = 0
Top = 0
Width = 9855
_Version = 786432
_ExtentX = 17383
_ExtentY = 1349
_StockProps = 1
BackColor = 16777088
VScrollLargeChange= 1000
VScrollSmallChange= 200
HScrollLargeChange= 1000
HScrollSmallChange= 200
BorderStyle = 4
Begin XtremeSuiteControls.PushButton cmdBlockInput
Height = 720
Left = 0
TabIndex = 18
ToolTipText = "锁定对方的鼠标键盘"
Top = 0
Width = 2600
_Version = 786432
_ExtentX = 4586
_ExtentY = 1270
_StockProps = 79
Caption = "锁定远程鼠标键盘"
BackColor = 16777152
TextAlignment = 1
Appearance = 6
Picture = "frmRemoteControl.frx":0CD6
ImageAlignment = 0
End
Begin XtremeSuiteControls.PushButton cmdIsControlling
Height = 720
Left = 2640
TabIndex = 19
ToolTipText = "开启控制对方的鼠标键盘"
Top = 0
Width = 2595
_Version = 786432
_ExtentX = 4586
_ExtentY = 1270
_StockProps = 79
Caption = "开启控制对方鼠标键盘"
BackColor = 16777152
TextAlignment = 1
Appearance = 6
Checked = -1 'True
Picture = "frmRemoteControl.frx":19B0
ImageAlignment = 0
End
Begin XtremeSuiteControls.PushButton cmdAutoResize
Height = 720
Left = 5280
TabIndex = 20
ToolTipText = "自动拉伸屏幕画面"
Top = 0
Width = 2595
_Version = 786432
_ExtentX = 4586
_ExtentY = 1270
_StockProps = 79
Caption = "自动拉伸屏幕画面"
BackColor = 16777152
TextAlignment = 1
Appearance = 6
Picture = "frmRemoteControl.frx":268A
ImageAlignment = 0
End
End
Begin MSWinsockLib.Winsock wsPicture
Left = 8040
Top = 4920
_ExtentX = 593
_ExtentY = 593
_Version = 393216
End
Begin MSWinsockLib.Winsock wsMessage
Left = 8640
Top = 4920
_ExtentX = 593
_ExtentY = 593
_Version = 393216
End
Begin VB.Menu mnuPopup
Caption = "PopupMenu"
Visible = 0 'False
Begin VB.Menu mnuRefresh
Caption = "刷新(&R)"
End
Begin VB.Menu mnuMkdir
Caption = "新建文件夹(&N)"
End
Begin VB.Menu mnuRename
Caption = "重命名(&M)"
End
Begin VB.Menu mnuCopy
Caption = "复制(&C)"
End
Begin VB.Menu mnuCut
Caption = "剪切(&U)"
End
Begin VB.Menu mnuPaste
Caption = "粘贴(&P)"
Enabled = 0 'False
End
Begin VB.Menu mnuDelete
Caption = "删除(&D)"
End
End
End
Attribute VB_Name = "frmRemoteControl"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Const BI_RGB = 0&
Private Const DIB_RGB_COLORS = 0 ' color table in RGBs
Private Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Private Type BITMAPINFOHEADER '40 bytes
biSize As Long 'BITMAPINFOHEADER结构的大小
biWidth As Long
biHeight As Long
biPlanes As Integer '设备的为平面数，现在都是1
biBitCount As Integer '图像的颜色位图
biCompression As Long '压缩方式
biSizeImage As Long '实际的位图数据所占字节
biXPelsPerMeter As Long '目标设备的水平分辨率
biYPelsPerMeter As Long '目标设备的垂直分辨率
biClrUsed As Long '使用的颜色数
biClrImportant As Long '重要的颜色数 如果该项为0，表示所有颜色都是重要的
End Type
Private Type RGBQUAD '只有bibitcount为1，2，4时才有调色板
Blue As Byte '蓝色分量
Green As Byte '绿色分量
Red As Byte '红色分量
Reserved As Byte '保留值
End Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors(255) As RGBQUAD
End Type
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal dx As Long, ByVal dY As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
'=========================================================================
'以下为zlib压缩的函数
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Private Declare Function uncompress Lib "zlib.dll" (dest As Any, destLen As Any, src As Any, ByVal srcLen As Long) As Long
Private Const OFFSET As Long = &H8
'以下为屏幕显示参数及各种屏幕数据
Dim W As Long, H As Long, M As Long
Dim x, y As Long, dwCurrentThreadID1 As Long
Dim J As Byte, g As Long
Dim T As Boolean
Dim bmpLen As Long, F As Byte
Dim CapName As String
Dim iBitmap2 As Long, iDC2 As Long
Dim iBitmap1 As Long, iDC1 As Long
Dim iBitmap3 As Long, iDC3 As Long
Dim bi24BitInfo As BITMAPINFO
Dim xData As Long
'==========================================
'以下为各种乱七八糟的变量
Dim TwipsX, TwipsY As Single '屏幕每个像素的Twip数
Dim DataPerSecond As Long '每秒钟的流量数
Dim DataPerSecondOld As Long '上一次计数的每秒钟流量数
Dim sDataRec As String '数据分段用的缓存：有时候数据量太大Winsock强制分包时就要用到我啦~
Dim bMultiData As Boolean '是否为多包数据分段模式
Function UnCompressByte(ByteArray() As Byte) '解压缩过程
Dim origLen As Long
Dim BufferSize As Long
Dim TempBuffer() As Byte
Call CopyMemory(origLen, ByteArray(0), OFFSET)
BufferSize = origLen
BufferSize = BufferSize + (BufferSize * 0.01) + 12
ReDim TempBuffer(BufferSize)
UnCompressByte = (uncompress(TempBuffer(0), BufferSize, ByteArray(OFFSET), UBound(ByteArray) - OFFSET + 1) = 0)
ReDim Preserve ByteArray(0 To BufferSize - 1)
CopyMemory ByteArray(0), TempBuffer(0), BufferSize
End Function
Public Sub Del_dc() '删除内存DC过程
DeleteDC iDC1
DeleteObject iBitmap1
DeleteDC iDC2
DeleteObject iBitmap2
End Sub
Public Function DCload()
iDC1 = CreateCompatibleDC(Me.hdc) '1
iBitmap1 = CreateCompatibleBitmap(Me.hdc, W, H * F) '显示区域设置
SelectObject iDC1, iBitmap1
iDC2 = CreateCompatibleDC(Me.hdc) '2
iBitmap2 = CreateCompatibleBitmap(Me.hdc, W, H) '显示区域设置
SelectObject iDC2, iBitmap2
End Function
Private Sub GetWindows() '获取接收到的屏幕
Dim Bmp As BITMAP
Dim hdc As Long, BD As Long
Dim Tpicture As Boolean
Dim bBytes() As Byte
'=======
g = J * H
'============
If T Then
Me.wsPicture.GetData bBytes, vbArray Or vbByte
If bCompress = True Then
UnCompressByte bBytes '解压
End If
SetDIBitsToDevice iDC2, 0, 0, W, H, 0, 0, 0, H, bBytes(0), bi24BitInfo, DIB_RGB_COLORS
BitBlt iDC1, 0, g, W, H, iDC2, 0, 0, vbSrcInvert 'xor'相反
BitBlt Me.picMain.hdc, 0, g, W, H, iDC1, 0, g, vbSrcCopy
Me.picMain.Refresh
Me.imgMain.Picture = Me.picMain.Image
End If
'============
If Not T Then
Call New_dc
T = True
End If
Dim a(2) As Byte
Me.wsPicture.SendData a
'========
End Sub
Private Sub New_dc() '创建内存DC过程
Dim bi24BitInfo As BITMAPINFO, bBytes() As Byte
Me.wsPicture.GetData bBytes, vbArray Or vbByte
If bCompress = True Then
UnCompressByte bBytes '解压
End If
With bi24BitInfo.bmiHeader
.biBitCount = 16
.biCompression = BI_RGB
.biPlanes = 1
.biSize = Len(bi24BitInfo.bmiHeader)
.biWidth = W
.biHeight = H * F
End With
SetDIBitsToDevice iDC1, 0, 0, W, H * F, 0, 0, 0, H * F, bBytes(0), bi24BitInfo, DIB_RGB_COLORS
End Sub
Public Function IsIPExists(strIP As String) As Integer
For i = 0 To frmMain.comIP.ListCount - 1 '扫一遍主窗体的IP列表
If frmMain.comIP.List(i) = strIP Then '找到了相同的IP的话
IsIPExists = i '返回Index
Exit Function '退出过程
End If
Next i
IsIPExists = -1 '找不到相同的话就返回-1
End Function
'=======================================================================
Public Sub ConnectedHandler() '连接后的处理过程
Dim iLstIP As Integer '列表中的IP位置
Me.Caption = "远程控制: " & Me.wsMessage.RemoteHostIP '更改标题
iLstIP = IsIPExists(frmMain.comIP.Text)
If iLstIP <> -1 Then '如果检测到这个IP连接过
wsSendData Me.wsMessage, "CNT|" & frmMain.lstPassword.List(iLstIP) '发送带密码的请求
Exit Sub
End If
If frmMain.lstPassword.List(frmMain.comIP.ListIndex) <> "" Then '如果记录里有密码
wsSendData Me.wsMessage, "CNT|" & frmMain.lstPassword.List(frmMain.comIP.ListIndex) '发送带密码的请求
Else
wsSendData Me.wsMessage, "CNT" '没密码就发送连接建立请求
End If
End Sub
Public Function GetListSelCount() As Integer '获取列表中选择的项目数
Dim Total As Integer '选择的项目数
'=========================================
For i = 1 To Me.lstFile.ListItems.Count
If Me.lstFile.ListItems(i).Checked = True Then '打了勾的就加进去~
Total = Total + 1
End If
Next i
GetListSelCount = Total
End Function
Private Sub cmdAutoResize_Click()
Me.cmdAutoResize.Checked = Not Me.cmdAutoResize.Checked '反选
AutoResize = Me.cmdAutoResize.Checked '调整是否拉伸画面状态
Call Form_Resize '窗体重新排版
Call SaveConfig '保存配置文件
End Sub
Private Sub cmdBlockInput_Click()
Me.cmdBlockInput.Checked = Not Me.cmdBlockInput.Checked '反选
If Me.cmdBlockInput.Checked = True Then '锁定状态
wsSendData Me.wsMessage, "BLK" '发送锁定鼠标键盘消息
Else
wsSendData Me.wsMessage, "ULK" '发送解锁鼠标键盘消息
End If
End Sub
Private Sub cmdIsControlling_Click()
Me.cmdIsControlling.Checked = Not Me.cmdIsControlling.Checked '反选
IsControlling = Me.cmdIsControlling.Checked '调整控制状态
End Sub
Private Sub cmdKillTasks_Click()
Dim SendTemp As String '要发送的数据缓存
Dim IsChecked As Boolean '是否有选择东西
'========================================
IsChecked = False
For i = 1 To Me.lstTask.ListItems.Count '遍历列表，看看要结束哪个
If Me.lstTask.ListItems(i).Checked = True Then
'加入到发送数据缓存中
SendTemp = SendTemp & Me.lstTask.ListItems(i).Text & "|" & Me.lstTask.ListItems(i).SubItems(1) & vbCrLf
IsChecked = True '有发送的东西
End If
Next i
If IsChecked = False Then '没有选择东西？！
MsgBox "你都没选择进程让我结束什么？！", 64
Else
a = MsgBox("确认结束选择的进程？这可能造成数据丢失等后果！", 32 + vbYesNo, "确认") '确认框
If a <> 6 Then
Exit Sub
End If
wsSendData Me.wsMessage, "KTS|" & SendTemp '如果有选择进程就发送结束进程请求
End If
End Sub
Private Sub cmdOpenDir_Click()
wsSendData Me.wsMessage, "VPH|" & Me.edPath.Text '发送打开目录请求
End Sub
Private Sub cmdRefreshTasks_Click()
wsSendData Me.wsMessage, "TSK" '发送获取进程请求
End Sub
Private Sub cmdRunCommandline_Click()
If Trim(Me.edCommandlineEnter.Text) = "" Then '不接受空命令
Exit Sub
End If
wsSendData Me.wsMessage, "CMD|" & Me.edCommandlineEnter.Text '发送执行命令行请求
Me.edCommandlineEnter.Text = "执行中，请稍后..."
Me.edCommandlineEnter.Enabled = False
End Sub
Private Sub cmdRunVBS_Click()
wsSendData Me.wsMessage, "VBS|" & Me.edVBS.Text '发送执行VBS请求
End Sub
Private Sub edCommandlineEnter_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then '按下回车键就执行命令
Call cmdRunCommandline_Click
KeyAscii = 0
End If
End Sub
Private Sub edPath_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
KeyAscii = 0
Call cmdOpenDir_Click '调用按钮按下过程
End If
End Sub
Private Sub Form_Load()
Me.Icon = frmMain.imgMainIcon.Picture '更改图标，为了更好看 (*^__^*)
'==================================================
Me.lstTask.ColumnHeaders.Add , , "进程名称", 1500
Me.lstTask.ColumnHeaders.Add , , "PID", 600
Me.lstTask.ColumnHeaders.Add , , "程序路径", 4000
'==================================================
Me.lstFile.ColumnHeaders.Add , , "名称", 2000
Me.lstFile.ColumnHeaders.Add , , "类型", 800
Me.lstFile.ColumnHeaders.Add , , "大小", 3000
'==================================================
Me.picKeyboard.Left = -10
Me.picKeyboard.Top = -10
Me.picKeyboard.Width = 1
Me.picKeyboard.Height = 1
IsControlling = True '控制模式
'==================================================
If AutoResize Then
Me.cmdAutoResize.Checked = True
End If
'==================================================
If bMouseWheelHook = True Then
PrevWndProc = SetWindowLong(Me.picKeyboard.hwnd, GWL_WNDPROC, AddressOf WndProc) '启动鼠标滚轮事件拦截
End If
End Sub
Private Sub Form_Resize()
On Error Resume Next
If Me.Height < 3000 Then
Me.Height = 3000
End If
If Me.Width < 4000 Then
Me.Width = 4000
End If
'-------------------------------------------------
'调整各种控件的大小和状态以适应窗体
Me.ResizerMain.Width = Me.Width - 240
'==========================================
Me.TabMain.Width = Me.Width - 240 '总选项卡
Me.TabMain.Height = Me.Height - Me.ResizerMain.Height - 480
'==========================================
Me.ResizerPicture.Width = Me.TabMain.Width - 120 '屏幕显示部分
Me.ResizerPicture.Height = Me.TabMain.Height - 480
If AutoResize = True Then '如果是自动拉伸画面的话就让图片框适应窗体
Me.imgMain.Width = Me.ResizerPicture.Width
Me.imgMain.Height = Me.ResizerPicture.Height
Me.ResizerPicture.HScrollMaximum = 0 '不加滚动条
Me.ResizerPicture.VScrollMaximum = 0
Else '否则让他适应原图
Me.imgMain.Width = Me.picMain.Width
Me.imgMain.Height = Me.picMain.Height
Me.ResizerPicture.HScrollMaximum = Me.picMain.Width '添加滚动条
Me.ResizerPicture.VScrollMaximum = Me.picMain.Height
End If
ScreenScaleW = Me.imgMain.Width / (W * TwipsX) '计算压缩图和原图的比例尺
ScreenScaleH = Me.imgMain.Height / (H * F * TwipsY)
'==========================================
Me.lstTask.Width = Me.TabMain.Width - 240 '进程部分
Me.lstTask.Height = Me.TabMain.Height - 1000
Me.cmdRefreshTasks.Top = Me.lstTask.Top + Me.lstTask.Height + 120
Me.cmdKillTasks.Top = Me.cmdRefreshTasks.Top
Me.labTaskTotal.Top = Me.cmdRefreshTasks.Top
'==========================================
Me.cmdOpenDir.Left = Me.TabMain.Width - Me.cmdOpenDir.Width - 120 '文件管理部分
Me.edPath.Width = Me.cmdOpenDir.Left - Me.edPath.Left - 120
Me.lstFile.Height = Me.TabMain.Height - 240 - Me.lstFile.Top
Me.lstFile.Width = Me.TabMain.Width - 240
'==========================================
Me.edVBS.Width = Me.TabMain.Width - 240 'VBS代码部分
Me.edVBS.Height = Me.TabMain.Height - 1000
Me.cmdRunVBS.Top = Me.cmdRefreshTasks.Top
'==========================================
Me.edInformation.Width = Me.TabMain.Width - 120 '系统信息部分
Me.edInformation.Height = Me.TabMain.Height - 480
'==========================================
Me.edCommandLine.Width = Me.TabMain.Width - 120 '命令行操作部分
Me.edCommandLine.Height = Me.TabMain.Height - 1000
Me.edCommandlineEnter.Width = Me.TabMain.Width - 360 - Me.cmdRunCommandline.Width
Me.edCommandlineEnter.Top = Me.lstTask.Top + Me.lstTask.Height + 120
Me.cmdRunCommandline.Top = Me.cmdRefreshTasks.Top
Me.cmdRunCommandline.Left = Me.edCommandlineEnter.Left + Me.edCommandlineEnter.Width + 120
End Sub
Private Sub Form_Unload(Cancel As Integer) '关闭窗体即断开连接
Me.wsMessage.Close
Me.wsPicture.Close
Dim OpenPath As String '程序自身的路径
OpenPath = IIf(Right(App.Path, 1) = "\", App.Path & App.EXEName & ".exe", App.Path & "\" & App.EXEName & ".exe")
Shell OpenPath, vbNormalFocus '沉舟侧畔千帆过 病树前头万木春
End '我老了，不中用了，该上路了。
End Sub
Private Sub lstFile_DblClick()
'获取类型并分类型发送请求
On Error Resume Next
Select Case Me.lstFile.ListItems.Item(Me.lstFile.SelectedItem.Index).SubItems(1)
Case "驱动器"
wsSendData Me.wsMessage, "GPH|" & Me.lstFile.SelectedItem.Index
Case "目录"
wsSendData Me.wsMessage, "GPH|" & Me.lstFile.SelectedItem.Index
Case "上层目录"
wsSendData Me.wsMessage, "GUD"
End Select
End Sub
Private Sub lstFile_ItemCheck(ByVal Item As XtremeSuiteControls.ListViewItem)
On Error Resume Next
For i = 1 To Me.lstFile.ListItems.Count
'如果是磁盘 或者 上层目录选项
If InStr(Me.lstFile.ListItems(i).SubItems(2), "空闲:") <> 0 Or Me.lstFile.ListItems(i).SubItems(1) = "上层目录" Then
Me.lstFile.ListItems(i).Checked = False
End If
Next i
End Sub
Private Sub lstFile_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim sCount As Integer '选择了的列表项数
'----------------------------------
If Button = 2 Then '按下右键弹出菜单
sCount = GetListSelCount
Me.mnuMkdir.Visible = True
Me.mnuPaste.Visible = True
If sCount = 0 Then '分情形弹出菜单
Me.mnuCopy.Visible = False '没有选择列表项则 复制、剪切、删除、重命名功能失效
Me.mnuCut.Visible = False
Me.mnuDelete.Visible = False
Me.mnuRename.Visible = False
Else
Me.mnuCopy.Visible = True
Me.mnuCut.Visible = True
Me.mnuDelete.Visible = True
Me.mnuRename.Visible = True
End If
If sCount > 1 Then '如果选择了多于一个列表项则 重命名功能失效
Me.mnuRename.Visible = False
End If
If InStr(Me.lstFile.ListItems(1).ListSubItems(2).Text, "空闲:") <> 0 Then '如果是磁盘根目录则只留下刷新
Me.mnuMkdir.Visible = False
Me.mnuPaste.Visible = False
End If
PopupMenu Me.mnuPopup
End If
End Sub
Private Sub mnuCopy_Click()
Dim tmpSendString As String '发送数据缓存
'----------------------------------
tmpSendString = "CPY|"
Me.mnuPaste.Enabled = True
For i = 1 To Me.lstFile.ListItems.Count
If Me.lstFile.ListItems(i).Checked = True Then '往缓存里面添加打了勾的列表项
tmpSendString = tmpSendString & i & "|"
End If
Next i
wsSendData Me.wsMessage, tmpSendString '发送复制文件请求
End Sub
Private Sub mnuCut_Click()
Dim tmpSendString As String '发送数据缓存
'----------------------------------
tmpSendString = "CUT|"
Me.mnuPaste.Enabled = True
For i = 1 To Me.lstFile.ListItems.Count
If Me.lstFile.ListItems(i).Checked = True Then '往缓存里面添加打了勾的列表项
tmpSendString = tmpSendString & i & "|"
End If
Next i
wsSendData Me.wsMessage, tmpSendString '发送剪切文件请求
End Sub
Private Sub mnuDelete_Click()
Dim tmpSendString As String '发送数据缓存
'----------------------------------
If GetListSelCount = 0 Then
Exit Sub
End If
a = MsgBox("您真的要删除选择的" & GetListSelCount & "个文件（夹）吗？该操作不可撤销。", 32 + vbYesNo, "确认")
If a <> 6 Then
Exit Sub
End If
tmpSendString = "DEL|"
For i = 1 To Me.lstFile.ListItems.Count
If Me.lstFile.ListItems(i).Checked = True Then '往缓存里面添加打了勾的列表项
tmpSendString = tmpSendString & i & "|"
End If
Next i
wsSendData Me.wsMessage, tmpSendString '发送删除文件请求
End Sub
Private Sub mnuMkdir_Click()
Dim fName As String '文件夹名字缓存
fName = InputBox("请输入新文件夹的名字：", "输入")
If Trim(fName) <> "" Then
If InStr(fName, "|") = 0 Then
wsSendData Me.wsMessage, "MKD|" & fName '发送创建文件夹请求
Else
MsgBox "创建文件夹失败。", 64, "创建文件夹失败"
End If
End If
End Sub
Private Sub mnuPaste_Click()
wsSendData Me.wsMessage, "PST" '发送粘贴请求
End Sub
Private Sub mnuRefresh_Click()
wsSendData Me.wsMessage, "REF" '发送刷新请求
End Sub