Форум программистов, компьютерный форум, киберфорум
Visual Basic
Войти
Регистрация
Восстановить пароль
 
Рейтинг 4.80/5: Рейтинг темы: голосов - 5, средняя оценка - 4.80
18 / 0 / 0
Регистрация: 02.02.2013
Сообщений: 3
1

Шифровка файлов с паролем

10.02.2013, 23:28. Просмотров 1036. Ответов 7
Метки нет (Все метки)


Нашел в сети интересный код, рабочий. В коде формы надо поменять так чтобы при запуске шифровался определенный файл с определенным паролем например пароль "qwerty" файл "C:\Program Files\Soft\test.exe"

Форма

Visual Basic
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
Option Explicit
Dim gstrCurrentFolder As String
 
Private Sub cmdCrypto_Click()
'enc/dec file
Dim tmpname
Call LockKeys
tmpname = UltraFile(Me.txtSource.Text, Me.txtTarget.Text, Me.txtKey.Text, Me.txtPCC.Text)
If UltraReturnValue = 0 Then
    'no error, change to new name
    If Me.txtSource.Text = Me.txtTarget.Text Then
        Me.txtSource.Text = tmpname
        Me.txtTarget.Text = tmpname
        Else
        Me.txtTarget.Text = tmpname
        End If
    Else
    'error, set msgbox
    MsgBox UltraReturnString, vbCritical
End If
Call FreeKeys
End Sub
 
Private Sub cmdCancelFile_Click()
'abort the file encryption
AbortUltraRun = True
End Sub
 
Private Sub cmdText_Click()
'end/dec text
Call LockKeys
Me.txtBox.Text = UltraText(Me.txtBox.Text, Me.txtKey.Text, Me.txtPCC.Text)
'check for errors
If UltraReturnValue <> 0 Then
    MsgBox UltraReturnString, vbCritical
    End If
Call FreeKeys
End Sub
 
Private Sub cmdCancelText_Click()
'abort the text encryption
AbortUltraRun = True
End Sub
 
Private Sub Command2_Click()
End
End Sub
 
Private Sub Command3_Click()
Form2.Visible = True
End Sub
 
Private Sub txtKey_Change()
Me.lblKeyQuality.Caption = "Key Quality: " & Str(KeyQuality(Me.txtKey.Text)) & "%"
End Sub
 
 
Private Sub txtBox_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'feed random data to seedstring
Call RandomFeed(X, Y)
End Sub
 
Private Sub LockKeys()
' enable only the cancel command
Me.cmdCrypto.Enabled = False
Me.cmdSource.Enabled = False
Me.cmdTarget.Enabled = False
Me.cmdCancelFile.Enabled = True
End Sub
 
Private Sub FreeKeys()
' enable all commands except canel
Me.cmdCrypto.Enabled = True
Me.cmdSource.Enabled = True
Me.cmdTarget.Enabled = True
Me.cmdCancelFile.Enabled = False
End Sub
 
 
'----------------------------------------------------------------------
Private Sub cmdSource_Click()
'get source file
On Error Resume Next
With Form1.CommonDialog1
.FileName = ""
.DialogTitle = "UltraSecurityFiles | Выберите файл jpg"
.Filter = "Image (*jpg*)|*jpg*"
.InitDir = gstrCurrentFolder
.FilterIndex = 1
.Flags = &H4
.FileName = ""
.ShowSave
If Err = 32755 Then ' cancel
    '
    Else
    Me.txtSource.Text = .FileName
    Me.txtTarget.Text = .FileName
    gstrCurrentFolder = CurDir$
    End If
End With
End Sub
 
Private Sub cmdTarget_Click()
'get target file
On Error Resume Next
With Form1.CommonDialog1
.FileName = ""
.DialogTitle = "UltraSecurityFiles | Выберите файл jpg"
.Filter = "Image(*jpg*)|*jpg*"
.InitDir = gstrCurrentFolder
.FilterIndex = 1
.Flags = &H4
.FileName = ""
.ShowSave
If Err = 32755 Then ' cancel
    '
    Else
    Me.txtTarget.Text = .FileName
    gstrCurrentFolder = CurDir$
    End If
End With
End Sub








Модуль


Visual Basic
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
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
'            ULTRA v1.0.3 Cryptographic Algorithm (c) 2004
'
'          Developed and written by D. Rijmenants
'
'    Features:
'
'  - Variable-lenght tripple transposition key
'  - Fast symmetric stream cipher in output feedback mode
'  - Optional exclusive users groups by PCC (Private Crypto Code)
'  - Each encryption with the same key and data is different due random header
'  - Full file handling support, including extension encryption
'  - Text encryption to text crypto format
'  - Data compression before ciphering to strenghten encryption
'  - Public functions return error codes and descriptions
'  - Progress visualization by simple picturebox control
'  - Optimized for Visual Basic
'-----------------------------------------------------------------
'
'         >>>  Using this encryption module <<<
'
' This code will give your project a strong encytion for text and files.
' The data is encrypted and decrypted with a variable lenght key and,
' if desired, a second PCC-key (Private Crypto Code) is used to create
' an exclusive user group. In this well documented description you will
' find all information to use, personalize and speedup this code.
'
' Public functions descriptions
'
' >>> UltraFile - file encoding/decoding function:
'
' return = UltraFile(Source, Target, Key, PCC)
'
' Where:
' Source (string) full path filename of the file to enc/decode
' Target (string) full path filename of the file after enc/decode
' Key    (string) keystring containing ASCII values 0-255
' PCC    (string) Private Crypto Code (use nullstring is not required)
' return (string) contains the new filename and extension after succesfull enc/decoding
'
' Notes:
' After encrypting a file, the filetype extension is included in the
' encryption and the files extension is changed in .ucc
' After proper decrypting the original extension is retrieved.
' When using the same name for source and target, the original file
' will be deleted using the Kill statement (no secure deleting !)
' Know problem: When file size exceeds available free memory the
' program could slowdown by fileswapping or even lockup.
'
' >>> UltraText - ASCII text encoding/decoding function:
'
' return = UltraText(Text, Key, PCC)
'
' Where:
' Text   (string) ASCII string to be enc/decoded
' Key    (string) keystring containing ASCII values 0-255
' PCC    (string) Private Crypto Code (use nullstring is not required)
' return (string) contains the enc/decoded text after succesfull dec/encoding
'
' Notes:
' When decryption failes, the original text is returned.
' After encrypting, the text will have the ULTRA crypto format
' without this format header and trailing the text is not
' recognized as ULTRA message.
'
' Example ULTRA message:
'
' --- BEGIN ULTRA MESSAGE ---
' Version: ULTRA v1.0.3
' mRqReWO2ruK/4ZY+EZiyJJTZ....(encrypted text)...
' --- END OF MESSAGE ---
'
'
'
' >>> Abort enc/decoding using a commandbutton
'
' You can abort the running file encode or decode process by changing
' the AbortUltraRun boolean value into True. You need a commandbutton
' (with caption 'Cancel') that sets AbortUltraRun True. After aborting
' the value automaticly resets. This cancel generates error 11 or 21.
' IMPORTANT: disable all other controles during process !!!
'
' Example:
'
' Private Sub commandButtonCancel_Click()
' AbortUltraRun = True
' End Sub
'
' Note: if the cancel feature is not required you can speedup the
' process by deleting all "If AbortUltraRun = True Then Exit For"
' and "DoEvent" codelines in this module.
'
'
' >>> Checking the key quality
'
' To have some idea about the quality of the key you can use the
' KeyQuality function. The function gives a score between 0 and 100
' depending on the variaty of characters, used for that key. This
' value can be used to show a percentage or a quality progress bar.
' See the general notes for more info on keys.
'
' return = KeyQuality(Key)
'
' Where:
' Key    (string)  keystring to be checked
' return (integer) quality value 0 to 100
'
' Example on using the function with a progressbar,
' to check during key entry in the txtKey textbox:
'
' Private Sub txtKey_Change()
' MyForm.ProgressBar1.Value = KeyQuality(MyForm.txtKey.text)
' End Sub
'
' Note: Set the ProgressBar Max value at 100
'
' >>> Visualize the enc/decoding progress:
'
' This code contains a sub called UpdateStatus() that enables you
' to view the progress of encoding and decoding. It uses a simple
' picturbox that you place on your form to draw a progressbar.
' When the progressbar is not used you can speedup encryption process
' by deleting the marked code lines in the routines EncodeByteArray,
' DecodeByteArray, HuffEncodeByte, HuffDecodeByte, EncodeFile and
' DecodeFile, and by deleting all Updatestatus(x) lines.
' Please check this UpdateStatus subroutine and adjust it to your
' needs in order to let it work properly !!!
'
'
'
' >>> Generating the random dummy header:
'
' To encrypt data the program uses a random dummy header that is
' encrypted to ensure that the keysettings in the beginning of the
' actual data is impossible to retrieve, unless the random byte
' sequence is properly decrypted during decoding. The program will
' use the randomize and rnd function to generate a random sequence.
' Optional, to generate a really random sequence, the user can feed
' random data to a seedstring by using the RandomFeed function in
' this code. Since the encryption of this dummy header is critical,
' the user should consider writing additional code to generate random
' data, for example by keystrokes and/or mousemoves on all objects
' such as textboxes, forms or commandbuttons as in this example:
'
' Private Sub Form1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
' Call RandomFeed(x, y)
' End Sub
'
'
' >>> Error reporting:
'
' To identify error the following public variables are used:
'
' UltraReturnValue (Integer) returns error number after enc/decoding
' UltraReturnString (String) returns error description after enc/decoding
'
' Example using the returns after using file or text enc/decoding:
'
' If UltraReturnValue <> 0 Then
'     MsgBox UltraReturnString, vbCritical
' End If
'
' Error list:
'
' Err= Description
' ----------------
'  0 = No errors found
'  1 = Cannot continue without text
'  2 = Cannot continue without key
'  3 = Key too small/is repeating
'  4 = Source file not found
'  5 = Compression checksum error (data corrupted)
' 10 = Crypto version unknown/contains errors
' 11 = Encoding has been aborted by user
' 12 = File error and File Error Description (during encoding)
' 20 = Crypto file version unknown/contains errors
' 21 = Decoding has been aborted by user
' 22 = File error and File Error Description (during decoding)
' 23 = Failed decoding the file (bad Key, PCC or corrupted data)
' 30 = Crypto header or footer format incomplete/contains errors
' 33 = Failed decoding the text (bad Key, PCC or corrupted data)
'
'
'
' >>> General notes:
'
' The key is a string of variable lenght containing up to 463
' bytes with a ASCII value between 0 and 255 (3704-bit key).
' A secure key should contain at least 5 character, both small and
' capital, as well as figures and signs and may never contain
' repetitions ( aaaaa, abcabc etc.) The program will refuses too
' small or repeating keys.
' When a PCC (Private Crypto Code) is used, only the group of users
' with identical PCC can decrypt the data. This PCC is usually a
' fixed code, defined for a exclusive usergroup. A good PCC-key
' should have the same properties as the main key but the program
' doesn't check it's quality.
' When using this algorithm in your code, it's level of security
' depends entirely on how it is implemented in the software and
' the hardware.
' Known issues: Encrypting files that are larger than the available
' free memory could slow down the program due fileswapping or even
' lockup the program. This is caused by the fact that this code
' loads the entire file into the memory before processing it.
'
'
' >>> Other usefull public functions (check in code below)
'
' KeyQuality
' CheckUltraText
' CheckUltraFile
' FileExist
' GetFileExt
' CutFileExt
' GetFilePath
' CutFilePath
' IsValidKey
'
'
' Comments and suggestions are welcom at: [email]DR.Defcom@telenet.be[/email]
'
'-----------------------------------------------------------------
'
' COPYRIGHT NOTICE
'
' The ULTRA v1.0.3 algorithm is free code and the author encourages
' all cryptanalytic attacks, optimizations, or improvements. The code
' must be available for free and may never be used to make profit
' when supplied as independent piece of code. It is not allowed to use
' the name ULTRA if changes are made to the code without permission
' by the author.
'
' When using this code in your program, please give credit to the
' author by noting 'ULTRA v1.0.3 by Dirk Rijmenants' in the about and
' help sections of your program and in your program code, and notify
' the author at mailadress: [email]DR.Defcom@telenet.be[/email]
'
' Huffman routine originally written by Fredrik Qvarfort
'
'
' All comments, suggestions and questions are welcome at
' mailadress: [email]DR.Defcom@telenet.be[/email]
'
' THIS CODE IS SUPPLIED "AS IS" AND WITHOUT WARRANTIES OF ANY KIND,
' EITHER EXPRESSED OR IMPLIED, WITH RESPECT TO THIS CODE, ITS QUALITY,
' PERFORMANCE, OR FITNESS FOR ANY PARTICULAR PURPOSE. THE ENTIRE RISK
' AS TO ITS QUALITY AND PERFORMANCE IS WITH THE USER. IN NO EVENT WILL
' THE AUTOR BE LIABLE FOR ANY DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES
' RESULTING OUT OF THE USE OF OR INABILITY TO USE THIS CODE.
 
' IMPORTANT NOTICE !
' ABOUT RESTRICTIONS ON IMPORTING STRONG ENCRYPTION ALGORITHMS:
' ULTRA IS A STREAM CIPHER ENCRYPTION ALGORITHM THAT USES A LENGTH-
' VARIABLE KEY. IN SOME COUNTRIES IMPORT OF THIS TYPE OF SOFTWARE IS
' FORBIDDEN BY LAW OR HAS LEGAL RESTRICTIONS.
' CHECK FOR LEGAL RESTRICTIONS ON THIS SUBJECT IN YOUR COUNTRY.
'
' (c) Rijmenants 2004
'
'-----------------------------------------------------------------
 
Option Explicit
 
'--------------------- users public values -------------------------
 
Public UltraReturnValue     As Integer
Public UltraReturnString    As String
Public AbortUltraRun        As Boolean
 
'-----------------------------------------------------------------
 
Private Const PROGRESS_CALCFREQ = 3
Private Const PROGRESS_CALCCRC = 3
Private Const PROGRESS_ENCHUFF = 44
Private Const PROGRESS_DECHUFF = 45
Private Const PROGRESS_CHECKCRC = 5
Private Const PROGRESS_ENCRYPT = 50
Private Const PROGRESS_DECRYPT = 50
 
Private CurrProgresValue As Integer
 
Private Const FILE_VERSION = "= UCC ULTRA v1.0.3 © DEFCOM ="
Private Const TEXT_BEGIN = "--- BEGIN ULTRA MESSAGE ---"
Private Const TEXT_VERSION = "Version: ULTRA v1.0.3"
Private Const TEXT_END = "--- END OF MESSAGE ---"
Private Const TEXT_MAXPERLINE = 60
 
Private K1(0 To 462)  As Integer
Private S1            As Integer
Private P1            As Integer
 
Private K2(0 To 250)  As Integer
Private P2            As Integer
Private S2            As Integer
 
Private K3(0 To 180)  As Integer
Private S3            As Integer
Private P3            As Integer
 
Private FEEDBACK      As Byte
Private SeedString As String
 
 
Private Const PR1 = 463
Private Const PR2 = 251
Private Const PR3 = 181
 
Private aDecTab(255)        As Integer
Private aEncTab(63)         As Byte
Private FileErrDescription  As String
 
Private Type HUFFMANTREE
  ParentNode As Integer
  RightNode As Integer
  LeftNode As Integer
  Value As Integer
  Weight As Long
End Type
 
Private Type byteArray
  Count As Byte
  Data() As Byte
End Type
 
Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
 
' ------------------------------------------------------------
'                   Public Users Functions
' ------------------------------------------------------------
Public Function UltraFile(ByVal Source As String, ByVal Target As String, Key As String, PCC As String) As String
' Encode/decode files
Dim i As Integer
UltraReturnValue = 0
UltraReturnString = ""
FileErrDescription = ""
If IsValidKey(Key) = False Then UltraReturnValue = 3: GoTo skip
If FileExist(Source) = False Then UltraReturnValue = 4: GoTo skip
If FileLen(Source) < 1 Then UltraReturnValue = 6: GoTo skip
i = CheckUltraFile(Source)
Select Case i
Case 0
    UltraFile = EncodeFile(Source, Target, Key, PCC)
Case 1
    UltraFile = DecodeFile(Source, Target, Key, PCC)
Case 2
    UltraReturnValue = 20 'error unkwown version
End Select
skip:
Call SetReturnString
If UltraReturnValue <> 0 Then UltraFile = Source
End Function
 
Public Function UltraText(ByVal aText As String, Key As String, PCC As String) As String
' Encode/decode text
Dim i As Integer
Dim Text As String
UltraReturnValue = 0
UltraReturnString = ""
FileErrDescription = ""
Text = TrimText(aText)
If Text = "" Then UltraReturnValue = 1: GoTo skip
If IsValidKey(Key) = False Then UltraReturnValue = 3: GoTo skip
i = CheckUltraText(Text)
Select Case i
Case 0
    UltraText = EncodeString(Text, Key, PCC)
Case 1
    UltraText = DecodeString(Text, Key, PCC)
Case 2
    UltraReturnValue = 10 'error unkwown version
Case 3
    UltraReturnValue = 30 'error crypto header
End Select
skip:
Call SetReturnString
If UltraReturnValue <> 0 Then UltraText = aText
End Function
 
' ------------------------------------------------------------
'    Progress Bar Picture sub (please adjust to your program code)
' ------------------------------------------------------------
 
Private Sub UpdateStatus(ByVal sngPercent As Single)
' IMPORTANT to use the progressbar:
' The following lines draw a progressbar in a picturebox
' called picProgress on a form called Form1
' change the names of form and picturebox to your own needs
' Set the picturebox Autoredraw property on TRUE !!!
' Set the picturebox Scalewidth property on 100 after sizing pic !!!
' Set the picturebox Forecolor at dark blue, the Backcolor at gray
' When the progressbar is not used you can speedup encryption process
' by deleting the marked code lines in the routines EncodeByteArray,
' DecodeByteArray, EncodeFile and DecodeFile, and by deleting all
' Updatestatus(x) lines.
With Form1.picProgress
If sngPercent > 100 Then sngPercent = 100
If sngPercent = 0 Then .Cls: Exit Sub
.DrawMode = 13
Form1.picProgress.Line (-10, -10)-(sngPercent, .Height + 75), .ForeColor, BF
.Refresh
End With
End Sub
 
' ------------------------------------------------------------
'                   Encryption algorithm functions
' ------------------------------------------------------------
 
Public Sub SetKey(ByVal aKey As String, ByVal aPCC As String)
Dim i           As Long
Dim j           As Long
Dim KEYLen      As Long
Dim KEY1()      As Byte
Dim KEY2(16)    As Byte
Dim KEY3(22)    As Byte
Dim KEYPCC()    As Byte
Dim tmp         As Integer
Dim PCCLen      As Integer
' setup key1 - variable
KEYLen = Len(aKey)
KEY1() = StrConv(aKey, vbFromUnicode)
For i = 0 To PR1 - 1
    K1(i) = i
Next
P1 = 0
S1 = 0
For i = 0 To PR1 - 1
    j = (j + K1(i) + KEY1(i Mod KEYLen)) Mod PR1
    tmp = K1(i)
    K1(i) = K1(j)
    K1(j) = tmp
Next
' setup key2 - 136 bits
For i = 0 To PR1 - 1
    KEY2(i Mod 17) = KEY2(i Mod 17) Xor (K1(i) And 255)
Next
For i = 0 To PR2 - 1
    K2(i) = i
Next
P2 = 0
S2 = 0
For i = 0 To PR2 - 1
    j = (j + K2(i) + KEY2(i Mod 17)) Mod PR2
    tmp = K2(i)
    K2(i) = K2(j)
    K2(j) = tmp
Next
' setup key3 - 184 bits
For i = 0 To PR2 - 1
    KEY3(i Mod 23) = KEY3(i Mod 23) Xor (K2(i) And 255)
Next
PCCLen = Len(aPCC)
KEYPCC() = StrConv(aPCC, vbFromUnicode)
If PCCLen > 0 Then
    For i = 0 To 22
        KEY3(i) = KEY3(i) Xor KEYPCC(i Mod PCCLen)
    Next
    End If
For i = 0 To PR3 - 1
    K3(i) = i
Next i
S2 = 0
P2 = 0
For i = 0 To PR3 - 1
    j = (j + K3(i) + KEY3(i Mod 23)) Mod PR3
    tmp = K3(i)
    K3(i) = K3(j)
    K3(j) = tmp
Next
S3 = 0
P3 = 0
FEEDBACK = 0
aKey = ""
aPCC = ""
End Sub
 
Private Function EncodeByte(aByte As Byte) As Byte
EncodeByte = aByte Xor FnULTRA(FEEDBACK)
FEEDBACK = EncodeByte
End Function
 
Private Function DecodeByte(aByte As Byte) As Byte
Dim tmpbyte As Byte
tmpbyte = aByte
DecodeByte = aByte Xor FnULTRA(FEEDBACK)
FEEDBACK = tmpbyte
End Function
 
Public Sub EncodeByteArray(byteArray() As Byte)
Dim ModVal As Integer
Dim i As Long
Dim ByteLen As Long
Dim NewProgress As Integer
ModVal = 5000
'use larger ModVal value to speedup when processing large amount of data
ByteLen = UBound(byteArray)
For i = 0 To ByteLen
    byteArray(i) = EncodeByte(byteArray(i))
    If i Mod ModVal = 0 Then
        DoEvents
        If AbortUltraRun = True Then Exit For
        '------------------------------------------------------
        'remove the following 5 lines if no progressbar is used
        NewProgress = i / ByteLen * PROGRESS_ENCHUFF + PROGRESS_CALCCRC + PROGRESS_CALCFREQ + PROGRESS_ENCRYPT
        If (NewProgress <> CurrProgresValue) Then
                CurrProgresValue = NewProgress
                Call UpdateStatus(CurrProgresValue)
            End If
        '------------------------------------------------------
        End If
Next i
End Sub
 
Public Sub DecodeByteArray(byteArray() As Byte)
Dim ModVal As Integer
Dim i As Long
Dim ByteLen As Long
Dim NewProgress As Integer
ModVal = 5000
'use larger ModVal value to speedup when processing large amount of data
ByteLen = UBound(byteArray)
For i = 0 To ByteLen
    byteArray(i) = DecodeByte(byteArray(i))
    If i Mod ModVal = 0 Then
        DoEvents
        If AbortUltraRun = True Then Exit For
        '------------------------------------------------------
        'remove the following 5 lines if no progressbar is used
        NewProgress = i / ByteLen * PROGRESS_DECRYPT
        If (NewProgress <> CurrProgresValue) Then
            CurrProgresValue = NewProgress
            Call UpdateStatus(CurrProgresValue)
            End If
        '------------------------------------------------------
        End If
Next i
End Sub
 
Private Function FnULTRA(FB As Byte) As Byte
Dim TS As Integer
Dim OUT1 As Byte
Dim OUT2 As Integer
Dim OUT3 As Integer
P1 = (P1 + 1) Mod PR1
S1 = (S1 + K1(P1) + FB) Mod PR1
TS = K1(P1)
K1(P1) = K1(S1)
K1(S1) = TS
OUT1 = K1((K1(P1) + K1(S1)) Mod PR1) Mod 256
P2 = (P2 + 1) Mod PR2
S2 = (S2 + K2(P2) + OUT1) Mod PR2
TS = K2(P2)
K2(P2) = K2(S2)
K2(S2) = TS
OUT2 = K2((K2(P2) + K2(S2)) Mod PR2) Mod 256
P3 = (P3 + 1) Mod PR3
S3 = (S3 + K3(P3) + OUT2) Mod PR3
TS = K3(P3)
K3(P3) = K3(S3)
K3(S3) = TS
OUT3 = K3((K3(P3) + K3(S3)) Mod PR3) Mod 256
FnULTRA = (OUT1 + OUT2 + OUT3) Mod 256
End Function
 
' ------------------------------------------------------------
'                  File encryption functions
' ------------------------------------------------------------
 
Private Function EncodeFile(ByVal SourceFile As String, ByVal TargetFile As String, ByVal Key As String, ByVal PCC As String) As String
Dim FileO       As Integer
Dim k           As Integer
Dim VersionBuffer() As Byte
Dim DummyBuffer() As Byte
Dim FileBuffer() As Byte
Dim OutBuffer() As Byte
Dim i As Long
Dim DummyString As String
Dim checkByte1 As Byte
Dim checkByte2 As Byte
Dim Extension  As String
Dim ModVal As Integer
Dim NewProgress As Integer
Dim ByteLen As Long
Dim tmpFile As String
On Error GoTo errHandler
ModVal = 5000
'use larger ModVal value to speedup when processing large amount of data
AbortUltraRun = False
'open file and read bytes into buffer array
FileO = FreeFile
Screen.MousePointer = 11
Open SourceFile For Binary As #FileO
    ReDim FileBuffer(0 To LOF(FileO) - 1)
    Get #FileO, , FileBuffer()
Close #FileO
Screen.MousePointer = 0
'start progress
CurrProgresValue = 0
'compress file
Call HuffEncodeByte(FileBuffer, UBound(FileBuffer) + 1)
If AbortUltraRun = True Then GoTo skip
'set version buffer
VersionBuffer = StrConv(FILE_VERSION, vbFromUnicode)
'set dummy
DummyString = RandomDummy
checkByte1 = Asc(Mid(DummyString, Len(DummyString) - 1, 1))
checkByte2 = Asc(Mid(DummyString, Len(DummyString), 1))
Extension = GetFileExt(SourceFile)
DummyString = DummyString + Extension + Chr(0)
Call SetKey(Key, PCC)
'encypt dummy+ext
DummyBuffer() = StrConv(DummyString, vbFromUnicode)
For i = 0 To UBound(DummyBuffer)
    DummyBuffer(i) = EncodeByte(DummyBuffer(i))
Next
'encrypt file
ByteLen = UBound(FileBuffer)
For i = 0 To ByteLen
    FileBuffer(i) = EncodeByte(FileBuffer(i))
    If i Mod ModVal = 0 Then
        DoEvents
        If AbortUltraRun = True Then Exit For
        '------------------------------------------------------
        'remove the following 5 lines if no progressbar is used
        NewProgress = i / ByteLen * PROGRESS_ENCHUFF + PROGRESS_CALCCRC + PROGRESS_CALCFREQ + PROGRESS_ENCRYPT
        If (NewProgress <> CurrProgresValue) Then '***
            CurrProgresValue = NewProgress '***
            Call UpdateStatus(CurrProgresValue) '***
            End If
        '------------------------------------------------------
        End If
Next
If AbortUltraRun = True Then GoTo skip
'encrypt sheckbytes
checkByte1 = EncodeByte(checkByte1)
checkByte2 = EncodeByte(checkByte2)
'save file
EncodeFile = CutFileExt(TargetFile) & ".ucc"
If FileExist(EncodeFile) Then Kill EncodeFile
Screen.MousePointer = 11
Open EncodeFile For Binary As #FileO
    Put #FileO, , VersionBuffer()
    Put #FileO, , DummyBuffer()
    Put #FileO, , FileBuffer()
    Put #FileO, , checkByte1
    Put #FileO, , checkByte2
Close #FileO
Screen.MousePointer = 0
Call UpdateStatus(0)
If SourceFile = TargetFile Then
    'Kill SourceFile
    If FileExist(SourceFile) Then Kill SourceFile
    End If
skip:
If AbortUltraRun = True Then
    UltraReturnValue = 11 'encode aborted
    EncodeFile = SourceFile
    End If
Call UpdateStatus(0)
Screen.MousePointer = 0
Exit Function
errHandler:
Close #FileO
UltraReturnValue = 12 ' encode file error
FileErrDescription = Err.Description
EncodeFile = SourceFile
Screen.MousePointer = 0
Call UpdateStatus(0)
End Function
 
Private Function DecodeFile(ByVal SourceFile As String, ByVal TargetFile As String, ByVal Key As String, ByVal PCC As String) As String
Dim i As Long
Dim DataStart As Long
Dim DummySize As Integer
Dim DummyStart As Integer
Dim Umax As Long
Dim FileBuffer() As Byte
Dim RndByte As Byte
Dim ExtByte As Byte
Dim ExtCount As Integer
Dim checkByte1 As Byte
Dim checkByte2 As Byte
Dim checkbyteA As Byte
Dim checkbyteB As Byte
Dim tmpASC As Integer
Dim SizeDummy As Byte
Dim FileO As Integer
Dim offSet As Integer
Dim TargetExt As String
Dim ModVal As Integer
Dim NewProgress As Integer
Dim ByteLen As Long
Dim tmpFile As String
On Error GoTo errHandler
ModVal = 5000
'increase ModVal value to speedup when processing large amount of data
AbortUltraRun = False
FileO = FreeFile
Screen.MousePointer = 11
Open SourceFile For Binary As #FileO
    'check if there is data
    ReDim FileBuffer(0 To LOF(FileO) - 1)
    Get #FileO, , FileBuffer()
Close #FileO
Screen.MousePointer = 0
Call SetKey(Key, PCC)
DummyStart = Len(FILE_VERSION)
'decrypt dummy bytes
DummySize = DecodeByte(FileBuffer(DummyStart))
If (DummySize + DummyStart) > UBound(FileBuffer) Then GoTo errHandlerCrypto
'decrypt dummy's
For i = 2 To DummySize
    RndByte = DecodeByte(FileBuffer(DummyStart + i - 1))
    'get checkbytes
    If i = DummySize - 1 Then checkByte1 = RndByte
    If i = DummySize Then checkByte2 = RndByte
Next
offSet = Len(FILE_VERSION) + DummySize
'decrypt ext
TargetExt = ""
Do
    ExtByte = DecodeByte(FileBuffer(offSet + ExtCount))
    If ExtByte <> 0 Then TargetExt = TargetExt & Chr(ExtByte)
    ExtCount = ExtCount + 1
Loop Until ExtByte = 0
If TargetExt <> "" Then TargetExt = "." & TargetExt
offSet = DummyStart + DummySize + ExtCount
CurrProgresValue = 0
ByteLen = UBound(FileBuffer) - offSet - 2
For i = 0 To ByteLen
    FileBuffer(i) = DecodeByte(FileBuffer(i + offSet))
    If i Mod ModVal = 0 Then
        DoEvents
        If AbortUltraRun = True Then Exit For
        '------------------------------------------------------
        'remove the following 5 lines if no progressbar is used
        NewProgress = i / ByteLen * PROGRESS_DECRYPT
        If (NewProgress <> CurrProgresValue) Then
            CurrProgresValue = NewProgress
            Call UpdateStatus(CurrProgresValue)
            End If
        '------------------------------------------------------
        End If
Next
If AbortUltraRun = True Then GoTo skip
checkbyteA = FileBuffer(UBound(FileBuffer) - 1)
checkbyteB = FileBuffer(UBound(FileBuffer))
checkbyteA = DecodeByte(checkbyteA)
checkbyteB = DecodeByte(checkbyteB)
If checkByte1 <> checkbyteA Or checkByte2 <> checkbyteB Then
    GoTo errHandlerCrypto
    End If
ReDim Preserve FileBuffer(UBound(FileBuffer) - offSet - 2)
'decompress file
Call HuffDecodeByte(FileBuffer, UBound(FileBuffer) + 1)
If AbortUltraRun = True Then GoTo skip
If UltraReturnValue <> 0 Then GoTo skip
'save file
DecodeFile = CutFileExt(TargetFile) & TargetExt
If FileExist(DecodeFile) Then Kill DecodeFile
'save the file
FileO = FreeFile
Screen.MousePointer = 11
Open DecodeFile For Binary As #FileO
    Put #FileO, , FileBuffer()
Close #FileO
Screen.MousePointer = 0
If SourceFile = TargetFile Then
    'overwrit source
    If FileExist(SourceFile) Then Kill SourceFile
    End If
skip:
'decode ok
Call UpdateStatus(0)
If AbortUltraRun = True Then
    UltraReturnValue = 21 'decode aborted
    DecodeFile = SourceFile
    End If
Screen.MousePointer = 0
Exit Function
errHandler:
Call UpdateStatus(0)
UltraReturnValue = 22 ' decode file error
FileErrDescription = Err.Description
Screen.MousePointer = 0
Exit Function
errHandlerCrypto:
Call UpdateStatus(0)
UltraReturnValue = 23 ' decode crypto error
Screen.MousePointer = 0
End Function
 
Public Function CheckUltraFile(ByVal Source As String) As Integer
' 0 = not encrypted
' 1 = ultra
' 2 = unknown version
Dim VersionBuffer() As Byte
Dim strVersion As String
Dim FileO As Integer
On Error Resume Next
'read crypto info from file
FileO = FreeFile
Open Source For Binary As #FileO
ReDim VersionBuffer(0 To Len(FILE_VERSION) - 1)
Get #FileO, , VersionBuffer()
Close #FileO
'get crypto info
strVersion = StrConv(VersionBuffer(), vbUnicode)
If strVersion = FILE_VERSION Then
        'known crypto version
        CheckUltraFile = 1
        Else
        If UCase(Right(Source, 4)) = ".UCC" Then
            CheckUltraFile = 2 'Unknown version
            Else
            CheckUltraFile = 0 'Unprotected"
            End If
        End If
End Function
 
' ------------------------------------------------------------
'                  Text encryption functions
' ------------------------------------------------------------
 
Public Function EncodeString(TextIn As String, KeyString As String, PCMstring As String) As String
Dim TextArray() As Byte
Dim DummyString As String
Dim checkByte1 As Byte
Dim checkByte2 As Byte
Dim i As Integer
Screen.MousePointer = 11
AbortUltraRun = False
EncodeString = TextIn
EncodeString = HuffEncodeString(EncodeString)
'create dummy header
DummyString = RandomDummy
checkByte1 = Asc(Mid(DummyString, Len(DummyString) - 1, 1))
checkByte2 = Asc(Mid(DummyString, Len(DummyString), 1))
'add dummy and check bytes
EncodeString = DummyString & EncodeString & Chr(checkByte1) & Chr(checkByte2)
'encode array
Call SetKey(KeyString, PCMstring)
TextArray() = StrConv(EncodeString, vbFromUnicode)
Call EncodeByteArray(TextArray)
EncodeString = StrConv(TextArray(), vbUnicode)
'conter to radix64
EncodeString = EncodeStr64(EncodeString, TEXT_MAXPERLINE)
'add header and trail
EncodeString = TEXT_BEGIN & vbCrLf & TEXT_VERSION & vbCrLf & EncodeString & vbCrLf & TEXT_END
Screen.MousePointer = 0
Call UpdateStatus(0)
End Function
 
Public Function DecodeString(TextIn As String, KeyString As String, PCMstring As String) As String
Dim TextArray() As Byte
Dim HL As Integer
Dim TL As Integer
Dim DummyString As String
Dim SizeDummy As Integer
Dim checkByte1 As Byte
Dim checkByte2 As Byte
CurrProgresValue = 0
Screen.MousePointer = 11
AbortUltraRun = False
'strip trail and header
HL = Len(TEXT_BEGIN & vbCrLf & TEXT_VERSION & vbCrLf)
TL = Len(vbCrLf & TEXT_END)
DecodeString = Mid(TextIn, HL + 1, Len(TextIn) - HL - TL)
'decode radix64
DecodeString = DecodeStr64(DecodeString)
'decode array
Call SetKey(KeyString, PCMstring)
TextArray() = StrConv(DecodeString, vbFromUnicode)
Call DecodeByteArray(TextArray)
DecodeString = StrConv(TextArray(), vbUnicode)
Screen.MousePointer = 0
'check checkbytes
SizeDummy = Asc(Left(DecodeString, 1))
If SizeDummy > Len(DecodeString) - 2 Then GoTo errDecode
DummyString = Left(DecodeString, SizeDummy)
checkByte1 = Asc(Mid(DummyString, Len(DummyString) - 1, 1))
checkByte2 = Asc(Mid(DummyString, Len(DummyString), 1))
'check decryption
If Asc(Mid(DecodeString, Len(DecodeString) - 1, 1)) = checkByte1 And _
 Asc(Mid(DecodeString, Len(DecodeString), 1)) = checkByte2 Then
    DecodeString = Mid(DecodeString, SizeDummy + 1, (Len(DecodeString) - 2) - SizeDummy)
    DecodeString = HuffDecodeString(DecodeString)
    Else
    GoTo errDecode
    End If
Call UpdateStatus(0)
Screen.MousePointer = 0
Exit Function
errDecode:
DecodeString = ""
UltraReturnValue = 33
Call UpdateStatus(0)
Screen.MousePointer = 0
End Function
 
Public Function CheckUltraText(ByVal TextIn As String) As Integer
' 0 = not encrypted
' 1 = ultra 1.0.3
' 2 = unknown version
' 3 = incomplete crypto header
Dim HL As Integer
Dim TL As Integer
Dim VL As Integer
TextIn = TrimText(TextIn)
'trim text and cut crlf's
HL = Len(TEXT_BEGIN & vbCrLf)
VL = Len(TEXT_VERSION & vbCrLf)
TL = Len(vbCrLf & TEXT_END)
If Left(TextIn, HL) = TEXT_BEGIN & vbCrLf And Right(TextIn, TL) <> vbCrLf & TEXT_END Then CheckUltraText = 3: Exit Function
If Left(TextIn, HL) <> TEXT_BEGIN & vbCrLf And Right(TextIn, TL) = vbCrLf & TEXT_END Then CheckUltraText = 3: Exit Function
If Len(TextIn) < HL + TL + VL + 1 Then Exit Function
If Left(TextIn, HL) <> TEXT_BEGIN & vbCrLf Then Exit Function
If Right(TextIn, TL) <> vbCrLf & TEXT_END Then Exit Function
If Mid(TextIn, HL + 1, VL) <> TEXT_VERSION & vbCrLf Then CheckUltraText = 2: Exit Function
CheckUltraText = 1
End Function
 
' ------------------------------------------------------------
'                     Random Dummy generating
' ------------------------------------------------------------
 
Private Function RandomDummy() As String
'setup dummy string, between 16 and 255 bytes, first byte contains dummylenght
Dim rndKey As String
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim q As Byte
Dim SizeDummy As Integer
RandomDummy = ""
Randomize
SizeDummy = Int(224 * Rnd) + 32
If Len(SeedString) > 0 Then
    For k = 1 To Len(SeedString)
        SizeDummy = SizeDummy Xor Asc(Mid(SeedString, k, 1))
    Next
    End If
Do While SizeDummy > 255
    SizeDummy = SizeDummy - 224
Loop
If SizeDummy < 32 Then SizeDummy = SizeDummy + 224
For k = 1 To SizeDummy - 1
    RandomDummy = RandomDummy & Chr(Int((256 * Rnd)))
Next
j = 1
For k = 1 To 16
    rndKey = ""
    For i = 1 To 16
        q = Int((256 * Rnd))
        If Len(SeedString) > 0 Then q = q Xor Asc(Mid(SeedString, j, 1))
        j = j + 1: If j > Len(SeedString) Then j = 1
        rndKey = rndKey & Chr(q)
    Next i
    Call SetKey(rndKey, "")
    For i = 1 To Len(RandomDummy)
        q = Asc(Mid(RandomDummy, i, 1))
        If k Mod 3 = 0 Then
            q = DecodeByte(q)
            Else
            q = EncodeByte(q)
            End If
        Mid(RandomDummy, i, 1) = Chr(q)
    Next i
Next k
RandomDummy = Chr(SizeDummy) & RandomDummy
End Function
 
Public Sub RandomFeed(ByVal X As Single, ByVal Y As Single)
'this sub enables the user to feed random data to seedstring
Static XP As Single
Static YP As Single
If X = XP And Y = YP Then Exit Sub
XP = X: YP = Y
SeedString = SeedString & Chr((X Xor Y) And 255)
If Len(SeedString) > 251 Then SeedString = Mid(SeedString, 2)
End Sub
 
' ------------------------------------------------------------
'                   Compression functions
' ------------------------------------------------------------
 
Private Function HuffDecodeString(Text As String) As String
Dim byteArray() As Byte
byteArray() = StrConv(Text, vbFromUnicode)
Call HuffDecodeByte(byteArray, Len(Text))
HuffDecodeString = StrConv(byteArray(), vbUnicode)
End Function
 
Private Function HuffEncodeString(Text As String) As String
Dim byteArray() As Byte
byteArray() = StrConv(Text, vbFromUnicode)
Call HuffEncodeByte(byteArray, Len(Text))
HuffEncodeString = StrConv(byteArray(), vbUnicode)
End Function
 
Private Sub HuffEncodeByte(byteArray() As Byte, ByteLen As Long)
Dim i As Long, j As Long, Char As Byte, BitPos As Byte, lNode1 As Long
Dim lNode2 As Long, lNodes As Long, lLength As Long, Count As Integer
Dim lWeight1 As Long, lWeight2 As Long, Result() As Byte, ByteValue As Byte
Dim ResultLen As Long, bytes As byteArray, NodesCount As Integer, NewProgress As Integer
Dim BitValue(0 To 7) As Byte, CharCount(0 To 255) As Long
Dim Nodes(0 To 511) As HUFFMANTREE, CharValue(0 To 255) As byteArray
'set identification
If (ByteLen = 0) Then
    ReDim Preserve byteArray(0 To ByteLen + 3)
    If (ByteLen > 0) Then Call CopyMem(byteArray(4), byteArray(0), ByteLen)
    byteArray(0) = 72
    byteArray(1) = 69
    byteArray(2) = 48
    byteArray(3) = 13
    Exit Sub
End If
ReDim Result(0 To 522)
Result(0) = 72
Result(1) = 69
Result(2) = 51
Result(3) = 13
ResultLen = 4
'get frequency off all bytes
For i = 0 To (ByteLen - 1)
    CharCount(byteArray(i)) = CharCount(byteArray(i)) + 1
    If (i Mod 1000 = 0) Then
        DoEvents
        If AbortUltraRun = True Then Exit Sub
        '------------------------------------------------------
        'remove the following 5 lines if no progressbar is used
        NewProgress = i / ByteLen * PROGRESS_CALCFREQ
        If (NewProgress <> CurrProgresValue) Then
            CurrProgresValue = NewProgress
            Call UpdateStatus(CurrProgresValue)
        End If
        '------------------------------------------------------
    End If
Next
'put freq in nodes
For i = 0 To 255
    If (CharCount(i) > 0) Then
        With Nodes(NodesCount)
            .Weight = CharCount(i)
            .Value = i
            .LeftNode = -1
            .RightNode = -1
            .ParentNode = -1
        End With
        NodesCount = NodesCount + 1
    End If
Next
 
For lNodes = NodesCount To 2 Step -1
    lNode1 = -1: lNode2 = -1
    For i = 0 To (NodesCount - 1)
        If (Nodes(i).ParentNode = -1) Then
            If (lNode1 = -1) Then
                lWeight1 = Nodes(i).Weight
                lNode1 = i
            ElseIf (lNode2 = -1) Then
                lWeight2 = Nodes(i).Weight
                lNode2 = i
            ElseIf (Nodes(i).Weight < lWeight1) Then
                If (Nodes(i).Weight < lWeight2) Then
                    If (lWeight1 < lWeight2) Then
                        lWeight2 = Nodes(i).Weight
                        lNode2 = i
                    Else
                        lWeight1 = Nodes(i).Weight
                        lNode1 = i
                    End If
                Else
                    lWeight1 = Nodes(i).Weight
                    lNode1 = i
                End If
            ElseIf (Nodes(i).Weight < lWeight2) Then
                lWeight2 = Nodes(i).Weight
                lNode2 = i
            End If
        End If
    Next
    
    With Nodes(NodesCount)
        .Weight = lWeight1 + lWeight2
        .LeftNode = lNode1
        .RightNode = lNode2
        .ParentNode = -1
        .Value = -1
    End With
    
    Nodes(lNode1).ParentNode = NodesCount
    Nodes(lNode2).ParentNode = NodesCount
    NodesCount = NodesCount + 1
Next
ReDim bytes.Data(0 To 255)
Call CreateBitSequences(Nodes(), NodesCount - 1, bytes, CharValue)
For i = 0 To 255
    If (CharCount(i) > 0) Then lLength = lLength + CharValue(i).Count * CharCount(i)
Next
lLength = IIf(lLength Mod 8 = 0, lLength \ 8, lLength \ 8 + 1)
If ((lLength = 0) Or (lLength > ByteLen)) Then
    ReDim Preserve byteArray(0 To ByteLen + 3)
    Call CopyMem(byteArray(4), byteArray(0), ByteLen)
    byteArray(0) = 72
    byteArray(1) = 69
    byteArray(2) = 48
    byteArray(3) = 13
    Exit Sub
End If
'calculate CRC
Char = 0
For i = 0 To (ByteLen - 1)
    Char = Char Xor byteArray(i)
    If (i Mod 10000 = 0) Then
        DoEvents
        If AbortUltraRun = True Then Exit Sub
        '------------------------------------------------------
        'remove the following 5 lines if no progressbar is used
        NewProgress = i / ByteLen * PROGRESS_CALCCRC + PROGRESS_CALCFREQ
        If (NewProgress <> CurrProgresValue) Then
            CurrProgresValue = NewProgress
            Call UpdateStatus(CurrProgresValue)
        End If
        '------------------------------------------------------
    End If
Next
Result(ResultLen) = Char
ResultLen = ResultLen + 1
Call CopyMem(Result(ResultLen), ByteLen, 4)
ResultLen = ResultLen + 4
BitValue(0) = 2 ^ 0
BitValue(1) = 2 ^ 1
BitValue(2) = 2 ^ 2
BitValue(3) = 2 ^ 3
BitValue(4) = 2 ^ 4
BitValue(5) = 2 ^ 5
BitValue(6) = 2 ^ 6
BitValue(7) = 2 ^ 7
Count = 0
For i = 0 To 255
    If (CharValue(i).Count > 0) Then Count = Count + 1
Next
Call CopyMem(Result(ResultLen), Count, 2)
ResultLen = ResultLen + 2
Count = 0
For i = 0 To 255
    If (CharValue(i).Count > 0) Then
        Result(ResultLen) = i
        ResultLen = ResultLen + 1
        Result(ResultLen) = CharValue(i).Count
        ResultLen = ResultLen + 1
        Count = Count + 16 + CharValue(i).Count
    End If
Next
ReDim Preserve Result(0 To ResultLen + Count \ 8)
BitPos = 0
ByteValue = 0
For i = 0 To 255
    With CharValue(i)
        If (.Count > 0) Then
            For j = 0 To (.Count - 1)
                If (.Data(j)) Then ByteValue = ByteValue + BitValue(BitPos)
                BitPos = BitPos + 1
                If (BitPos = 8) Then
                    Result(ResultLen) = ByteValue
                    ResultLen = ResultLen + 1
                    ByteValue = 0
                    BitPos = 0
                End If
            Next
        End If
    End With
Next
If (BitPos > 0) Then
    Result(ResultLen) = ByteValue
    ResultLen = ResultLen + 1
End If
ReDim Preserve Result(0 To ResultLen - 1 + lLength)
Char = 0
BitPos = 0
For i = 0 To (ByteLen - 1)
    With CharValue(byteArray(i))
        For j = 0 To (.Count - 1)
            If (.Data(j) = 1) Then Char = Char + BitValue(BitPos)
            BitPos = BitPos + 1
            If (BitPos = 8) Then
                Result(ResultLen) = Char
                ResultLen = ResultLen + 1
                BitPos = 0
                Char = 0
            End If
        Next
    End With
    If (i Mod 10000 = 0) Then
        DoEvents
        '------------------------------------------------------
        'remove the following 5 lines if no progressbar is used
        If AbortUltraRun = True Then Exit Sub
        NewProgress = i / ByteLen * PROGRESS_ENCHUFF + PROGRESS_CALCCRC + PROGRESS_CALCFREQ
        If (NewProgress <> CurrProgresValue) Then
            CurrProgresValue = NewProgress
            Call UpdateStatus(CurrProgresValue)
        End If
        '------------------------------------------------------
    End If
Next
If (BitPos > 0) Then
    Result(ResultLen) = Char
    ResultLen = ResultLen + 1
End If
ReDim byteArray(0 To ResultLen - 1)
Call CopyMem(byteArray(0), Result(0), ResultLen)
End Sub
 
Private Sub HuffDecodeByte(byteArray() As Byte, ByteLen As Long)
Dim i As Long, j As Long, pos As Long, Char As Byte, CurrPos As Long
Dim Count As Integer, CheckSum As Byte, Result() As Byte, BitPos As Integer
Dim NodeIndex As Long, ByteValue As Byte, ResultLen As Long, NodesCount As Long
Dim lResultLen As Long, NewProgress As Integer, BitValue(0 To 7) As Byte
Dim Nodes(0 To 511) As HUFFMANTREE, CharValue(0 To 255) As byteArray
If (byteArray(0) <> 72) Or (byteArray(1) <> 69) Or (byteArray(3) <> 13) Then
ElseIf (byteArray(2) = 48) Then
    Call CopyMem(byteArray(0), byteArray(4), ByteLen - 4)
    ReDim Preserve byteArray(0 To ByteLen - 5)
    Exit Sub
ElseIf (byteArray(2) <> 51) Then
    Err.Raise vbObjectError, "HuffmanDecode()", "The data either was not compressed with HE3 or is corrupt (identification string not found)"
    Exit Sub
End If
CurrPos = 5
CheckSum = byteArray(CurrPos - 1)
CurrPos = CurrPos + 1
Call CopyMem(ResultLen, byteArray(CurrPos - 1), 4)
CurrPos = CurrPos + 4
lResultLen = ResultLen
If (ResultLen = 0) Then Exit Sub
ReDim Result(0 To ResultLen - 1)
Call CopyMem(Count, byteArray(CurrPos - 1), 2)
CurrPos = CurrPos + 2
For i = 1 To Count
    With CharValue(byteArray(CurrPos - 1))
        CurrPos = CurrPos + 1
        .Count = byteArray(CurrPos - 1)
        CurrPos = CurrPos + 1
        ReDim .Data(0 To .Count - 1)
    End With
Next
BitValue(0) = 2 ^ 0
BitValue(1) = 2 ^ 1
BitValue(2) = 2 ^ 2
BitValue(3) = 2 ^ 3
BitValue(4) = 2 ^ 4
BitValue(5) = 2 ^ 5
BitValue(6) = 2 ^ 6
BitValue(7) = 2 ^ 7
ByteValue = byteArray(CurrPos - 1)
CurrPos = CurrPos + 1
BitPos = 0
For i = 0 To 255
    With CharValue(i)
        If (.Count > 0) Then
            For j = 0 To (.Count - 1)
                If (ByteValue And BitValue(BitPos)) Then .Data(j) = 1
                BitPos = BitPos + 1
                If (BitPos = 8) Then
                    ByteValue = byteArray(CurrPos - 1)
                    CurrPos = CurrPos + 1
                    BitPos = 0
                End If
            Next
        End If
    End With
Next
If (BitPos = 0) Then CurrPos = CurrPos - 1
NodesCount = 1
Nodes(0).LeftNode = -1
Nodes(0).RightNode = -1
Nodes(0).ParentNode = -1
Nodes(0).Value = -1
For i = 0 To 255
    Call CreateTree(Nodes(), NodesCount, i, CharValue(i))
Next
ResultLen = 0
    For CurrPos = CurrPos To ByteLen
        ByteValue = byteArray(CurrPos - 1)
        For BitPos = 0 To 7
            If (ByteValue And BitValue(BitPos)) Then NodeIndex = Nodes(NodeIndex).RightNode Else NodeIndex = Nodes(NodeIndex).LeftNode
            If (Nodes(NodeIndex).Value > -1) Then
                Result(ResultLen) = Nodes(NodeIndex).Value
                ResultLen = ResultLen + 1
                If (ResultLen = lResultLen) Then GoTo DecodeFinished
                NodeIndex = 0
            End If
        Next
        If (CurrPos Mod 10000 = 0) Then
            DoEvents
            If AbortUltraRun = True Then Exit Sub
            '------------------------------------------------------
            'remove the following 5 lines if no progressbar is used
            NewProgress = CurrPos / ByteLen * PROGRESS_DECRYPT + PROGRESS_DECHUFF
            If (NewProgress <> CurrProgresValue) Then
                CurrProgresValue = NewProgress
                Call UpdateStatus(CurrProgresValue)
            End If
            '------------------------------------------------------
        End If
    Next
DecodeFinished:
    'check CRC
    Char = 0
    For i = 0 To (ResultLen - 1)
        Char = Char Xor Result(i)
        If (i Mod 10000 = 0) Then
            DoEvents
            If AbortUltraRun = True Then Exit Sub
            '------------------------------------------------------
            'remove the following 5 lines if no progressbar is used
            NewProgress = i / ResultLen * PROGRESS_DECRYPT + PROGRESS_CHECKCRC + PROGRESS_DECHUFF
            If (NewProgress <> CurrProgresValue) Then
                CurrProgresValue = NewProgress
                Call UpdateStatus(CurrProgresValue)
            End If
            '------------------------------------------------------
        End If
    Next
    If (Char <> CheckSum) Then UltraReturnValue = 5
    ReDim byteArray(0 To ResultLen - 1)
    Call CopyMem(byteArray(0), Result(0), ResultLen)
End Sub
 
Private Sub CreateBitSequences(Nodes() As HUFFMANTREE, ByVal NodeIndex As Integer, bytes As byteArray, CharValue() As byteArray)
    Dim NewBytes As byteArray
    If (Nodes(NodeIndex).Value > -1) Then
        CharValue(Nodes(NodeIndex).Value) = bytes
        Exit Sub
    End If
    If (Nodes(NodeIndex).LeftNode > -1) Then
        NewBytes = bytes
        NewBytes.Data(NewBytes.Count) = 0
        NewBytes.Count = NewBytes.Count + 1
        Call CreateBitSequences(Nodes(), Nodes(NodeIndex).LeftNode, NewBytes, CharValue)
    End If
    If (Nodes(NodeIndex).RightNode > -1) Then
        NewBytes = bytes
        NewBytes.Data(NewBytes.Count) = 1
        NewBytes.Count = NewBytes.Count + 1
        Call CreateBitSequences(Nodes(), Nodes(NodeIndex).RightNode, NewBytes, CharValue)
    End If
End Sub
 
Private Sub CreateTree(Nodes() As HUFFMANTREE, NodesCount As Long, Char As Long, bytes As byteArray)
Dim a As Integer
Dim NodeIndex As Long
NodeIndex = 0
For a = 0 To (bytes.Count - 1)
    If (bytes.Data(a) = 0) Then
        If (Nodes(NodeIndex).LeftNode = -1) Then
            Nodes(NodeIndex).LeftNode = NodesCount
            Nodes(NodesCount).ParentNode = NodeIndex
            Nodes(NodesCount).LeftNode = -1
            Nodes(NodesCount).RightNode = -1
            Nodes(NodesCount).Value = -1
            NodesCount = NodesCount + 1
        End If
        NodeIndex = Nodes(NodeIndex).LeftNode
    ElseIf (bytes.Data(a) = 1) Then
        If (Nodes(NodeIndex).RightNode = -1) Then
            Nodes(NodeIndex).RightNode = NodesCount
            Nodes(NodesCount).ParentNode = NodeIndex
            Nodes(NodesCount).LeftNode = -1
            Nodes(NodesCount).RightNode = -1
            Nodes(NodesCount).Value = -1
            NodesCount = NodesCount + 1
        End If
        NodeIndex = Nodes(NodeIndex).RightNode
    Else
        Stop
    End If
Next
Nodes(NodeIndex).Value = Char
End Sub
 
' ------------------------------------------------------------
'                   Base 64 Radix functions
' ------------------------------------------------------------
 
Private Function PadString(strData As String) As String
Dim nLen As Long
Dim sPad As String
Dim nPad As Integer
nLen = Len(strData)
nPad = ((nLen \ 8) + 1) * 8 - nLen
sPad = String(nPad, Chr(nPad))
PadString = strData & sPad
End Function
 
Private Function UnpadString(strData As String) As String
Dim nLen As Long
Dim nPad As Long
nLen = Len(strData)
If nLen = 0 Then Exit Function
nPad = Asc(Right(strData, 1))
If nPad > 8 Then nPad = 0
UnpadString = Left(strData, nLen - nPad)
End Function
 
Private Function EncodeStr64(encString As String, ByVal MaxPerLine As Integer) As String
' Return radix64 of string
Dim abOutput()  As Byte
Dim sLast       As String
Dim b(3)        As Byte
Dim j           As Integer
Dim CharCount   As Integer
Dim iIndex      As Long
Dim Umax        As Long
Dim i As Long, nLen As Long, nQuants As Long
EncodeStr64 = ""
nLen = Len(encString)
nQuants = nLen \ 3
iIndex = 0
If MaxPerLine < 10 Then MaxPerLine = 10
Umax = nQuants + 1
Call MakeEncTab
If (nQuants > 0) Then
    ReDim abOutput(nQuants * 4 - 1)
    For i = 0 To nQuants - 1
        For j = 0 To 2
            b(j) = Asc(Mid(encString, (i * 3) + j + 1, 1))
        Next
        Call EncodeQuantumB(b)
        abOutput(iIndex) = b(0)
        abOutput(iIndex + 1) = b(1)
        abOutput(iIndex + 2) = b(2)
        abOutput(iIndex + 3) = b(3)
        CharCount = CharCount + 4
        ' insert CRLF if max char per line is reached
        If CharCount >= MaxPerLine Then
            ReDim Preserve abOutput(UBound(abOutput) + 2)
            CharCount = 0
            abOutput(iIndex + 4) = 13
            abOutput(iIndex + 5) = 10
            iIndex = iIndex + 6
            Else
            iIndex = iIndex + 4
            End If
    Next
    EncodeStr64 = StrConv(abOutput, vbUnicode)
End If
Select Case nLen Mod 3
Case 0
    sLast = ""
Case 1
    b(0) = Asc(Mid(encString, nLen, 1))
    b(1) = 0
    b(2) = 0
    Call EncodeQuantumB(b)
    sLast = StrConv(b(), vbUnicode)
    sLast = Left(sLast, 2) & "=="
Case 2
    b(0) = Asc(Mid(encString, nLen - 1, 1))
    b(1) = Asc(Mid(encString, nLen, 1))
    b(2) = 0
    Call EncodeQuantumB(b)
    sLast = StrConv(b(), vbUnicode)
    sLast = Left(sLast, 3) & "="
End Select
EncodeStr64 = EncodeStr64 & sLast
End Function
 
Private Function DecodeStr64(decString As String) As String
' Return string of decoded values from radix64
Dim abDecoded() As Byte
Dim d(3)    As Byte
Dim c       As Integer
Dim di      As Integer
Dim i       As Long
Dim nLen    As Long
Dim iIndex  As Long
Dim Umax    As Long
nLen = Len(decString)
If nLen < 4 Then
    Exit Function
End If
ReDim abDecoded(((nLen \ 4) * 3) - 1)
Umax = nLen
iIndex = 0
di = 0
Call MakeDecTab
For i = 1 To Len(decString)
    c = CByte(Asc(Mid(decString, i, 1)))
    c = aDecTab(c)
    If c >= 0 Then
        d(di) = CByte(c)
        di = di + 1
        If di = 4 Then
            abDecoded(iIndex) = SHL2(d(0)) Or (SHR4(d(1)) And &H3)
            iIndex = iIndex + 1
            abDecoded(iIndex) = SHL4(d(1) And &HF) Or (SHR2(d(2)) And &HF)
            iIndex = iIndex + 1
            abDecoded(iIndex) = SHL6(d(2) And &H3) Or d(3)
            iIndex = iIndex + 1
            If d(3) = 64 Then
                iIndex = iIndex - 1
                abDecoded(iIndex) = 0
            End If
            If d(2) = 64 Then
                iIndex = iIndex - 1
                abDecoded(iIndex) = 0
            End If
            di = 0
        End If
    End If
Next i
DecodeStr64 = StrConv(abDecoded(), vbUnicode)
DecodeStr64 = Left(DecodeStr64, iIndex)
End Function
 
Private Sub EncodeQuantumB(b() As Byte)
Dim b0 As Byte, b1 As Byte, b2 As Byte, b3 As Byte
b0 = SHR2(b(0)) And &H3F
b1 = SHL4(b(0) And &H3) Or (SHR4(b(1)) And &HF)
b2 = SHL2(b(1) And &HF) Or (SHR6(b(2)) And &H3)
b3 = b(2) And &H3F
b(0) = aEncTab(b0)
b(1) = aEncTab(b1)
b(2) = aEncTab(b2)
b(3) = aEncTab(b3)
End Sub
 
Private Function MakeDecTab()
Dim t As Integer
Dim c As Integer
For c = 0 To 255
    aDecTab(c) = -1
Next
t = 0
For c = Asc("A") To Asc("Z")
    aDecTab(c) = t
    t = t + 1
Next
For c = Asc("a") To Asc("z")
    aDecTab(c) = t
    t = t + 1
Next
For c = Asc("0") To Asc("9")
    aDecTab(c) = t
    t = t + 1
Next
c = Asc("+")
aDecTab(c) = t
t = t + 1
c = Asc("/")
aDecTab(c) = t
t = t + 1
c = Asc("=")
aDecTab(c) = t
End Function
 
Private Function MakeEncTab()
Dim i As Integer
Dim c As Integer
i = 0
For c = Asc("A") To Asc("Z")
    aEncTab(i) = c
    i = i + 1
Next
For c = Asc("a") To Asc("z")
    aEncTab(i) = c
    i = i + 1
Next
For c = Asc("0") To Asc("9")
    aEncTab(i) = c
    i = i + 1
Next
c = Asc("+")
aEncTab(i) = c
i = i + 1
c = Asc("/")
aEncTab(i) = c
i = i + 1
End Function
 
Private Function SHL2(ByVal bytValue As Byte) As Byte
SHL2 = (bytValue * &H4) And &HFF
End Function
 
Private Function SHL4(ByVal bytValue As Byte) As Byte
SHL4 = (bytValue * &H10) And &HFF
End Function
 
Private Function SHL6(ByVal bytValue As Byte) As Byte
SHL6 = (bytValue * &H40) And &HFF
End Function
 
Private Function SHR2(ByVal bytValue As Byte) As Byte
SHR2 = bytValue \ &H4
End Function
 
Private Function SHR4(ByVal bytValue As Byte) As Byte
SHR4 = bytValue \ &H10
End Function
 
Private Function SHR6(ByVal bytValue As Byte) As Byte
SHR6 = bytValue \ &H40
End Function
 
Private Sub SetReturnString()
'get the ultra error descriptions
Select Case UltraReturnValue
Case 0
    UltraReturnString = ""
Case 1
    UltraReturnString = "Cannot continue without text (Error 1)"
Case 2
    UltraReturnString = "Cannot continue without key (Error 2)"
Case 3
    UltraReturnString = "Key too small/is repeating (Error 3)"
Case 4
    UltraReturnString = "Source file not found (Error 4)"
Case 5
    UltraReturnString = "Compression checksum error (Error 5)"
Case 6
    UltraReturnString = "Cannot process empty file (Error 6)"
Case 10
    UltraReturnString = "Crypto version unknown/contains errors (Error 10)"
Case 11
    UltraReturnString = "Encoding has been aborted by user"
Case 12
    UltraReturnString = "File error: " & FileErrDescription & " (Error 12)"
Case 20
    UltraReturnString = "Crypto file version unknown/contains errors (Error 20)"
Case 21
    UltraReturnString = "Decoding has been aborted by user"
Case 22
    UltraReturnString = "File error: " & FileErrDescription & " (Error 22)"
Case 23
    UltraReturnString = "Failed decoding the file (Error 23)"
Case 30
    UltraReturnString = "Crypto header or footer format incomplete/contains errors (Error 30)"
Case 33
    UltraReturnString = "Failed decoding the text (Error 33)"
End Select
End Sub
 
' ------------------------------------------------------------
'              Miscellanious public functions
' ------------------------------------------------------------
 
Public Function KeyQuality(ByVal aKey As String) As Integer
' returns an integer value (0 to 100) rating the key quality
Dim QC As Integer
Dim LN As Integer
Dim k As Integer
Dim Uc As Boolean
Dim Lc As Boolean
LN = Len(aKey)
QC = LN * 3
If IsValidKey(aKey) = False Then KeyQuality = 0: Exit Function
'check ucases and lcases
For k = 1 To Len(aKey)
    If Asc(Mid(aKey, k, 1)) > 64 And Asc(Mid(aKey, k, 1)) < 91 Then Uc = True
    If Asc(Mid(aKey, k, 1)) > 96 And Asc(Mid(aKey, k, 1)) < 123 Then Lc = True
Next
If Uc = True And Lc = True Then QC = QC * 1.2
'check numbers
For k = 1 To Len(aKey)
    If Asc(Mid(aKey, k, 1)) > 47 And Asc(Mid(aKey, k, 1)) < 58 Then
        If Uc = True Or Lc = True Then QC = QC * 1.4
        Exit For
        End If
Next
'check signs
For k = 1 To Len(aKey)
    If Asc(Mid(aKey, k, 1)) < 48 Or Asc(Mid(aKey, k, 1)) > 122 Or (Asc(Mid(aKey, k, 1)) > 57 And Asc(Mid(aKey, k, 1)) < 65) Then QC = QC * 1.5: Exit For
Next
If QC > 100 Then QC = 100
KeyQuality = Int(QC)
End Function
 
Public Function FileExist(FileName As String) As Boolean
'checks weither a file exists
    On Error GoTo FileDoesNotExist
    Call FileLen(FileName)
    FileExist = True
    Exit Function
FileDoesNotExist:
    FileExist = False
End Function
 
Public Function GetFileExt(strFile As String) As String
'returns extension of filename
Dim k   As Integer
Dim pos As Integer
For k = 1 To Len(strFile)
    If Mid(strFile, k, 1) = "." Then pos = k
Next
If pos = Len(strFile) Then pos = 0
If pos = 0 Then
    GetFileExt = ""
    Else
    GetFileExt = LCase(Mid(strFile, pos + 1))
    End If
End Function
 
Public Function GetFilePath(strFile As String) As String
'returns only the path without filename
Dim k As Integer
Dim pos As Integer
For k = 1 To Len(strFile)
    If Mid(strFile, k, 1) = "\" Then pos = k
Next
If pos < 2 Then
    GetFilePath = ""
    Else
    GetFilePath = Left(strFile, pos)
    End If
End Function
 
Public Function CutFileExt(strFile As String) As String
'returns full path and filename without extension
Dim k As Integer
Dim pos As Integer
For k = 1 To Len(strFile)
    If Mid(strFile, k, 1) = "." Then pos = k
Next
If pos = 0 Then
    CutFileExt = strFile
    Else
    CutFileExt = Left(strFile, pos - 1)
    End If
End Function
 
Public Function CutFilePath(strFile As String) As String
'returns only the filename without full path
Dim k As Integer
Dim pos As Integer
For k = 1 To Len(strFile)
    If Mid(strFile, k, 1) = "\" Then pos = k
Next
If pos = 0 Then
    CutFilePath = strFile
    Else
    CutFilePath = Mid(strFile, pos + 1)
    End If
End Function
 
Public Function IsValidKey(ByVal aKey As String) As Boolean
'check if key is at least 5 char long, and doesn't repeat
Dim tmp As String
Dim Wid As Integer
Dim i As Integer
Dim Repro As Boolean
If Len(aKey) < 5 Then Exit Function
For Wid = 1 To Int(Len(aKey) / 2)
    IsValidKey = False
    For i = Wid + 1 To Len(aKey) Step Wid
        If Mid(aKey, 1, Wid) <> Mid(aKey, i, Wid) Then IsValidKey = True: Exit For
    Next
If IsValidKey = False Then Exit For
Next
End Function
 
Public Function TrimText(ByVal aText As String) As String
'cut off all heading and trailing spaces,tabs,CR's and LF's
Dim tmp As String
BeginCutL:
tmp = Left(aText, 1)
If tmp = Chr(32) Or tmp = Chr(9) Or tmp = Chr(13) Or tmp = Chr(10) Then
    aText = Mid(aText, 2)
    GoTo BeginCutL
    End If
BeginCutR:
tmp = Right(aText, 1)
If tmp = Chr(32) Or tmp = Chr(9) Or tmp = Chr(13) Or tmp = Chr(10) Then
    aText = Left(aText, Len(aText) - 1)
    GoTo BeginCutR
    End If
TrimText = aText
End Function
0
Programming
Эксперт
94731 / 64177 / 26122
Регистрация: 12.04.2006
Сообщений: 116,782
10.02.2013, 23:28
Ответы с готовыми решениями:

Шифровка файлов Java
Добрый день. Задали задание которое просто вынесло мне мозг. Хотя если это всё знать то оно не...

Шифровка exe файлов
как шифруются exe файлы? я знаю там нет шифровки там каждый символ это значение от 0 - 255 надо...

Шифровка файлов в vault
Здравствуйте. Помогите плиз. Проблема такая же как в аналогичных темах. Пользователь открыл письмо...

Шифровка ресурсных файлов
Как зашифровать или спрятать в программу ресурсные файлы(у меня это 69 папок и 552 файла объемом...

7
Alex77755
11.02.2013, 18:11
  #2

Не по теме:

Это насколько суперсекретной должна быть разработка, что бы только на шифровку понадобилось около 2000 строк кода!? Не иначе "Hello World".

1
Эксперт WindowsАвтор FAQ
17601 / 7444 / 884
Регистрация: 25.12.2011
Сообщений: 11,236
Записей в блоге: 16
11.02.2013, 18:46 3
Упаковка деревом Хаффмана + XOR.

Интересно по какому принципу формируется ключ. Функция FnULTRA накручена.
И как соотносится переменная FEEDBACK между EncodeByte и DecodeByte.
0
SoftIce
11.02.2013, 19:17
  #4

Не по теме:

Цитата Сообщение от Alex77755 Посмотреть сообщение
на шифровку понадобилось около 2000 строк кода!? Не иначе "Hello World".
:D
осталось расшифровку написать на 4000 строк :rofl:

1
11 / 2 / 0
Регистрация: 17.10.2012
Сообщений: 80
11.02.2013, 20:53 5
Ну парни, че вы ржете) человек помощи просит))
1
18 / 0 / 0
Регистрация: 02.02.2013
Сообщений: 3
11.02.2013, 21:03  [ТС] 6
кто-нибудь поможет мне или все будут ржать?)) Разработка для Пентагона)))
0
Заблокирован
11.02.2013, 21:39 7
ultradevelop, Да куда мне, вон отцы Alex77755, SoftIce, Dragokas, не могут, только приколы ловят, а если и могут, им лень их пивом надо стимулировать, работу их головного мозга. Я по базам данных специалист, а тут надо головой думать . Математика, а у меня в школе Лидия Васильевна по математике говорила учи, пригодится .
 Комментарий модератора 
Предупреждение за оффтоп.
1
es geht mir gut
11222 / 4699 / 1178
Регистрация: 27.07.2011
Сообщений: 11,426
11.02.2013, 22:11 8
Цитата Сообщение от black_idea Посмотреть сообщение
кто-нибудь поможет мне или все будут ржать?
А проект выложить?
Думаешь охота все эти контролы с нестандартными именами создавать.
1
IT_Exp
Эксперт
87844 / 49110 / 22898
Регистрация: 17.06.2006
Сообщений: 92,604
11.02.2013, 22:11

Заказываю контрольные, курсовые, дипломные и любые другие студенческие работы здесь или здесь.

Шифровка / дешифровка файлов (scrembler)
Здравствуйте есть программа для шифровки и дешифровки файлов , нужно поменять в ней значения key ,...

Шифровка файлов. чем лечить?
Мошенники просят денег как обычно. Пришло письмо якобы от моего переписчика, в нем файл .htp в...

Скрытие папок \ файлов паролем
Только вчера перешел с ХР на семерку. В ХР была программа Lock Folder ХР, которая скрывала файлы и...

Установка exe файлов только с паролем
Всем Привет! Как сделать на win7 под правами админа , чтоб установка любых приложений происходила...


Искать еще темы с ответами

Или воспользуйтесь поиском по форуму:
8
Ответ Создать тему
Опции темы

КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2021, vBulletin Solutions, Inc.