,   CyberForum.ru

Visual Basic


 
 
:  :  - 2,   - 5.00
13144 / 5038 / 1209
: 24.09.2011
: 7,784
06.01.2013, 15:53     Visual Basic 6.0 #21
2 -2
( Visual Basic 6.0)
Visual Basic
1
2
3
4
5
6
7
8
9
Function FileCompare(path1, path2) As Long
    '     
    '    fc.exe.  :
    '0 -  ;
    '1 -  ;
    '2 -   
FileCompare = CreateObject("wscript.shell").Run( _
    "cmd /c fc /b """ & path1 & """ """ & path2 & """", 0, True)
End Function
.
dev.Free
07.01.2013, 10:00     Visual Basic 6.0 #22
.

: Label1, Text1 Command1 .

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
Option Explicit
 
Private Sub Command1_Click()
Label1 = SummaString_Val(Text1)
End Sub
 
'
'Âîçâð*ù*åò ñóììó ïðîïèñüþ â ëþáîé â*ëþòå ñ **èìå*îâ**èåì êîïååê  - Public Function SummaString_Val(Summa As String, Valuta As Integer) As String
'
Public Function SummaString_Val(Summa As String, Optional Valuta As Integer) As String
   Dim T1Str As String
   Dim T2Str As String
   Dim T3Str As String
   Dim T4Str As String
   Dim KStr As String
   Dim Cel As String
   
   Summa = Trim$(Summa) 'Óä*ëèòü ïðîáåëû
   Summa = Replace(Summa, ",", ".", , , vbBinaryCompare) 'Ç*ìå*èòü ç*ïÿòûå ** òî÷êè
   If InStr(1, Summa, ".", vbBinaryCompare) = 0 Then Summa = Summa & ".00" 'Äîïèñ*òü êîïåéêè
   If Mid$(Summa, Len(Summa) - 1, 1) = "." Then Summa = Summa & "0" '
   'Ïðîâåðê* äëè*û ÷èñë*
   If Len(Summa) > 15 Then
      MsgBox "Ñëèøêîì äëè**îå ÷èñëî.", vbInformation, "Ìóëüòèâ*ëþò**ÿ ñóìì* ïðîïèñüþ"
      Exit Function
   End If
   
   If Len(Summa) < 15 Then Summa = String(15 - Len(Summa), "0") & Summa
   
   Select Case Valuta
      '================================ Ðóáëè =================================
      Case Is = 0, 810, 112
      'À**ëèç ïåðâîé òðè*äû
      T1Str = TrStr(Left(Summa, 3), 0)
      If T1Str <> "" Then
         Select Case Right$(Left(Summa, 3), 1)
            Case Is = "0"
               T1Str = T1Str & "ìèëëè*ðäîâ "
            Case Is = "1"
               If Mid$(Left(Summa, 3), 2, 1) = "1" Then
                  T1Str = T1Str & "ìèëëè*ðäîâ "
               Else
                  T1Str = T1Str & "ìèëëè*ðä "
               End If
            Case Is = "2"
               If Mid$(Left(Summa, 3), 2, 1) = "1" Then
                  T1Str = T1Str & "ìèëëè*ðäîâ "
               Else
                  T1Str = T1Str & "ìèëëè*ðä* "
               End If
            Case Is = "3"
               If Mid$(Left(Summa, 3), 2, 1) = "1" Then
                  T1Str = T1Str & "ìèëëè*ðäîâ "
               Else
                  T1Str = T1Str & "ìèëëè*ðä* "
               End If
            Case Is = "4"
               If Mid$(Left(Summa, 3), 2, 1) = "1" Then
                  T1Str = T1Str & "ìèëëè*ðäîâ "
               Else
                  T1Str = T1Str & "ìèëëè*ðä* "
               End If
            Case Else
               T1Str = T1Str & "ìèëëè*ðäîâ "
         End Select
      End If
   
      'À**ëèç âòîðîé òðè*äû
      T2Str = TrStr(Mid$(Summa, 4, 3), 0)
      If T2Str <> "" Then
         Select Case Right$(Mid$(Summa, 4, 3), 1)
            Case Is = "0"
               T2Str = T2Str & "ìèëëèî*îâ "
            Case Is = "1"
               If Mid$(Mid$(Summa, 4, 3), 2, 1) = "1" Then
                  T2Str = T2Str & "ìèëëèî*îâ "
               Else
                  T2Str = T2Str & "ìèëëèî* "
               End If
            Case Is = "2"
               If Mid$(Mid$(Summa, 4, 3), 2, 1) = "1" Then
                  T2Str = T2Str & "ìèëëèî*îâ "
               Else
                  T2Str = T2Str & "ìèëëèî** "
               End If
            Case Is = "3"
               If Mid$(Mid$(Summa, 4, 3), 2, 1) = "1" Then
                  T2Str = T2Str & "ìèëëèî*îâ "
               Else
                  T2Str = T2Str & "ìèëëèî** "
               End If
            Case Is = "4"
               If Mid$(Mid$(Summa, 4, 3), 2, 1) = "1" Then
                  T2Str = T2Str & "ìèëëèî*îâ "
               Else
                  T2Str = T2Str & "ìèëëèî** "
               End If
            Case Else
               T2Str = T2Str & "ìèëëèî*îâ "
         End Select
      End If
      
      'À**ëèç òðåòüåé òðè*äû
      T3Str = TrStr(Mid$(Summa, 7, 3), 1)
      If T3Str <> "" Then
         Select Case Right$(Mid$(Summa, 7, 3), 1)
            Case Is = "0"
               T3Str = T3Str & "òûñÿ÷ "
            Case Is = "1"
               If Mid$(Mid$(Summa, 7, 3), 2, 1) = "1" Then
                  T3Str = T3Str & "òûñÿ÷ "
               Else
                  T3Str = T3Str & "òûñÿ÷* "
               End If
            Case Is = "2"
               If Mid$(Mid$(Summa, 7, 3), 2, 1) = "1" Then
                  T3Str = T3Str & "òûñÿ÷ "
               Else
                  T3Str = T3Str & "òûñÿ÷è "
               End If
            Case Is = "3"
               If Mid$(Mid$(Summa, 7, 3), 2, 1) = "1" Then
                  T3Str = T3Str & "òûñÿ÷ "
               Else
                  T3Str = T3Str & "òûñÿ÷è "
               End If
            Case Is = "4"
               If Mid$(Mid$(Summa, 7, 3), 2, 1) = "1" Then
                  T3Str = T3Str & "òûñÿ÷ "
               Else
                  T3Str = T3Str & "òûñÿ÷è "
               End If
            Case Else
               T3Str = T3Str & "òûñÿ÷ "
         End Select
      End If
      
      'À**ëèç ÷åòâåðòîé òðè*äû
      T4Str = TrStr(Mid$(Summa, 10, 3), 0)
   
      'À**ëèç êîïååê
      KStr = KdStr(Right$(Summa, 2), 1)
   
      If Len(T1Str & T2Str & T3Str & T4Str) = 0 Then
         Cel = "*îëü "
      Else
         Cel = T1Str & T2Str & T3Str & T4Str
      End If
      
      '========= Ïðèïèñ*òü â*ëþòó =========
      'Ðóáëè
      If Val(Mid$(Summa, 11, 1)) <> 1 Then
         Select Case Mid$(Summa, 12, 1)
            Case Is = "0"
               Cel = Cel & "ðóáëåé "
            Case Is = "1"
               Cel = Cel & "ðóáëü "
            Case Is = "2"
               Cel = Cel & "ðóáëÿ "
            Case Is = "3"
               Cel = Cel & "ðóáëÿ "
            Case Is = "4"
               Cel = Cel & "ðóáëÿ "
            Case Else
               Cel = Cel & "ðóáëåé "
         End Select
      End If
      
      Select Case Mid$(Summa, 11, 2)
         Case Is = "10", "11", "12", "13", "14", "15", "16", "17", "18", "19"
            Cel = Cel & "ðóáëåé "
      End Select
      
      'Êîïåéêè
      If Val(Mid$(Summa, 14, 1)) <> 1 Then
         Select Case Right$(Summa, 1)
            Case Is = "0"
               KStr = KStr & "êîïååê"
            Case Is = "1"
               KStr = KStr & "êîïåéê*"
            Case Is = "2"
               KStr = KStr & "êîïåéêè"
            Case Is = "3"
               KStr = KStr & "êîïåéêè"
            Case Is = "4"
               KStr = KStr & "êîïåéêè"
            Case Else
               KStr = KStr & "êîïååê"
         End Select
      End If
      
      Select Case Right$(Summa, 2)
         Case Is = "10", "11", "12", "13", "14", "15", "16", "17", "18", "19"
            KStr = KStr & "êîïååê"
      End Select
         SummaString_Val = Cel & KStr
   '================================ Äîëë*ðû =================================
      Case Is = 840
      'À**ëèç ïåðâîé òðè*äû
      T1Str = TrStr(Left(Summa, 3), 0)
      If T1Str <> "" Then
         Select Case Right$(Left(Summa, 3), 0)
            Case Is = "0"
               T1Str = T1Str & "ìèëëè*ðäîâ "
            Case Is = "1"
               If Mid$(Left(Summa, 3), 2, 1) = "1" Then
                  T1Str = T1Str & "ìèëëè*ðäîâ "
               Else
                  T1Str = T1Str & "ìèëëè*ðä "
               End If
            Case Is = "2"
               If Mid$(Left(Summa, 3), 2, 1) = "1" Then
                  T1Str = T1Str & "ìèëëè*ðäîâ "
               Else
                  T1Str = T1Str & "ìèëëè*ðä* "
               End If
            Case Is = "3"
               If Mid$(Left(Summa, 3), 2, 1) = "1" Then
                  T1Str = T1Str & "ìèëëè*ðäîâ "
               Else
                  T1Str = T1Str & "ìèëëè*ðä* "
               End If
            Case Is = "4"
               If Mid$(Left(Summa, 3), 2, 1) = "1" Then
                  T1Str = T1Str & "ìèëëè*ðäîâ "
               Else
                  T1Str = T1Str & "ìèëëè*ðä* "
               End If
            Case Else
               T1Str = T1Str & "ìèëëè*ðäîâ "
         End Select
      End If
   
      'À**ëèç âòîðîé òðè*äû
      T2Str = TrStr(Mid$(Summa, 4, 3), 0)
      If T2Str <> "" Then
         Select Case Right$(Mid$(Summa, 4, 3), 1)
            Case Is = "0"
               T2Str = T2Str & "ìèëëèî*îâ "
            Case Is = "1"
               If Mid$(Mid$(Summa, 4, 3), 2, 1) = "1" Then
                  T2Str = T2Str & "ìèëëèî*îâ "
               Else
                  T2Str = T2Str & "ìèëëèî* "
               End If
            Case Is = "2"
               If Mid$(Mid$(Summa, 4, 3), 2, 1) = "1" Then
                  T2Str = T2Str & "ìèëëèî*îâ "
               Else
                  T2Str = T2Str & "ìèëëèî** "
               End If
            Case Is = "3"
               If Mid$(Mid$(Summa, 4, 3), 2, 1) = "1" Then
                  T2Str = T2Str & "ìèëëèî*îâ "
               Else
                  T2Str = T2Str & "ìèëëèî** "
               End If
            Case Is = "4"
               If Mid$(Mid$(Summa, 4, 3), 2, 1) = "1" Then
                  T2Str = T2Str & "ìèëëèî*îâ "
               Else
                  T2Str = T2Str & "ìèëëèî** "
               End If
            Case Else
               T2Str = T2Str & "ìèëëèî*îâ "
         End Select
      End If
      
      'À**ëèç òðåòüåé òðè*äû
      T3Str = TrStr(Mid$(Summa, 7, 3), 1)
      If T3Str <> "" Then
         Select Case Right$(Mid$(Summa, 7, 3), 1)
            Case Is = "0"
               T3Str = T3Str & "òûñÿ÷ "
            Case Is = "1"
               If Mid$(Mid$(Summa, 7, 3), 2, 1) = "1" Then
                  T3Str = T3Str & "òûñÿ÷ "
               Else
                  T3Str = T3Str & "òûñÿ÷* "
               End If
            Case Is = "2"
               If Mid$(Mid$(Summa, 7, 3), 2, 1) = "1" Then
                  T3Str = T3Str & "òûñÿ÷ "
               Else
                  T3Str = T3Str & "òûñÿ÷è "
               End If
            Case Is = "3"
               If Mid$(Mid$(Summa, 7, 3), 2, 1) = "1" Then
                  T3Str = T3Str & "òûñÿ÷ "
               Else
                  T3Str = T3Str & "òûñÿ÷è "
               End If
            Case Is = "4"
               If Mid$(Mid$(Summa, 7, 3), 2, 1) = "1" Then
                  T3Str = T3Str & "òûñÿ÷ "
               Else
                  T3Str = T3Str & "òûñÿ÷è "
               End If
            Case Else
               T3Str = T3Str & "òûñÿ÷ "
         End Select
      End If
      
      'À**ëèç ÷åòâåðòîé òðè*äû
      T4Str = TrStr(Mid$(Summa, 10, 3), 0)
   
      'À**ëèç êîïååê
      KStr = KdStr(Right$(Summa, 2), 0)
   
      If Len(T1Str & T2Str & T3Str & T4Str) = 0 Then
         Cel = "*îëü "
      Else
         Cel = T1Str & T2Str & T3Str & T4Str
      End If
      '========= Ïðèïèñ*òü â*ëþòó =========
      'Ðóáëè
      If Val(Mid$(Summa, 11, 1)) <> 1 Then
         Select Case Mid$(Summa, 12, 1)
            Case Is = "0"
               Cel = Cel & "äîëë*ðîâ "
            Case Is = "1"
               Cel = Cel & "äîëë*ð "
            Case Is = "2"
               Cel = Cel & "äîëë*ð* "
            Case Is = "3"
               Cel = Cel & "äîëë*ð* "
            Case Is = "4"
               Cel = Cel & "äîëë*ð* "
            Case Else
               Cel = Cel & "äîëë*ðîâ "
         End Select
      End If
      
      Select Case Mid$(Summa, 11, 2)
         Case Is = "10", "11", "12", "13", "14", "15", "16", "17", "18", "19"
            Cel = Cel & "äîëë*ðîâ "
      End Select
      
      'Êîïåéêè
      If Val(Mid$(Summa, 14, 1)) <> 1 Then
         Select Case Right$(Summa, 1)
            Case Is = "0"
               KStr = KStr & "öå*òîâ"
            Case Is = "1"
               KStr = KStr & "öå*ò"
            Case Is = "2"
               KStr = KStr & "öå*ò*"
            Case Is = "3"
               KStr = KStr & "öå*ò*"
            Case Is = "4"
               KStr = KStr & "öå*ò*"
            Case Else
               KStr = KStr & "öå*òîâ"
         End Select
      End If
      
      Select Case Right$(Summa, 2)
         Case Is = "10", "11", "12", "13", "14", "15", "16", "17", "18", "19"
            KStr = KStr & "öå*òîâ"
      End Select
         SummaString_Val = Cel & KStr
      '================================ Ëåè =================================
      Case Is = 498
      'À**ëèç ïåðâîé òðè*äû
      T1Str = TrStr(Left(Summa, 3), 0)
      If T1Str <> "" Then
         Select Case Right$(Left(Summa, 3), 1)
            Case Is = "0"
               T1Str = T1Str & "ìèëëè*ðäîâ "
            Case Is = "1"
               If Mid$(Left(Summa, 3), 2, 1) = "1" Then
                  T1Str = T1Str & "ìèëëè*ðäîâ "
               Else
                  T1Str = T1Str & "ìèëëè*ðä "
               End If
            Case Is = "2"
               If Mid$(Left(Summa, 3), 2, 1) = "1" Then
                  T1Str = T1Str & "ìèëëè*ðäîâ "
               Else
                  T1Str = T1Str & "ìèëëè*ðä* "
               End If
            Case Is = "3"
               If Mid$(Left(Summa, 3), 2, 1) = "1" Then
                  T1Str = T1Str & "ìèëëè*ðäîâ "
               Else
                  T1Str = T1Str & "ìèëëè*ðä* "
               End If
            Case Is = "4"
               If Mid$(Left(Summa, 3), 2, 1) = "1" Then
                  T1Str = T1Str & "ìèëëè*ðäîâ "
               Else
                  T1Str = T1Str & "ìèëëè*ðä* "
               End If
            Case Else
               T1Str = T1Str & "ìèëëè*ðäîâ "
         End Select
      End If
   
      'À**ëèç âòîðîé òðè*äû
      T2Str = TrStr(Mid$(Summa, 4, 3), 0)
      If T2Str <> "" Then
         Select Case Right$(Mid$(Summa, 4, 3), 1)
            Case Is = "0"
               T2Str = T2Str & "ìèëëèî*îâ "
            Case Is = "1"
               If Mid$(Mid$(Summa, 4, 3), 2, 1) = "1" Then
                  T2Str = T2Str & "ìèëëèî*îâ "
               Else
                  T2Str = T2Str & "ìèëëèî* "
               End If
            Case Is = "2"
               If Mid$(Mid$(Summa, 4, 3), 2, 1) = "1" Then
                  T2Str = T2Str & "ìèëëèî*îâ "
               Else
                  T2Str = T2Str & "ìèëëèî** "
               End If
            Case Is = "3"
               If Mid$(Mid$(Summa, 4, 3), 2, 1) = "1" Then
                  T2Str = T2Str & "ìèëëèî*îâ "
               Else
                  T2Str = T2Str & "ìèëëèî** "
               End If
            Case Is = "4"
               If Mid$(Mid$(Summa, 4, 3), 2, 1) = "1" Then
                  T2Str = T2Str & "ìèëëèî*îâ "
               Else
                  T2Str = T2Str & "ìèëëèî** "
               End If
            Case Else
               T2Str = T2Str & "ìèëëèî*îâ "
         End Select
      End If
      
      'À**ëèç òðåòüåé òðè*äû
      T3Str = TrStr(Mid$(Summa, 7, 3), 1)
      If T3Str <> "" Then
         Select Case Right$(Mid$(Summa, 7, 3), 1)
            Case Is = "0"
               T3Str = T3Str & "òûñÿ÷ "
            Case Is = "1"
               If Mid$(Mid$(Summa, 7, 3), 2, 1) = "1" Then
                  T3Str = T3Str & "òûñÿ÷ "
               Else
                  T3Str = T3Str & "òûñÿ÷* "
               End If
            Case Is = "2"
               If Mid$(Mid$(Summa, 7, 3), 2, 1) = "1" Then
                  T3Str = T3Str & "òûñÿ÷ "
               Else
                  T3Str = T3Str & "òûñÿ÷è "
               End If
            Case Is = "3"
               If Mid$(Mid$(Summa, 7, 3), 2, 1) = "1" Then
                  T3Str = T3Str & "òûñÿ÷ "
               Else
                  T3Str = T3Str & "òûñÿ÷è "
               End If
            Case Is = "4"
               If Mid$(Mid$(Summa, 7, 3), 2, 1) = "1" Then
                  T3Str = T3Str & "òûñÿ÷ "
               Else
                  T3Str = T3Str & "òûñÿ÷è "
               End If
            Case Else
               T3Str = T3Str & "òûñÿ÷ "
         End Select
      End If
      
      'À**ëèç ÷åòâåðòîé òðè*äû
      T4Str = TrStr(Mid$(Summa, 10, 3), 0)
   
      'À**ëèç êîïååê
      KStr = KdStr(Right$(Summa, 2), 0)
   
      If Len(T1Str & T2Str & T3Str & T4Str) = 0 Then
         Cel = "*îëü "
      Else
         Cel = T1Str & T2Str & T3Str & T4Str
      End If
      '========= Ïðèïèñ*òü â*ëþòó =========
      'Ðóáëè
      If Val(Mid$(Summa, 11, 1)) <> 1 Then
         Select Case Mid$(Summa, 12, 1)
            Case Is = "0"
               Cel = Cel & "ëååâ "
            Case Is = "1"
               Cel = Cel & "ëåé "
            Case Is = "2"
               Cel = Cel & "ëåÿ "
            Case Is = "3"
               Cel = Cel & "ëåÿ "
            Case Is = "4"
               Cel = Cel & "ëåÿ "
            Case Else
               Cel = Cel & "ëåé "
         End Select
      End If
      
      Select Case Mid$(Summa, 11, 2)
         Case Is = "10", "11", "12", "13", "14", "15", "16", "17", "18", "19"
            Cel = Cel & "ëååâ "
      End Select
      
      'Êîïåéêè
      If Val(Mid$(Summa, 14, 1)) <> 1 Then
         Select Case Right$(Summa, 1)
            Case Is = "0"
               KStr = KStr & "á**ü"
            Case Is = "1"
               KStr = KStr & "á**ü"
            Case Is = "2"
               KStr = KStr & "á**ÿ"
            Case Is = "3"
               KStr = KStr & "á**ÿ"
            Case Is = "4"
               KStr = KStr & "á**ÿ"
            Case Else
               KStr = KStr & "á**ü"
         End Select
      End If
      
      Select Case Right$(Summa, 2)
         Case Is = "10", "11", "12", "13", "14", "15", "16", "17", "18", "19"
            KStr = KStr & "á**ü"
      End Select
         SummaString_Val = Cel & KStr
      
      '================================ Ãðèâ*û =================================
      Case Is = 980
      'À**ëèç ïåðâîé òðè*äû
      T1Str = TrStr(Left(Summa, 3), 0)
      If T1Str <> "" Then
         Select Case Right$(Left(Summa, 3), 1)
            Case Is = "0"
               T1Str = T1Str & "ìèëëè*ðäîâ "
            Case Is = "1"
               If Mid$(Left(Summa, 3), 2, 1) = "1" Then
                  T1Str = T1Str & "ìèëëè*ðäîâ "
               Else
                  T1Str = T1Str & "ìèëëè*ðä "
               End If
            Case Is = "2"
               If Mid$(Left(Summa, 3), 2, 1) = "1" Then
                  T1Str = T1Str & "ìèëëè*ðäîâ "
               Else
                  T1Str = T1Str & "ìèëëè*ðä* "
               End If
            Case Is = "3"
               If Mid$(Left(Summa, 3), 2, 1) = "1" Then
                  T1Str = T1Str & "ìèëëè*ðäîâ "
               Else
                  T1Str = T1Str & "ìèëëè*ðä* "
               End If
            Case Is = "4"
               If Mid$(Left(Summa, 3), 2, 1) = "1" Then
                  T1Str = T1Str & "ìèëëè*ðäîâ "
               Else
                  T1Str = T1Str & "ìèëëè*ðä* "
               End If
            Case Else
               T1Str = T1Str & "ìèëëè*ðäîâ "
         End Select
      End If
   
      'À**ëèç âòîðîé òðè*äû
      T2Str = TrStr(Mid$(Summa, 4, 3), 0)
      If T2Str <> "" Then
         Select Case Right$(Mid$(Summa, 4, 3), 1)
            Case Is = "0"
               T2Str = T2Str & "ìèëëèî*îâ "
            Case Is = "1"
               If Mid$(Mid$(Summa, 4, 3), 2, 1) = "1" Then
                  T2Str = T2Str & "ìèëëèî*îâ "
               Else
                  T2Str = T2Str & "ìèëëèî* "
               End If
            Case Is = "2"
               If Mid$(Mid$(Summa, 4, 3), 2, 1) = "1" Then
                  T2Str = T2Str & "ìèëëèî*îâ "
               Else
                  T2Str = T2Str & "ìèëëèî** "
               End If
            Case Is = "3"
               If Mid$(Mid$(Summa, 4, 3), 2, 1) = "1" Then
                  T2Str = T2Str & "ìèëëèî*îâ "
               Else
                  T2Str = T2Str & "ìèëëèî** "
               End If
            Case Is = "4"
               If Mid$(Mid$(Summa, 4, 3), 2, 1) = "1" Then
                  T2Str = T2Str & "ìèëëèî*îâ "
               Else
                  T2Str = T2Str & "ìèëëèî** "
               End If
            Case Else
               T2Str = T2Str & "ìèëëèî*îâ "
         End Select
      End If
      
      'À**ëèç òðåòüåé òðè*äû
      T3Str = TrStr(Mid$(Summa, 7, 3), 1)
      If T3Str <> "" Then
         Select Case Right$(Mid$(Summa, 7, 3), 1)
            Case Is = "0"
               T3Str = T3Str & "òûñÿ÷ "
            Case Is = "1"
               If Mid$(Mid$(Summa, 7, 3), 2, 1) = "1" Then
                  T3Str = T3Str & "òûñÿ÷ "
               Else
                  T3Str = T3Str & "òûñÿ÷* "
               End If
            Case Is = "2"
               If Mid$(Mid$(Summa, 7, 3), 2, 1) = "1" Then
                  T3Str = T3Str & "òûñÿ÷ "
               Else
                  T3Str = T3Str & "òûñÿ÷è "
               End If
            Case Is = "3"
               If Mid$(Mid$(Summa, 7, 3), 2, 1) = "1" Then
                  T3Str = T3Str & "òûñÿ÷ "
               Else
                  T3Str = T3Str & "òûñÿ÷è "
               End If
            Case Is = "4"
               If Mid$(Mid$(Summa, 7, 3), 2, 1) = "1" Then
                  T3Str = T3Str & "òûñÿ÷ "
               Else
                  T3Str = T3Str & "òûñÿ÷è "
               End If
            Case Else
               T3Str = T3Str & "òûñÿ÷ "
         End Select
      End If
      
      'À**ëèç ÷åòâåðòîé òðè*äû
      T4Str = TrStr(Mid$(Summa, 10, 3), 1)
   
      'À**ëèç êîïååê
      KStr = KdStr(Right$(Summa, 2), 1)
   
      If Len(T1Str & T2Str & T3Str & T4Str) = 0 Then
         Cel = "*îëü "
      Else
         Cel = T1Str & T2Str & T3Str & T4Str
      End If
      '========= Ïðèïèñ*òü â*ëþòó =========
      'Ðóáëè
      If Val(Mid$(Summa, 11, 1)) <> 1 Then
         Select Case Mid$(Summa, 12, 1)
            Case Is = "0"
               Cel = Cel & "ãðèâå* "
            Case Is = "1"
               Cel = Cel & "ãðèâ** "
            Case Is = "2"
               Cel = Cel & "ãðèâ*û "
            Case Is = "3"
               Cel = Cel & "ãðèâ*û "
            Case Is = "4"
               Cel = Cel & "ãðèâ*û "
            Case Else
               Cel = Cel & "ãðèâå* "
         End Select
      End If
      
      Select Case Mid$(Summa, 11, 2)
         Case Is = "10", "11", "12", "13", "14", "15", "16", "17", "18", "19"
            Cel = Cel & "ãðèâå* "
      End Select
      
      'Êîïåéêè
      If Val(Mid$(Summa, 14, 1)) <> 1 Then
         Select Case Right$(Summa, 1)
            Case Is = "0"
               KStr = KStr & "êîïååê"
            Case Is = "1"
               KStr = KStr & "êîïåéê*"
            Case Is = "2"
               KStr = KStr & "êîïåéêè"
            Case Is = "3"
               KStr = KStr & "êîïåéêè"
            Case Is = "4"
               KStr = KStr & "êîïåéêè"
            Case Else
               KStr = KStr & "êîïååê"
         End Select
      End If
      
      Select Case Right$(Summa, 2)
         Case Is = "10", "11", "12", "13", "14", "15", "16", "17", "18", "19"
            KStr = KStr & "êîïååê"
      End Select
      
      SummaString_Val = Cel & KStr
      
      '================================ ÅÂÐÎ =================================
      Case Is = 978
      'À**ëèç ïåðâîé òðè*äû
      T1Str = TrStr(Left(Summa, 3), 0)
      If T1Str <> "" Then
         Select Case Right$(Left(Summa, 3), 1)
            Case Is = "0"
               T1Str = T1Str & "ìèëëè*ðäîâ "
            Case Is = "1"
               If Mid$(Left(Summa, 3), 2, 1) = "1" Then
                  T1Str = T1Str & "ìèëëè*ðäîâ "
               Else
                  T1Str = T1Str & "ìèëëè*ðä "
               End If
            Case Is = "2"
               If Mid$(Left(Summa, 3), 2, 1) = "1" Then
                  T1Str = T1Str & "ìèëëè*ðäîâ "
               Else
                  T1Str = T1Str & "ìèëëè*ðä* "
               End If
            Case Is = "3"
               If Mid$(Left(Summa, 3), 2, 1) = "1" Then
                  T1Str = T1Str & "ìèëëè*ðäîâ "
               Else
                  T1Str = T1Str & "ìèëëè*ðä* "
               End If
            Case Is = "4"
               If Mid$(Left(Summa, 3), 2, 1) = "1" Then
                  T1Str = T1Str & "ìèëëè*ðäîâ "
               Else
                  T1Str = T1Str & "ìèëëè*ðä* "
               End If
            Case Else
               T1Str = T1Str & "ìèëëè*ðäîâ "
         End Select
      End If
   
      'À**ëèç âòîðîé òðè*äû
      T2Str = TrStr(Mid$(Summa, 4, 3), 0)
      If T2Str <> "" Then
         Select Case Right$(Mid$(Summa, 4, 3), 1)
            Case Is = "0"
               T2Str = T2Str & "ìèëëèî*îâ "
            Case Is = "1"
               If Mid$(Mid$(Summa, 4, 3), 2, 1) = "1" Then
                  T2Str = T2Str & "ìèëëèî*îâ "
               Else
                  T2Str = T2Str & "ìèëëèî* "
               End If
            Case Is = "2"
               If Mid$(Mid$(Summa, 4, 3), 2, 1) = "1" Then
                  T2Str = T2Str & "ìèëëèî*îâ "
               Else
                  T2Str = T2Str & "ìèëëèî** "
               End If
            Case Is = "3"
               If Mid$(Mid$(Summa, 4, 3), 2, 1) = "1" Then
                  T2Str = T2Str & "ìèëëèî*îâ "
               Else
                  T2Str = T2Str & "ìèëëèî** "
               End If
            Case Is = "4"
               If Mid$(Mid$(Summa, 4, 3), 2, 1) = "1" Then
                  T2Str = T2Str & "ìèëëèî*îâ "
               Else
                  T2Str = T2Str & "ìèëëèî** "
               End If
            Case Else
               T2Str = T2Str & "ìèëëèî*îâ "
         End Select
      End If
      
      'À**ëèç òðåòüåé òðè*äû
      T3Str = TrStr(Mid$(Summa, 7, 3), 1)
      If T3Str <> "" Then
         Select Case Right$(Mid$(Summa, 7, 3), 1)
            Case Is = "0"
               T3Str = T3Str & "òûñÿ÷ "
            Case Is = "1"
               If Mid$(Mid$(Summa, 7, 3), 2, 1) = "1" Then
                  T3Str = T3Str & "òûñÿ÷ "
               Else
                  T3Str = T3Str & "òûñÿ÷* "
               End If
            Case Is = "2"
               If Mid$(Mid$(Summa, 7, 3), 2, 1) = "1" Then
                  T3Str = T3Str & "òûñÿ÷ "
               Else
                  T3Str = T3Str & "òûñÿ÷è "
               End If
            Case Is = "3"
               If Mid$(Mid$(Summa, 7, 3), 2, 1) = "1" Then
                  T3Str = T3Str & "òûñÿ÷ "
               Else
                  T3Str = T3Str & "òûñÿ÷è "
               End If
            Case Is = "4"
               If Mid$(Mid$(Summa, 7, 3), 2, 1) = "1" Then
                  T3Str = T3Str & "òûñÿ÷ "
               Else
                  T3Str = T3Str & "òûñÿ÷è "
               End If
            Case Else
               T3Str = T3Str & "òûñÿ÷ "
         End Select
      End If
      
      'À**ëèç ÷åòâåðòîé òðè*äû
      T4Str = TrStr(Mid$(Summa, 10, 3), 0)
   
      'À**ëèç êîïååê
      KStr = KdStr(Right$(Summa, 2), 0)
   
      If Len(T1Str & T2Str & T3Str & T4Str) = 0 Then
         Cel = "*îëü "
      Else
         Cel = T1Str & T2Str & T3Str & T4Str
      End If
      '========= Ïðèïèñ*òü â*ëþòó =========
      'Ðóáëè
      If Val(Mid$(Summa, 11, 1)) <> 1 Then
         Select Case Mid$(Summa, 12, 1)
            Case Is = "0"
               Cel = Cel & "åâðî "
            Case Is = "1"
               Cel = Cel & "åâðî "
            Case Is = "2"
               Cel = Cel & "åâðî "
            Case Is = "3"
               Cel = Cel & "åâðî "
            Case Is = "4"
               Cel = Cel & "åâðî "
            Case Else
               Cel = Cel & "åâðî "
         End Select
      End If
      
      Select Case Mid$(Summa, 11, 2)
         Case Is = "10", "11", "12", "13", "14", "15", "16", "17", "18", "19"
            Cel = Cel & "åâðî "
      End Select
      
      'Êîïåéêè
      If Val(Mid$(Summa, 14, 1)) <> 1 Then
         Select Case Right$(Summa, 1)
            Case Is = "0"
               KStr = KStr & "öå*òîâ"
            Case Is = "1"
               KStr = KStr & "öå*ò"
            Case Is = "2"
               KStr = KStr & "öå*ò*"
            Case Is = "3"
               KStr = KStr & "öå*ò*"
            Case Is = "4"
               KStr = KStr & "öå*ò*"
            Case Else
               KStr = KStr & "öå*òîâ"
         End Select
      End If
      
      Select Case Right$(Summa, 2)
         Case Is = "10", "11", "12", "13", "14", "15", "16", "17", "18", "19"
            KStr = KStr & "öå*òîâ"
      End Select
         SummaString_Val = Cel & KStr
   End Select
   SummaString_Val = UCase(Left(SummaString_Val, 1)) & Right(SummaString_Val, Len(SummaString_Val) - 1)
End Function
 
'===============================================================================
'===============================================================================
'===============================================================================
'===============================================================================
 
Private Function TrStr(Triada As String, Rod As Integer) As String
   TrStr = ""
   If Rod = 0 Then
      Select Case Left$(Triada, 1)
         Case Is = "1"
            TrStr = TrStr & "ñòî "
         Case Is = "2"
            TrStr = TrStr & "äâåñòè "
         Case Is = "3"
            TrStr = TrStr & "òðèñò* "
         Case Is = "4"
            TrStr = TrStr & "÷åòûðåñò* "
         Case Is = "5"
            TrStr = TrStr & "ïÿòüñîò "
         Case Is = "6"
            TrStr = TrStr & "øåñòüñîò "
         Case Is = "7"
            TrStr = TrStr & "ñåìüñîò "
         Case Is = "8"
            TrStr = TrStr & "âîñåìüñîò "
         Case Is = "9"
            TrStr = TrStr & "äåâÿòüñîò "
      End Select
   
      Select Case Mid$(Triada, 2, 1)
         Case Is = "2"
            TrStr = TrStr & "äâ*äö*òü "
         Case Is = "3"
            TrStr = TrStr & "òðèäö*òü "
         Case Is = "4"
            TrStr = TrStr & "ñîðîê "
         Case Is = "5"
            TrStr = TrStr & "ïÿòüäåñÿò "
         Case Is = "6"
            TrStr = TrStr & "øåñòüäåñÿò "
         Case Is = "7"
            TrStr = TrStr & "ñåìüäåñÿò "
         Case Is = "8"
            TrStr = TrStr & "âîñåìüäåñÿò "
         Case Is = "9"
            TrStr = TrStr & "äåâÿ*îñòî "
      End Select
   
      If Val(Mid$(Triada, 2, 1)) > 1 Then
         Select Case Right$(Triada, 1)
            Case Is = "1"
               TrStr = TrStr & "îäè* "
            Case Is = "2"
               TrStr = TrStr & "äâ* "
            Case Is = "3"
               TrStr = TrStr & "òðè "
            Case Is = "4"
               TrStr = TrStr & "÷åòûðå "
            Case Is = "5"
               TrStr = TrStr & "ïÿòü "
            Case Is = "6"
               TrStr = TrStr & "øåñòü "
            Case Is = "7"
               TrStr = TrStr & "ñåìü "
            Case Is = "8"
               TrStr = TrStr & "âîñåìü "
            Case Is = "9"
               TrStr = TrStr & "äåâÿòü "
         End Select
      End If
   
      Select Case Right$(Triada, 2)
         Case Is = "01"
            TrStr = TrStr & "îäè* "
         Case Is = "02"
            TrStr = TrStr & "äâ* "
         Case Is = "03"
            TrStr = TrStr & "òðè "
         Case Is = "04"
            TrStr = TrStr & "÷åòûðå "
         Case Is = "05"
            TrStr = TrStr & "ïÿòü "
         Case Is = "06"
            TrStr = TrStr & "øåñòü "
         Case Is = "07"
            TrStr = TrStr & "ñåìü "
         Case Is = "08"
            TrStr = TrStr & "âîñåìü "
         Case Is = "09"
            TrStr = TrStr & "äåâÿòü "
         Case Is = "10"
            TrStr = TrStr & "äåñÿòü "
         Case Is = "11"
            TrStr = TrStr & "îäè***äö*òü "
         Case Is = "12"
            TrStr = TrStr & "äâå**äö*òü "
         Case Is = "13"
            TrStr = TrStr & "òðè**äö*òü "
         Case Is = "14"
            TrStr = TrStr & "÷åòûð**äö*òü "
         Case Is = "15"
            TrStr = TrStr & "ïÿò**äö*òü "
         Case Is = "16"
            TrStr = TrStr & "øåñò**äö*òü "
         Case Is = "17"
            TrStr = TrStr & "ñåìü**äö*òü "
         Case Is = "18"
            TrStr = TrStr & "âîñåì**äö*òü "
         Case Is = "19"
            TrStr = TrStr & "äåâÿò**äö*òü "
      End Select
   Else
      Select Case Left$(Triada, 1)
         Case Is = "1"
            TrStr = TrStr & "ñòî "
         Case Is = "2"
            TrStr = TrStr & "äâåñòè "
         Case Is = "3"
            TrStr = TrStr & "òðèñò* "
         Case Is = "4"
            TrStr = TrStr & "÷åòûðåñò* "
         Case Is = "5"
            TrStr = TrStr & "ïÿòüñîò "
         Case Is = "6"
            TrStr = TrStr & "øåñòüñîò "
         Case Is = "7"
            TrStr = TrStr & "ñåìüñîò "
         Case Is = "8"
            TrStr = TrStr & "âîñåìüñîò "
         Case Is = "9"
            TrStr = TrStr & "äåâÿòüñîò "
      End Select
   
      Select Case Mid$(Triada, 2, 1)
         Case Is = "2"
            TrStr = TrStr & "äâ*äö*òü "
         Case Is = "3"
            TrStr = TrStr & "òðèäö*òü "
         Case Is = "4"
            TrStr = TrStr & "ñîðîê "
         Case Is = "5"
            TrStr = TrStr & "ïÿòüäåñÿò "
         Case Is = "6"
            TrStr = TrStr & "øåñòüäåñÿò "
         Case Is = "7"
            TrStr = TrStr & "ñåìüäåñÿò "
         Case Is = "8"
            TrStr = TrStr & "âîñåìüäåñÿò "
         Case Is = "9"
            TrStr = TrStr & "äåâÿ*îñòî "
      End Select
   
      If Val(Mid$(Triada, 2, 1)) > 1 Then
         Select Case Right$(Triada, 1)
            Case Is = "1"
               TrStr = TrStr & "îä** "
            Case Is = "2"
               TrStr = TrStr & "äâå "
            Case Is = "3"
               TrStr = TrStr & "òðè "
            Case Is = "4"
               TrStr = TrStr & "÷åòûðå "
            Case Is = "5"
               TrStr = TrStr & "ïÿòü "
            Case Is = "6"
               TrStr = TrStr & "øåñòü "
            Case Is = "7"
               TrStr = TrStr & "ñåìü "
            Case Is = "8"
               TrStr = TrStr & "âîñåìü "
            Case Is = "9"
               TrStr = TrStr & "äåâÿòü "
         End Select
      End If
   
      Select Case Right$(Triada, 2)
         Case Is = "01"
            TrStr = TrStr & "îä** "
         Case Is = "02"
            TrStr = TrStr & "äâå "
         Case Is = "03"
            TrStr = TrStr & "òðè "
         Case Is = "04"
            TrStr = TrStr & "÷åòûðå "
         Case Is = "05"
            TrStr = TrStr & "ïÿòü "
         Case Is = "06"
            TrStr = TrStr & "øåñòü "
         Case Is = "07"
            TrStr = TrStr & "ñåìü "
         Case Is = "08"
            TrStr = TrStr & "âîñåìü "
         Case Is = "09"
            TrStr = TrStr & "äåâÿòü "
         Case Is = "10"
            TrStr = TrStr & "äåñÿòü "
         Case Is = "11"
            TrStr = TrStr & "îäè***äö*òü "
         Case Is = "12"
            TrStr = TrStr & "äâå**äö*òü "
         Case Is = "13"
            TrStr = TrStr & "òðè**äö*òü "
         Case Is = "14"
            TrStr = TrStr & "÷åòûð**äö*òü "
         Case Is = "15"
            TrStr = TrStr & "ïÿò**äö*òü "
         Case Is = "16"
            TrStr = TrStr & "øåñò**äö*òü "
         Case Is = "17"
            TrStr = TrStr & "ñåìü**äö*òü "
         Case Is = "18"
            TrStr = TrStr & "âîñåì**äö*òü "
         Case Is = "19"
            TrStr = TrStr & "äåâÿò**äö*òü "
      End Select
   End If
End Function
 
Private Function KdStr(Kopeiki As String, Rod As Integer) As String
   KdStr = ""
   
   If Rod = 0 Then
      Select Case Left(Kopeiki, 1)
         Case Is = "2"
            KdStr = KdStr & "Äâ*äö*òü "
         Case Is = "3"
            KdStr = KdStr & "Òðèäö*òü "
         Case Is = "4"
            KdStr = KdStr & "Ñîðîê "
         Case Is = "5"
            KdStr = KdStr & "Ïÿòüäåñÿò "
         Case Is = "6"
            KdStr = KdStr & "Øåñòüäåñÿò "
         Case Is = "7"
            KdStr = KdStr & "Ñåìüäåñÿò "
         Case Is = "8"
            KdStr = KdStr & "Âîñåìüäåñÿò "
         Case Is = "9"
            KdStr = KdStr & "Äåâÿ*îñòî "
      End Select
   
      If Val(Left(Kopeiki, 1)) > 1 Then
         Select Case Right(Kopeiki, 1)
            Case Is = "1"
               KdStr = KdStr & "îäè* "
            Case Is = "2"
               KdStr = KdStr & "äâ* "
            Case Is = "3"
               KdStr = KdStr & "òðè "
            Case Is = "4"
               KdStr = KdStr & "÷åòûðå "
            Case Is = "5"
               KdStr = KdStr & "ïÿòü "
            Case Is = "6"
               KdStr = KdStr & "øåñòü "
            Case Is = "7"
               KdStr = KdStr & "ñåìü "
            Case Is = "8"
               KdStr = KdStr & "âîñåìü "
            Case Is = "9"
               KdStr = KdStr & "äåâÿòü "
         End Select
      Else
         Select Case Kopeiki
            Case Is = "00"
               KdStr = KdStr & "*îëü "
            Case Is = "01"
               KdStr = KdStr & "îäè* "
            Case Is = "02"
               KdStr = KdStr & "äâ* "
            Case Is = "03"
               KdStr = KdStr & "òðè "
            Case Is = "04"
               KdStr = KdStr & "÷åòûðå "
            Case Is = "05"
               KdStr = KdStr & "ïÿòü "
            Case Is = "06"
               KdStr = KdStr & "øåñòü "
            Case Is = "07"
               KdStr = KdStr & "ñåìü "
            Case Is = "08"
               KdStr = KdStr & "âîñåìü "
            Case Is = "09"
               KdStr = KdStr & "äåâÿòü "
            Case Is = "10"
               KdStr = KdStr & "äåñÿòü "
            Case Is = "11"
               KdStr = KdStr & "îäè***äö*òü "
            Case Is = "12"
               KdStr = KdStr & "äâå**äö*òü "
            Case Is = "13"
               KdStr = KdStr & "òðè**äö*òü "
            Case Is = "14"
               KdStr = KdStr & "÷åòûð**äö*òü "
            Case Is = "15"
               KdStr = KdStr & "ïÿò**äö*òü "
            Case Is = "16"
               KdStr = KdStr & "øåñò**äö*òü "
            Case Is = "17"
               KdStr = KdStr & "ñåì**äö*òü "
            Case Is = "18"
               KdStr = KdStr & "âîñåìü**äö*òü "
            Case Is = "19"
               KdStr = KdStr & "äåâÿò**äö*òü "
         End Select
      End If
   Else
      Select Case Left(Kopeiki, 1)
         Case Is = "2"
            KdStr = KdStr & "Äâ*äö*òü "
         Case Is = "3"
            KdStr = KdStr & "Òðèäö*òü "
         Case Is = "4"
            KdStr = KdStr & "Ñîðîê "
         Case Is = "5"
            KdStr = KdStr & "Ïÿòüäåñÿò "
         Case Is = "6"
            KdStr = KdStr & "Øåñòüäåñÿò "
         Case Is = "7"
            KdStr = KdStr & "Ñåìüäåñÿò "
         Case Is = "8"
            KdStr = KdStr & "Âîñåìüäåñÿò "
         Case Is = "9"
            KdStr = KdStr & "Äåâÿ*îñòî "
      End Select
   
      If Val(Left(Kopeiki, 1)) > 1 Then
         Select Case Right(Kopeiki, 1)
            Case Is = "1"
               KdStr = KdStr & "îä** "
            Case Is = "2"
               KdStr = KdStr & "äâå "
            Case Is = "3"
               KdStr = KdStr & "òðè "
            Case Is = "4"
               KdStr = KdStr & "÷åòûðå "
            Case Is = "5"
               KdStr = KdStr & "ïÿòü "
            Case Is = "6"
               KdStr = KdStr & "øåñòü "
            Case Is = "7"
               KdStr = KdStr & "ñåìü "
            Case Is = "8"
               KdStr = KdStr & "âîñåìü "
            Case Is = "9"
               KdStr = KdStr & "äåâÿòü "
         End Select
      Else
         Select Case Kopeiki
            Case Is = "00"
               KdStr = KdStr & "*îëü "
            Case Is = "01"
               KdStr = KdStr & "îä** "
            Case Is = "02"
               KdStr = KdStr & "äâå "
            Case Is = "03"
               KdStr = KdStr & "òðè "
            Case Is = "04"
               KdStr = KdStr & "÷åòûðå "
            Case Is = "05"
               KdStr = KdStr & "ïÿòü "
            Case Is = "06"
               KdStr = KdStr & "øåñòü "
            Case Is = "07"
               KdStr = KdStr & "ñåìü "
            Case Is = "08"
               KdStr = KdStr & "âîñåìü "
            Case Is = "09"
               KdStr = KdStr & "äåâÿòü "
            Case Is = "10"
               KdStr = KdStr & "äåñÿòü "
            Case Is = "11"
               KdStr = KdStr & "îäè***äö*òü "
            Case Is = "12"
               KdStr = KdStr & "äâå**äö*òü "
            Case Is = "13"
               KdStr = KdStr & "òðè**äö*òü "
            Case Is = "14"
               KdStr = KdStr & "÷åòûð**äö*òü "
            Case Is = "15"
               KdStr = KdStr & "ïÿò**äö*òü "
            Case Is = "16"
               KdStr = KdStr & "øåñò**äö*òü "
            Case Is = "17"
               KdStr = KdStr & "ñåì**äö*òü "
            Case Is = "18"
               KdStr = KdStr & "âîñåìü**äö*òü "
            Case Is = "19"
               KdStr = KdStr & "äåâÿò**äö*òü "
         End Select
      End If
   End If
End Function
 
Private Sub Form_Load()
Text1.SelLength = Len(Text1)
End Sub
dev.Free
07.01.2013, 10:19     Visual Basic 6.0 #23
""

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Const KEYEVENTF_KEYUP = &H2
Const VK_CONTROL = &H11
Const VK_MENU = &H12
Const VK_ESCAPE = &H1B
 
Private Sub ShowStartMenu()
Call keybd_event(VK_CONTROL, 0, 0, 0)
Call keybd_event(VK_ESCAPE, 0, 0, 0)
Call keybd_event(VK_ESCAPE, 0, KEYEVENTF_KEYUP, 0)
Call keybd_event(VK_CONTROL, 0, KEYEVENTF_KEYUP, 0)
End Sub
 
Private Sub Command1_Click()
Call ShowStartMenu
End Sub


Key Code Visual Basic 6.0 Visual Basic 2008. . Windows VK_CONTROL, 0, KEYEVENTF_KEYUP, 0 , , Windows . CTRL + ALT + DELETE.
dev.Free
07.01.2013, 10:33     Visual Basic 6.0 #24
60- ftp.

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal sAgent As String, ByVal nAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal nFlags As Long) As Long
Private Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" (ByVal hInternetSession As Long, ByVal sServerName As String, ByVal nServerPort As Integer, ByVal sUserName As String, ByVal sPassword As String, ByVal nService As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Private Declare Function FtpPutFile Lib "wininet.dll" Alias "FtpPutFileA" (ByVal hFtpSession As Long, ByVal lpszLocalFile As String, ByVal lpszRemoteFile As String, ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean
Private Declare Function FtpGetFile Lib "wininet.dll" Alias "FtpGetFileA" (ByVal hFtpSession As Long, ByVal lpszRemoteFile As String, ByVal lpszNewFile As String, ByVal fFailIfExists As Boolean, ByVal dwFlagsAndAttributes As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean
Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer
 
Dim rc&
Dim rs&
 
Private Sub Command1_Click()
    rc& = InternetOpen("", 0, vbNullString, vbNullString, 0)
    rs& = InternetConnect(rc&, "ftp.narod.ru", "21", "Login", "Password", 1, 0, 0)
    If FtpGetFile(rs&, "GetFile.txt", "C:\GetFile.txt", False, 0, 2, 0) = False Then MsgBox "  !", vbExclamation
    'If FtpPutFile(rs&, "C:\SendFile.txt", "SendFile.txt", 2, 0) = False Then MsgBox "  !", vbExclamation
    ' dwFlags  FtpGetFile/FtpPutFile   /.
    '    : 1 -  ASCII; 2 -  Binary
    Call InternetCloseHandle(rs&)
    Call InternetCloseHandle(rc&)
End Sub


61- ( ).

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
':
'     Print( Write)
 
Open "c:\1.txt" For Append As #1 '    ,    Print #1, " "'    1.txt 
Close #1 ' 
 
'       - FreeFile. :
f = FreeFile '   
Open "c:\1.txt" For Append As f '    
Print #f, " "'   1.txt 
Close #f ' 
 
':
'      .       . :
 
f = FreeFile
Open "c:\1.txt" For Input As f'   1.txt  
Text1.Text = Input(LOF(f), f) '       ( LOF(Len Of File)   )
Close f
 
':
 
Dim txt as String
 
Open "c:\1.txt" For Input As #1'   1.txt  
Do While Not EOF(1) '  EOF(End Of File) ,     Line Input #1, txt '    Text1.Text = txt
Loop
Close #1


62- .

Windows XP, Windows Seven.

Visual Basic
1
2
3
4
5
6
7
8
9
10
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Const SPI_SETDESKWALLPAPER = 20
 
Private Sub SetWallpaper(File As String)
SystemParametersInfo SPI_SETDESKWALLPAPER, 0, ByVal File, True
End Sub
 
Private Sub Form_Load()
SetWallpaper "D:\123.JPG"
End Sub


63- , , , .

Visual Basic
1
2
3
4
5
6
7
8
9
10
Private Declare Function ShellExecute Lib "shell32.dll" Alias _
"ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, _
ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
 
Private Const SW_NORMAL = (1&)
 
Private Sub Command1_Click()
Call ShellExecute(Me.hwnd, "open", "D:\123.JPG", 0&, 0&, SW_NORMAL&)
End Sub
Cricket93
143 / 44 / 1
: 06.11.2012
: 283
13.01.2013, 13:30     Visual Basic 6.0 #25


( , ctrl + T (), "Microsoft Internet Controls"), ! 2 ( Multiline = true, scroolbars = 2) , !

...

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
Private Sub Command1_Click()
tex = Text1.text
tex = Replace(tex, " ", "+")
url = "http: // translate.yandex.net/api/v1/tr/translate?lang=en-ru&text=" & tex
WebBrowser1.Navigate url
End Sub
 
 
Private Sub Form_Load()
Dim tex$, tex2$, i%, url$, dv1&, dv2&, txt$
WebBrowser1.Navigate "about:blank"
End Sub
 
Private Sub WebBrowser1_DocumentComplete(ByVal pDisp As Object, url As Variant)
On Error Resume Next
If WebBrowser1.LocationURL = url Then 
txt = WebBrowser1.Document.body.innertext 
dv1 = InStr(1, txt, "")
dv2 = InStr(dv1, txt, "</text>")
nTxt = Mid$(txt, dv1, dv2 - dv1)
Text2.text = nTxt
End If
End Sub
Cricket93
143 / 44 / 1
: 06.11.2012
: 283
17.01.2013, 00:19     Visual Basic 6.0 #26

! , .

Visual Basic
1
2
3
4
5
6
7
' :
Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long 
 
Private Sub Form_Load() '  ,   :
SetWindowRgn hWnd, CreateEllipticRgn(80, 0, 300, 200), True '     -   , ,   (80),  ,  
End Sub
dev.Free
19.01.2013, 12:34     Visual Basic 6.0 #27
66- ALT+F4

, , .

Visual Basic
1
2
3
4
5
6
7
8
9
Option Explicit
 
Private Sub Form_QueryUnload _
    (Cancel As Integer, _
     UnloadMode As Integer)
   If UnloadMode = vbFormControlMenu Then
    Cancel = True
   End If
End Sub


67- .

SHBrowseForFolder , , . , Null.

SHGetPathFromIDList pszPath as String .


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
Private Type BROWSEINFO
  hOwner As Long
  pidlRoot As Long
  pszDisplayName As String
  lpszTitle As String
  ulFlags As Long
  lpfn As Long
  lParam As Long
  iImage As Long
End Type
 
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" _
(lpBrowseInfo As BROWSEINFO) As Long
 
Const BIF_RETURNONLYFSDIRS = &H1
 
Private Sub Command1_Click()
  Dim myBrowseInfo As BROWSEINFO
  Dim execNumderDir As Boolean
  Dim NumderDir As Long
  Dim pos As Integer
  Dim myPath_512 As String
 
  With myBrowseInfo
    .hOwner = Me.hWnd
    .pidlRoot = 0&
    .lpszTitle = "Select directory"
    .ulFlags = BIF_RETURNONLYFSDIRS
  End With
 
  NumderDir& = SHBrowseForFolder(myBrowseInfo)
  myPath_512$ = Space$(512)
  execNumderDir = SHGetPathFromIDList(ByVal NumderDir&, ByVal myPath_512$)
 
  If execNumderDir Then
    pos = InStr(myPath_512$, Chr$(0))
    myPath = Left(myPath_512$, pos - 1)
  Else:
    myPath = ""
  End If
  Text1.Text = myPath
End Sub


68- RichTextBox, ?

Visual Basic
1
2
3
4
5
Option Explicit
 
Private Sub Command1_Click()
RichTextBox1.SelPrint (Printer.hDC)
End Sub


69- RichTextBox, ?

:

Visual Basic
1
2
3
4
5
Option Explicit
 
Private Sub Command1_Click()
PrintRTF RichTextBox1, 1440, 1440, 1440, 1440
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
Option Explicit
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type CharRange
cpMin As Long
cpMax As Long
End Type
Private Type FormatRange
hDC As Long
hdcTarget As Long
rc As RECT
rcPage As RECT
chrg As CharRange
End Type
Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90
Private Const PHYSICALOFFSETX As Long = 112
Private Const PHYSICALOFFSETY As Long = 113
Private Const WM_USER As Long = &H400
Private Const EM_FORMATRANGE As Long = WM_USER + 57
Private Declare Function GetDeviceCaps Lib "gdi32" _
    (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
    (ByVal hwnd As Long, _
     ByVal msg As Long, _
     ByVal wp As Long, _
     lp As Any) As Long
 
Public Declare Function DrawText Lib "user32" Alias "DrawTextA" _
    (ByVal hDC As Long, _
     ByVal lpStr As String, _
     ByVal nCount As Long, _
     lpRect As RECT, _
     ByVal wFormat As Long) As Long
 
Public Sub PrintRTF(rtf As RichTextBox, LeftMarginWidth As Long, _
        TopMarginHeight, RightMarginWidth, BottomMarginHeight, Optional Text$)
Dim LeftOffset&, TopOffset&, LeftMargin&, TopMargin&
Dim RightMargin&, BottomMargin&
Dim rcDrawTo As RECT, rcPage As RECT
Dim TextLength&, NextCharPos&
Dim fr As FormatRange, Page&, tmp$
 
NextCharPos = 0
Page = 1
Printer.ScaleMode = vbTwips
LeftOffset = GetDeviceCaps(Printer.hDC, PHYSICALOFFSETX) / _
                                    GetDeviceCaps(Printer.hDC, LOGPIXELSX) * 1440
TopOffset = GetDeviceCaps(Printer.hDC, PHYSICALOFFSETY) / _
                                    GetDeviceCaps(Printer.hDC, LOGPIXELSY) * 1440
LeftMargin = LeftMarginWidth - LeftOffset
TopMargin = TopMarginHeight - TopOffset
RightMargin = (Printer.Width - RightMarginWidth) - LeftOffset
BottomMargin = (Printer.Height - BottomMarginHeight) - TopOffset
rcPage.Left = 0
rcPage.Top = 0
rcPage.Right = Printer.ScaleWidth
rcPage.Bottom = Printer.ScaleHeight
rcDrawTo.Left = LeftMargin
rcDrawTo.Top = TopMargin
rcDrawTo.Right = RightMargin
rcDrawTo.Bottom = BottomMargin
TextLength = Len(rtf.Text)
Do
fr.hDC = Printer.hDC
fr.hdcTarget = Printer.hDC
fr.chrg.cpMin = NextCharPos
fr.chrg.cpMax = -1
fr.rc = rcDrawTo
fr.rcPage = rcPage
Printer.Print Space(1)
tmp = "  RichTextBox: " & Text
DrawText Printer.hDC, tmp, Len(tmp), MakeRect(10, 10, Printer.Width, 700), 0
tmp = Chr$(32) & Page
DrawText Printer.hDC, tmp, Len(tmp), MakeRect(Printer.Width / _
        Printer.TwipsPerPixelX - Printer.TextWidth(tmp), 10, Printer.Width, 700), 0
NextCharPos = SendMessage(rtf.hwnd, EM_FORMATRANGE, True, fr)
If NextCharPos < = 0 Or NextCharPos >= TextLength Then Exit Do
Printer.NewPage
Page = Page + 1
Loop
Printer.EndDoc
SendMessage rtf.hwnd, EM_FORMATRANGE, False, ByVal CLng(0)
End Sub
 
Public Function MakeRect(Left&, Top&, Right&, Bottom&) As RECT
With MakeRect
 .Bottom = Bottom
 .Left = Left
 .Right = Right
 .Top = Top
End With
End Function


70- ?

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
Option Explicit
 
Private Declare Function SetLocalTime Lib "kernel32.dll" _
                    (lpSystemTime As SystemTime) As Long
 
Private Type SystemTime
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
End Type
 
Dim SetTime As SystemTime
Dim RetVal As Long
 
Private Sub SetNewTime _
    (NewHour As Integer, NewMinute As Integer, NewSecond As Integer)
SetTime.wHour = NewHour
SetTime.wMinute = NewMinute
SetTime.wSecond = NewSecond
SetTime.wMilliseconds = 0
SetTime.wDay = Day(Date)
'     
'SetTime.wDay = 06
SetTime.wMonth = Month(Date)
'SetTime.wMonth = 8
SetTime.wYear = Year(Date)
'SetTime.wYear = 2006
RetVal = SetLocalTime(SetTime)
End Sub
 
Private Sub Command1_Click()
Call SetNewTime(19, 42, 11)
End Sub


1 ?

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
Option Explicit
 
Private Sub Text2_Change()
On Error GoTo ErrLabel
Dim Message As String
Dim NumberM As Integer
Dim FileNum As Byte
Message = String$(1, " ")
FileNum = FreeFile
Open App.Path & "\1.txt" For Binary As FileNum
NumberM = Val(Text2.Text)
Get #FileNum, NumberM, Message
Text1.Text = Message
Close FileNum
Exit Sub
 
ErrLabel:
    Dim errsabj As String
    If Err.Number = 63 Then
    errsabj = MsgBox("   ,  !", _
            vbCritical + vbRetryCancel)
        Select Case errsabj
        Case vbCancel
            End
        Case vbRetry
            Text2.Text = ""
            Resume Next
        End Select
    End If
End Sub


71- ?

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
'     
'    
Option Explicit
 
Dim FileNum As Byte
 
Private Declare Function ShellExecute Lib "shell32" Alias "ShellExecuteA" _
            (ByVal hwnd As Long, _
            ByVal lpOperation As String, _
            ByVal lpFile As String, _
            ByVal lpParameters As String, _
            ByVal lpDirectory As String, _
            ByVal nShowCmd As Long) As Long
 
Private Const SW_SHOWNORMAL = 1
 
Private Sub Form_Load()
FileNum = FreeFile
Open "D:\Sample.txt" For Append As FileNum
Print #FileNum, "  "
Print #FileNum, "  "
Close FileNum
 
ShellExecute 0, vbNullString, "D:\Sample.txt", vbNullString, _
                                vbNullString, SW_SHOWNORMAL
End
End Sub


, [a; b]

Visual Basic
1
2
3
For i=1 to N
  if i< a or i> b then print X(i)
Next i
?

Visual Basic
1
2
3
4
5
Option Explicit
 
Private Sub Form_Load()
Text1.Text = Replace(" ,   ", " ", "")
End Sub


?

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Option Explicit
 
Private Sub Command1_Click()
Text1.Text = Replace(Text1.Text, Text3.Text, Text2.Text)
End Sub
 
Private Sub Command2_Click()
Text1.Text = Replace(Text1.Text, Text2.Text, Text3.Text)
End Sub
 
Private Sub Form_Load()
Text1.Text = _
        "    ,     Replace"
Text2.Text = ""
Text3.Text = ""
End Sub


75- .

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
Private Sub Command1_Click()
  Cls
  Kohh Text1.Text, 0, Me.ScaleHeight - 10 * Screen.TwipsPerPixelY, _
                   Me.ScaleWidth, Me.ScaleHeight - 10 * Screen.TwipsPerPixelY
End Sub
 
Private Sub Kohh(NumIt As Integer, x1&, y1&, x2&, y2&)
  If NumIt = 1 Or (x1 \ Screen.TwipsPerPixelX = x2 \ Screen.TwipsPerPixelX And y1 \ Screen.TwipsPerPixelY = y2 \ Screen.TwipsPerPixelY) Then
    Line (x1, y1)-(x2, y2)
  Else
    Kohh NumIt - 1, x1, y1, _
                    x1 + (x2 - x1) / 3, y1 + (y2 - y1) / 3
    Kohh NumIt - 1, x1 + (x2 - x1) / 3, y1 + (y2 - y1) / 3, _
                    (x1 + x2) / 2 + (y2 - y1) * Sqr(3) / 6, (y1 + y2) / 2 - (x2 - x1) * Sqr(3) / 6
    Kohh NumIt - 1, (x1 + x2) / 2 + (y2 - y1) * Sqr(3) / 6, (y1 + y2) / 2 - (x2 - x1) * Sqr(3) / 6, _
                    x2 - (x2 - x1) / 3, y2 - (y2 - y1) / 3
    Kohh NumIt - 1, x2 - (x2 - x1) / 3, y2 - (y2 - y1) / 3, _
                    x2, y2
  End If
 
  Stps = (Stps + 1) Mod 30000
  If Stps = 0 Then DoEvents
End Sub


76- .

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
Option Explicit
Dim xA, yA, xB, yB, xC, yC As Double
Dim level As Integer
Dim yT As Double
 
Private Sub Command1_Click()
Picture1.Cls
 
'Picture1.Scale (-10, 10)-(10, -10)
 
Picture1.DrawWidth = 2
 
'xA = -8: yA = -8: xC = 8: yC = -8
 
xA = 300: yA = Picture1.Height - 300: xC = Picture1.Width - 300: yC = Picture1.Height - 300
level = Val(Text1.Text)
If level < = 0 Then
    MsgBox "!", vbInformation, "ERROR"
    Text1.Text = ""
    Exit Sub
End If
xB = (xA + xC) / 2
 
'For yT = yA To 10 Step 0.001
 
For yT = yA To Picture1.Height Step 0.001
    If FormatNumber(Sqr((xB - xA) * (xB - xA) + (yT - yA) * (yT - yA)), 3) = _
    FormatNumber(Sqr((xC - xA) * (xC - xA) + (yC - yA) * (yC - yA)), 3) Then
        yB = yT
    End If
Next yT
Picture1.Line (xA, yA)-(xB, yB)
Picture1.Line (xB, yB)-(xC, yC)
Picture1.Line (xC, yC)-(xA, yA)
 
dr xA, yA, xB, yB, xC, yC, level
End Sub
 
Private Sub dr(xA, yA, xB, yB, xC, yC, level)
 
    Dim a, h, l As Double
    Dim x1, y1, x2, y2, x3, y3 As Double
 
    If level <> 1 Then
        a = Sqr((xC - xA) * (xC - xA) + (yC - yA) * (yC - yA))
        h = a * (Sqr(3) / 2)
        l = Sqr((a / 2) * (a / 2) - (h / 2) * (h / 2))
        x1 = xA + l
        y1 = yB + h / 2
        ' y1 = yB + h / 2
        x2 = xC - l: y2 = y1
        x3 = (xC + xA) / 2: y3 = yA
 
        Picture1.Line (x1, y1)-(x2, y2)
        Picture1.Line (x2, y2)-(x3, y3)
        Picture1.Line (x3, y3)-(x1, y1)
 
        dr xA, yA, x1, y1, x3, y3, level - 1
        dr x1, y1, xB, yB, x2, y2, level - 1
        dr x3, y3, x2, y2, xC, yC, level - 1
    End If
End Sub
dev.Free
08.02.2013, 15:12     Visual Basic 6.0 #28
77- .

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
Private Sub UserControl_MouseDown(Button As Integer, Shift 
As Integer, X As Single, Y As Single)
         On Error GoTo Routine_Error
 
         If Button = vbRightButton Then PopupMenu mnuFile    
'mnuFile     
 
     Routine_Error:
         If Err.Number <> 0 Then MsgBox Err.Description, 
vbInformation, Err.Source
     End Sub
78- HTML RichTextBox.

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
' Color the tags in the RichTextBox's text.
' This version is a little simple and does not
' ignores comment properly. It cannot handle nested
' brackets as in:
'
' <A HREF= <!-- here's a comment -->
'    http://www.vb-helper.com>
'
Private Sub ColorTags(rch As RichTextBox)
Dim txt As String
Dim tag_open As Integer
Dim tag_close As Integer
 
    txt = rch.Text
    tag_close = 1
    Do
        ' See where the next tag starts.
        tag_open = InStr(tag_close, txt, "<")
        If tag_open = 0 Then Exit Do
       
        ' See where the tag ends.
        tag_close = InStr(tag_open, txt, ">")
        If tag_open = 0 Then tag_close = Len(txt)
       
        ' Color the tag.
        rch.SelStart = tag_open - 1
        rch.SelLength = tag_close - tag_open + 1
        rch.SelColor = vbRed
    Loop
End Sub
 
' Load the file.
Private Sub Form_Load()
Dim fnum As Integer
Dim txt As String
 
    ' Move the hidden text box so it cannot be seen.
    rchHidden.Move -rchHidden.Width - 120, 0
   
    ' Load the file.
    fnum = FreeFile
    Open App.Path & " odbooks.htm" For Input As fnum
    txt = Input$(LOF(fnum), fnum)
    rchHidden.Text = txt
    Close fnum
 
    ' Color the HTML tags.
    ColorTags rchHidden
 
    ' Copy the result to the visible text box.
    rchHidden.SelStart = 0
    rchHidden.SelLength = Len(rchHidden.Text)
    rchVisible.SelStart = 0
    rchVisible.SelLength = Len(rchVisible.Text)
    rchVisible.SelRTF = rchHidden.SelRTF
End Sub
Private Sub Form_Resize()
    rchVisible.Move 0, 0, ScaleWidth, ScaleHeight
End Sub


79- Text Box ?

Visual Basic
1
2
3
4
Private Sub txtname_KeyPress(KeyAscii As Integer)
        '      
        KeyAscii = Asc(UCase(Chr(KeyAscii)))
End Sub
80- ComboBox.

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Declare Function SendMessage Lib "User" _ 
(ByVal hWnd As Integer, ByVal wMsg As Integer, _ 
ByVal wParam As Integer, lParam As Any) As Long 
 
Sub CBFindString (ctlEdit As Control, _ 
sSearch As String) 
Dim lPos As Long 
 
Const CB_FINDSTRING = &H40C 
lPos = SendMessage(ctlEdit.hWnd, CB_FINDSTRING, _ 
0, ByVal sSearch) 
If lPos >= 0 Then 
ctlEdit.ListIndex = lPos 
End If 
End Sub
81- (Tabs).

, ? list box . List box , ; . list box (List1) Picture box (Picture1) . Index Picture1 . Form_Load:

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
Private Sub Form_Load()
    Dim x As Integer
    For x = 0 To 15
        List1.AddItem "Picture1(" & x & ")"
    If x > 0 Then Load Picture1(x)
    Picture(x).AutoRedraw = True
        Picture(x).AutoRedraw = True
        Picture(x).Visible = True
        Picture(x).Left = Picture1(0).Left
        Picture(x).Top = Picture1(0).Top
        Picture(x).Width = Picture1(0).Width
        Picture(x).Height = Picture1(0).Height
        Picture1(x).Print "This is picture " & x
    Next x
    Me.Show: Me.Refresh
    List1.ListIndex = 0
 
End Sub
 VB 4.0,    :
 
With Picture1(x)
    .AutoRedraw = True
    .Visible = True
    .Left = Picture1(0).Left
    .Top = Picture1(0).Top
    .Width = Picture1(0).Width
    .Height = Picture1(0).Height
End With


, picture . .

List1_Click:

Visual Basic
1
Picture1(List1.ListIndex).ZOrder
, (picture). - VBX !
Dragokas
 Windows FAQ
15772 / 6620 / 796
: 25.12.2011
: 10,238
: 16
10.02.2013, 01:48  []     Visual Basic 6.0 #29
--
: BV (Boris Vorontsov)
API- mciSendString,
mciSendString .

.

:
  • ,
  • ""
  • CD
  • /
  • ,
  • .
 : rar clsMedia.rar (23.3 , 207 )
Dragokas
 Windows FAQ
15772 / 6620 / 796
: 25.12.2011
: 10,238
: 16
10.02.2013, 19:51  []     Visual Basic 6.0 #30
-
API- mciSendString
(Lite- )

:

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
Option Explicit
 
Public Declare Function mciSendString& Lib "winmm.dll" Alias "mciSendStringA" _
    (ByVal lpstrCommand$, _
    ByVal lpstrReturnString$, _
    ByVal uReturnLength&, _
    ByVal hwndCallback&)
 
Private Const MCI_ALIAS As String = "Media_1" '//  
 
Sub main()
    Dim strFileName$
    
    strFileName = "u:\\9-para_normalnih vstavay.mp3" '//   -
    
    '//         
    strFileName = Replace(strFileName, Chr(34), "")
    If InStr(strFileName, " ") <> 0 Then strFileName = Chr(34) & strFileName & Chr(34)
    
    '//   (-    -    )
    PlaySnd strFileName
    'PlaySnd strFileName:=strFileName, ASync:=False
    
    MCISend "Pause " & MCI_ALIAS '// 
    Stop
    
    MCISend "Resume " & MCI_ALIAS '// 
    Stop
    
    StopSnd '// 
End Sub
 
Sub StopSnd()
    MCISend "Stop " & MCI_ALIAS '//  
    MCISend "Close " & MCI_ALIAS '//  
End Sub
 
Sub PlaySnd(strFileName$, Optional ASync As Boolean = True)
        '//  .
        '//    ,      
        '// Seek  .         .
    MCISend "Close " & MCI_ALIAS
    MCISend "Open " & strFileName & " alias " & MCI_ALIAS '//  
    MCISend "Play " & MCI_ALIAS & IIf(ASync, "", " wait")
End Sub
 
Sub MCISend(lpstrCommand$)
    mciSendString lpstrCommand, vbNullString, 0&, 0&
End Sub
antonboom
bmstu-team
301 / 136 / 56
: 10.01.2012
: 420
: 10
11.02.2013, 00:00     Visual Basic 6.0 #31

:
  1. File\Save Form1 As
  2. File\Save Form1 As

    - ( ), .
  3. - , , Form11
  4. Project\Add File (Ctrl + D) (2)
  5. .

:

MS Visual Basic 6.0

      Visual Basic 6.0  
dev.Free
17.02.2013, 16:09     Visual Basic 6.0 #32
"" Windows.

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
'    CommandButton
' :      
' ,       Restart  
' .
 
Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
 
Private Sub Command1_Click()
    Dim freez
    
    freez = SetParent(Me.hWnd, Me.hWnd)
End Sub


, Windows.

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
' 1
'      (1000  = 1 ). 
'    -   1000.
 
Private Declare Function GetTickCount Lib "Kernel32" () As Long
 
Private Sub Form_Load()
    MsgBox GetTickCount()
End Sub
 
'   .
 
Private Declare Function GetTickCount Lib "Kernel32" () As Long
 
Private Sub Command1_Click()
    Dim a_hour, a_minute, a_second
    a = Format(GetTickCount() / 1000, "0") ' 
    a_hour = Int(a / 3600)
    a = a - a_hour * 3600
    a_minute = Int(a / 60)
    a_second = a - a_minute * 60
    MsgBox "      " & str(a_hour) & "  " & str(a_minute) & " " & str(a_second) & " "
End Sub
 
'  
'    ListBox   Timer
 
Private Declare Function GetTickCount& Lib "Kernel32" ()
 
Private Sub Form_Load()
    Timer1.Interval = 1000
End Sub
 
Private Sub Timer1_Timer()
    MS = GetTickCount()
    SekGesamt = MS \ 1000
    Std = (SekGesamt \ 3600)
    Min = (SekGesamt - (Std * 3600)) \ 60
    Sek = (SekGesamt - (Std * 3600) - (Min * 60))
    t = Format(Std, "00") & ":" & Format(Min, "00") & ":" & Format(Sek, "00")
    Label1.Caption = t
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
'          
' 55  * 22 .   temp.bmp
 
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
 
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight 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
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 GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
 
Const SRCCOPY = &HCC0020
 
Dim hwndTB As Long ' handle taskbar'
Dim hWndSB As Long ' handle   
Dim hDcSB As Long ' handle   
Dim mRect As RECT '   
Dim hDcTmp As Long ' handle  
Dim hBmpTmp As Long '  
Dim hBmpTmp2 As Long '  
Dim nWidth As Long '   
Dim nHeight As Long '   
Dim sPath As String '   
 
Private Sub Form_Load()
    '  handle taskbar   
    hwndTB = FindWindow("Shell_TrayWnd", "")
    hWndSB = FindWindowEx(hwndTB, 0, "button", vbNullString)
    '  dc  
    hDcSB = GetWindowDC(hWndSB)
    '    
    Call GetWindowRect(hWndSB, mRect)
    '   
    nWidth = mRect.Right - mRect.Left
    nHeight = mRect.Bottom - mRect.Top
    hDcTmp = CreateCompatibleDC(hDcSB)
    hBmpTmp = CreateCompatibleBitmap(hDcTmp, nWidth, nHeight)
    '     
    sPath = App.Path & "\temp.bmp"
    hBmpTmp2 = SelectObject(hDcTmp, LoadPicture(sPath))
End Sub
 
Private Sub tmrPaint_Timer()
    '   
    Call BitBlt(hDcSB, 0, 0, nWidth, nHeight, hDcTmp, 0, 0, SRCCOPY)
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
    '   
    hBmpTmp = SelectObject(hDcTmp, hBmpTmp2)
    DeleteObject hBmpTmp
    DeleteDC hDcTmp
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
'         .  
' timer1, interval = 50.   lblTime, Top = 0, left = 0
 
'     
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
'    
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
'    
Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
 
Private Sub Form_Load()
    Dim hnd As Long
    
    '    
    '         
    '    (  : Shell_TrayWnd)
    hnd = FindWindow("Shell_TrayWnd", vbNullString)
    '   ( : TrayNotifyWnd)
    hnd = FindWindowEx(hnd, 0, "TrayNotifyWnd", vbNullString)
    '   ( : TrayClockWClass)
    hnd = FindWindowEx(hnd, 0, "TrayClockWClass", vbNullString)
    '    
    Me.Left = 0
    Me.Top = 0
    SetParent Me.hwnd, hnd
End Sub
 
Private Sub Timer1_Timer()
    lblTime = Time
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
Private Declare Function SetSysColors Lib "user32" (ByVal nChanges As Long, lpSysColor As Long, lpColorValues As Long) As Long
 
Private Declare Function GetSysColor& Lib "user32" (ByVal nIndex As Long)
 
'   
Private Const COLOR_SCROLLBAR = 0 'The Scrollbar colour
Private Const COLOR_BACKGROUND = 1 'Colour of the background With no wallpaper
Private Const COLOR_ACTIVECAPTION = 2 'Caption of Active Window
Private Const COLOR_INACTIVECAPTION = 3 'Caption of Inactive window
Private Const COLOR_MENU = 4 'Menu
Private Const COLOR_WINDOW = 5 'Windows background
Private Const COLOR_WINDOWFRAME = 6 'Window frame
Private Const COLOR_MENUTEXT = 7 'Window Text
Private Const COLOR_WINDOWTEXT = 8 '3D dark shadow (Win95)
Private Const COLOR_CAPTIONTEXT = 9 'Text in window caption
Private Const COLOR_ACTIVEBORDER = 10 'Border of active window
Private Const COLOR_INACTIVEBORDER = 11 'Border of inactive window
Private Const COLOR_APPWORKSPACE = 12 'Background of MDI desktop
Private Const COLOR_HIGHLIGHT = 13 'Selected item background
Private Const COLOR_HIGHLIGHTTEXT = 14 'Selected menu item
Private Const COLOR_BTNFACE = 15 'Button
Private Const COLOR_BTNSHADOW = 16 '3D shading of button
Private Const COLOR_GRAYTEXT = 17 'Grey text, of zero If dithering Is used.
Private Const COLOR_BTNTEXT = 18 'Button text
Private Const COLOR_INACTIVECAPTIONTEXT = 19 'Text of inactive window
Private Const COLOR_BTNHIGHLIGHT = 20 '3D highlight of button
 
Dim OldColor As Long
 
Private Sub Form_Load()
    '  
    OldColor = GetSysColor(COLOR_ACTIVECAPTION)
    
    SetSysColors 1, COLOR_ACTIVECAPTION, RGB(255, 0, 0)
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
    '  
    SetSysColors 1, COLOR_ACTIVECAPTION, OldColor
End Sub


Windows, GetSystemInfo.

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
Private Type SYSTEM_INFO
    dwOemID As Long
    dwPageSize As Long
    lpMinimumApplicationAddress As Long
    lpMaximumApplicationAddress As Long
    dwActiveProcessorMask As Long
    dwNumberOrfProcessors As Long
    dwProcessorType As Long
    dwAllocationGranularity As Long
    dwReserved As Long
End Type
 
Private Type OSVERSIONINFO
    dwOSVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformId As Long
    szCSDVersion As String * 128
End Type
 
Private Type MEMORYSTATUS
    dwLength As Long
    dwMemoryLoad As Long
    dwTotalPhys As Long
    dwAvailPhys As Long
    dwTotalPageFile As Long
    dwAvailPageFile As Long
    dwTotalVirtual As Long
    dwAvailVirtual As Long
End Type
 
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (LpVersionInformation As OSVERSIONINFO) As Long
Private Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As MEMORYSTATUS)
Private Declare Sub GetSystemInfo Lib "kernel32" (lpSystemInfo As SYSTEM_INFO)
 
Const PROCESSOR_INTEL_386 = 386
Const PROCESSOR_INTEL_486 = 486
Const PROCESSOR_INTEL_PENTIUM = 586
Const PROCESSOR_MIPS_R4000 = 4000
Const PROCESSOR_ALPHA_21064 = 21064
 
Sub SystemInformation()
    Dim msg As String ' Status information.
    Dim NewLine As String ' New-line.
    Dim ret As Integer ' OS Information
    Dim ver_major As Integer ' OS Version
    Dim ver_minor As Integer ' Minor Os Version
    Dim Build As Long ' OS Build
    NewLine = Chr(13) + Chr(10) ' New-line.
    ' Get operating system And version.
    Dim verinfo As OSVERSIONINFO
    
    verinfo.dwOSVersionInfoSize = Len(verinfo)
    ret = GetVersionEx(verinfo)
    If ret = 0 Then
        MsgBox "Error Getting Version Information"
        End
    End If
    'MsgBox verinfo.dwPlatformId
    Select Case verinfo.dwPlatformId
        Case 0
        msg = msg + "Windows 32s "
        Case 1
        msg = msg + "Windows 95 "
        Case 2
        msg = msg + "Windows NT "
    End Select
    
    ver_major = verinfo.dwMajorVersion
    ver_minor = verinfo.dwMinorVersion
    Build = verinfo.dwBuildNumber
    msg = msg & ver_major & "." & ver_minor
    msg = msg & " (Build " & Build & ")" & NewLine & NewLine
    
    ' Get CPU Type And operating mode.
    Dim sysinfo As SYSTEM_INFO
    GetSystemInfo sysinfo
    msg = msg + "CPU: "
    'MsgBox sysinfo.dwProcessorType
    Select Case sysinfo.dwProcessorType
        Case PROCESSOR_INTEL_386
        msg = msg + "Intel 386" + NewLine
        Case PROCESSOR_INTEL_486
        msg = msg + "Intel 486" + NewLine
        Case PROCESSOR_INTEL_PENTIUM
        msg = msg + "Intel Pentium" + NewLine
        Case PROCESSOR_MIPS_R4000
        msg = msg + "MIPS R4000" + NewLine
        Case PROCESSOR_ALPHA_21064
        msg = msg + "DEC Alpha 21064" + NewLine
        Case Else
        msg = msg + "(unknown)" + NewLine
    End Select
    msg = msg + NewLine
    ' Get free memory.
    Dim memsts As MEMORYSTATUS
    Dim memory As Long
    
    GlobalMemoryStatus memsts
    memory = memsts.dwTotalPhys
    msg = msg + "Total Physical Memory: "
    msg = msg + Format(memory \ 1024, "###,###,###") + "K" + NewLine
    memory = memsts.dwAvailPhys
    msg = msg + "Available Physical Memory: "
    msg = msg + Format(memory \ 1024, "###,###,###") + "K" + NewLine
    memory = memsts.dwTotalVirtual
    msg = msg + "Total Virtual Memory: "
    msg = msg + Format(memory \ 1024, "###,###,###") + "K" + NewLine
    memory = memsts.dwAvailVirtual
    msg = msg + "Available Virtual Memory: "
    msg = msg + Format(memory \ 1024, "###,###,###") + "K" + NewLine
    MsgBox msg, vbOKOnly, "System Info"
End Sub
 
Private Sub Command1_Click()
    Call SystemInformation
End Sub


traybar.

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
Declare Function Shell_NotifyIconA Lib "SHELL32" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Integer
 
Public Const NIM_ADD = 0
Public Const NIM_MODIFY = 1
Public Const NIM_DELETE = 2
Public Const NIF_MESSAGE = 1
Public Const NIF_ICON = 2
Public Const NIF_TIP = 4
 
Type NOTIFYICONDATA
    cbSize As Long
    hWnd As Long
    uID As Long
    uFlags As Long
    uCallbackMessage As Long
    hIcon As Long
    szTip As String * 64
End Type
 
Public Function SetTrayIcon(Mode As Long, hWnd As Long, Icon As Long, tip As String) As Long
    Dim nidTemp As NOTIFYICONDATA
    nidTemp.cbSize = Len(nidTemp)
    nidTemp.hWnd = hWnd
    nidTemp.uID = 0&
    nidTemp.uFlags = NIF_ICON Or NIF_TIP
    nidTemp.uCallbackMessage = 0&
    nidTemp.hIcon = Icon
    nidTemp.szTip = tip & Chr$(0)
    SetTrayIcon = Shell_NotifyIconA(Mode, nidTemp)
End Function
 
  :
Private Sub Form_Click()
SetTrayIcon NIM_MODIFY, Me.hWnd, Me.Icon, "? !"
End Sub
Private Sub Form_Load()
SetTrayIcon NIM_ADD, Me.hWnd, Me.Icon, ""
End Sub
Private Sub Form_Unload(Cancel As Integer)
SetTrayIcon NIM_DELETE, Me.hWnd, 0&, ""
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
'        ,   
'  SHELL: Shell "rundll32.exe shell32.dll,Control_RunDLL " 
'& FileName, vbNormalFocus,
' FileName -     ".CPL",    
' %windir/system%
'       ".CPL".
'      ,  -  
' .
' 2 CommandButton  1 FileListBox  .     
' .
 
Public Sub RunControlPanelExtension(FileName As String)
    Shell "rundll32.exe shell32.dll,Control_RunDLL " & FileName, vbNormalFocus
End Sub
 
Private Sub Command2_Click()
    RunControlPanelExtension File1.FileName
End Sub
 
Private Sub Command1_Click()
    Shell "rundll32.exe shell32.dll,Control_RunDLL", vbNormalFocus
End Sub
 
Private Sub Form_Load()
    File1.Pattern = "*.CPL"
    ' Windows NT  'C:\Windows\SYSTEM'  'C:\WINNT\SYSTEM32'
    File1.FileName = "C:\Windows\SYSTEM"
End Sub
 
' :
 
' 
'Call Shell("rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl @1", 5)
'   
'Call Shell("rundll32.exe shell32.dll,Control_RunDLL appwiz.cpl,,1", 5)
' 
'Call Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,0", 5)
' 
'Call Shell("rundll32.exe shell32.dll,Control_RunDLL inetcpl.cpl,,0", 5)
'
'Call Shell("rundll32.exe shell32.dll,Control_RunDLL main.cpl @1", 5)
'  
'Call Shell("rundll32.exe shell32.dll,SHHelpShortcuts_RunDLL AddPrinter", vbNormalFocus)
' 
'Call Shell("rundll32.exe shell32.dll,Control_RunDLL modem.cpl", 5)
' 
'Call Shell("rundll32.exe shell32.dll,Control_RunDLL main.cpl @0", 5)
' 
'Call Shell("rundll32.exe shell32.dll,Control_RunDLL netcpl.cpl", 5)
' ""
'Call Shell("rundll32.exe shell32.dll,Control_RunDLL password.cpl", 5)
' "  "
'Shell("rundll32.exe shell32.dll,Control_RunDLL intl.cpl,,0", 5)
' ""
'Call Shell("rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl @1", 5)
' 
'Call Shell("rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl,,0", 5)
'   
'Call Shell("rundll32.exe shell32.dll,Control_RunDLL timedate.cpl", 5)
 
' 2
'  ShellExecute.
 
Private Declare Function GetDesktopWindow Lib "user32.dll" () As Long
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
 
Const SW_SHOWNORMAL = 1
 
Function StartCPLApp(AppName As String) As Long
    Dim Scr_hDC As Long
    
    Scr_hDC = GetDesktopWindow()
    MsgBox Scr_hDC
    StartCPLApp = ShellExecute(Scr_hDC, "Open", "Control", AppName, "C:\", SW_SHOWNORMAL)
End Function
 
Private Sub Command1_Click()
    StartCPLApp "DESK.CPL"
End Sub


.

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'   2 CommandButton.       
'  ,  -   .
 
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As String, ByVal fuWinIni As Long) As Long
 
Const SPI_SETDESKWALLPAPER = 20
 
Private Sub Command1_Click()
    SystemParametersInfo SPI_SETDESKWALLPAPER, 0, "D:\Basic\tmpProj\Load.bmp", True
    '  D:\Basic\tmpProj\Load.bmp        bmp
End Sub
 
Private Sub Command2_Click()
    SystemParametersInfo SPI_SETDESKWALLPAPER, 0, 0, False
End Sub
Catstail
22514 / 10919 / 1774
: 12.02.2012
: 18,067
19.02.2013, 12:50     Visual Basic 6.0 #33

, ... , PE- exe-. (Reserved, Commited). . vb6.exe .
      Visual Basic 6.0  
 : zip SetStack.zip (9.4 , 74 )
Craw
235 / 46 / 4
: 10.06.2012
: 268
: 1
20.02.2013, 22:41     Visual Basic 6.0 #34
3D , , DirectX 8

. .
.

...
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
Option Explicit
 
'   DirectX,   ..
Dim g_DX As New DirectX8
Dim g_D3D As Direct3D8
Dim g_D3DDevice As Direct3DDevice8
Dim g_VB As Direct3DVertexBuffer8
Dim g_D3DX As New D3DX8
Dim g_Texture As Direct3DTexture8
 
'    
Private Type CUSTOMVERTEX
    Position As D3DVECTOR   '3d êîîðäè**òû âåðøè*û.
    color As Long           'Öâåò âåðøè*û.
    tu As Single            'Êîîðäè**ò* òåêñòóðû.
    tv As Single            'Êîîðäè**ò* òåêñòóðû.
End Type
 
Const D3DFVF_CUSTOMVERTEX = (D3DFVF_XYZ Or D3DFVF_DIFFUSE Or D3DFVF_TEX1)
'  
Const g_pi = 3.1415
 
Private Sub Form_Load()
'   DirectX,   
Me.Show
If Not InitD3d(Form1.hWnd) Then
   MsgBox "Íåâîçìîæ*î è*èöè*ëèçèðîâ*òü Direct3d."
   End
End If
If Not InitGeometry() Then
   MsgBox "Íåâîçìîæ*î è*èöè*ëòçèðîâ*òü áóôåð âåðøè*."
   End
End If
Timer1.Enabled = True
End Sub
 
Function InitD3d(hWnd As Long) As Boolean
On Local Error Resume Next '÷òîáû ïðè îøèáêå ïðîãð*ìì* ïðîäîëæ*ë* ð*áîò*òü ä*ëüøå
 
Set g_D3D = g_DX.Direct3DCreate() 'ïîëó÷*åì îáúåêò Direct3d
If g_D3D Is Nothing Then Exit Function  'åñëè *è÷åãî *å ïðîèñõîäèò - âûõîä èç ôó*êöèè
 
Dim Mode As D3DDISPLAYMODE
g_D3D.GetAdapterDisplayMode D3DADAPTER_DEFAULT, Mode
 
Dim d3dpp As D3DPRESENT_PARAMETERS
d3dpp.Windowed = 1
d3dpp.SwapEffect = D3DSWAPEFFECT_COPY_VSYNC
d3dpp.BackBufferFormat = Mode.Format
d3dpp.BackBufferCount = 1
d3dpp.EnableAutoDepthStencil = 1
d3dpp.AutoDepthStencilFormat = D3DFMT_D16
 
'ñîçä*¸ì  óñòðîéñòâî ðå*äåðè*ã*
Set g_D3DDevice = g_D3D.CreateDevice(D3DADAPTER_DEFAULT, D3DDEVTYPE_HAL, hWnd, _
                                     D3DCREATE_SOFTWARE_VERTEXPROCESSING, d3dpp)
If g_D3DDevice Is Nothing Then Exit Function
 
'âûêëþ÷*åì culling
g_D3DDevice.SetRenderState D3DRS_CULLMODE, D3DCULL_NONE
'âêëþ÷*åì z-áóôôåðè*ã
g_D3DDevice.SetRenderState D3DRS_ZENABLE, 1
'  3D 
g_D3DDevice.SetRenderState D3DRS_LIGHTING, 0
 
InitD3d = True 'è*èöè*ëèç*öèÿ Direct3d ïðîøë* óñïåø*î
End Function
 
Public Sub Render()
'      
Dim v As CUSTOMVERTEX
Dim sizeOfVertex As Long
 
g_D3DDevice.Clear 0, ByVal 0, D3DCLEAR_TARGET Or D3DCLEAR_ZBUFFER, &HFF&, 1, 0
 
' Í*÷*ëî ñöå*û
g_D3DDevice.BeginScene
'  
g_D3DDevice.SetTexture 0, g_Texture
g_D3DDevice.SetTextureStageState 0, D3DTSS_COLOROP, D3DTOP_MODULATE
g_D3DDevice.SetTextureStageState 0, D3DTSS_COLORARG1, D3DTA_TEXTURE
g_D3DDevice.SetTextureStageState 0, D3DTSS_COLORARG2, D3DTA_DIFFUSE
g_D3DDevice.SetTextureStageState 0, D3DTSS_ALPHAOP, D3DTOP_DISABLE
'  
SetupMatrices
 
sizeOfVertex = Len(v)
g_D3DDevice.SetStreamSource 0, g_VB, sizeOfVertex
g_D3DDevice.SetVertexShader D3DFVF_CUSTOMVERTEX
g_D3DDevice.DrawPrimitive D3DPT_TRIANGLESTRIP, 0, (4 * 25) - 2
 
' Êî*åö ñöå*û
g_D3DDevice.EndScene
'   
g_D3DDevice.Present ByVal 0, ByVal 0, 0, ByVal 0
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
CleanUp
End Sub
 
Private Sub Timer1_Timer()
'  40 ,   
Render
End Sub
 
Public Sub CleanUp()
'      
'     
Set g_D3DDevice = Nothing
Set g_D3D = Nothing
Set g_Texture = Nothing
Set g_VB = Nothing
Set g_D3DDevice = Nothing
Set g_D3D = Nothing
End Sub
 
Function InitGeometry() As Boolean
' ,    
 
'  
On Local Error Resume Next
'  
Set g_Texture = g_D3DX.CreateTextureFromFile(g_D3DDevice, App.Path + "\texture1.jpg")
If g_Texture Is Nothing Then Exit Function
 
Dim Vertices(99) As CUSTOMVERTEX
Dim VertexSizeInBytes As Long
 
VertexSizeInBytes = Len(Vertices(0))
 
Dim i As Long
Dim Theta As Single
'    DirectX - 
'    
'      ,   
'    49     
For i = 0 To 49
    Theta = (2 * g_pi * i) / (50 - 1)
    
    Vertices(2 * i + 0).Position = vec3(Sin(Theta), -1, Cos(Theta))
    Vertices(2 * i + 0).color = &HFFFFFFFF  'áåëûé.
    Vertices(2 * i + 0).tu = i / (50 - 1)
    Vertices(2 * i + 0).tv = 1
    
    Vertices(2 * i + 1).Position = vec3(Sin(Theta), 1, Cos(Theta))
    Vertices(2 * i + 1).color = &HFF808080  'ñåðûé.
    Vertices(2 * i + 1).tu = i / (50 - 1)
    Vertices(2 * i + 1).tv = 0
Next
 
Set g_VB = g_D3DDevice.CreateVertexBuffer(VertexSizeInBytes * 100, _
                 0, D3DFVF_CUSTOMVERTEX, D3DPOOL_DEFAULT)
If g_VB Is Nothing Then Exit Function
 
D3DVertexBuffer8SetData g_VB, 0, VertexSizeInBytes * 100, 0, Vertices(0)
 
InitGeometry = True
End Function
 
Function vec3(x As Single, y As Single, z As Single) As D3DVECTOR
    vec3.x = x
    vec3.y = y
    vec3.z = z
End Function
 
Public Sub SetupMatrices()
Dim matWorld As D3DMATRIX 'Ì*òðèö* Ìèð*
D3DXMatrixRotationAxis matWorld, vec3(1, 1, 1), Timer / 4
g_D3DDevice.SetTransform D3DTS_WORLD, matWorld
 
Dim matView As D3DMATRIX 'Ì*òðèö* Îáçîð*
D3DXMatrixLookAtLH matView, vec3(0, 3, -5), _
                            vec3(0, 0, 0), _
                            vec3(0, 1, 0)
                             
g_D3DDevice.SetTransform D3DTS_VIEW, matView
 
Dim matProj As D3DMATRIX 'Ì*òðèö* 
D3DXMatrixPerspectiveFovLH matProj, g_pi / 4, 1, 1, 1000
g_D3DDevice.SetTransform D3DTS_PROJECTION, matProj
 
End Sub



3D , DirectX 8

3D .. 3D Max ..
, , DirectX. .

...
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
'!
'd3dpp.AutoDepthStencilFormat = D3DFMT_D16
' D3DFMT_D16   ,
'   .
 
Option Explicit
 
Dim g_DX As New DirectX8
Dim g_D3DX As New D3DX8
Dim g_D3D As Direct3D8
Dim g_D3DDevice As Direct3DDevice8
Dim g_Mesh As D3DXMesh                  '  3d 
Dim g_MeshMaterials() As D3DMATERIAL8   '    3d 
Dim g_MeshTextures() As Direct3DTexture8 '  3d 
Dim g_NumMaterials As Long
 
Const g_pi = 3.1415
 
 
Private Sub Form_Load()
Me.Show
If Not InitD3d(Form1.hWnd) Then
   MsgBox "  Direct3d."
   End
End If
If Not InitGeometry() Then
   MsgBox "   ."
   End
End If
Timer1.Enabled = True
End Sub
 
Function InitD3d(hWnd As Long) As Boolean
On Local Error Resume Next '      
 
Set g_D3D = g_DX.Direct3DCreate() '  Direct3d
If g_D3D Is Nothing Then Exit Function  '    -   
 
Dim Mode As D3DDISPLAYMODE
g_D3D.GetAdapterDisplayMode D3DADAPTER_DEFAULT, Mode
 
Dim d3dpp As D3DPRESENT_PARAMETERS
d3dpp.Windowed = 1
d3dpp.SwapEffect = D3DSWAPEFFECT_COPY_VSYNC
d3dpp.BackBufferFormat = Mode.Format
d3dpp.BackBufferCount = 1
d3dpp.EnableAutoDepthStencil = 1
d3dpp.AutoDepthStencilFormat = D3DFMT_D16
 
'   
Set g_D3DDevice = g_D3D.CreateDevice(D3DADAPTER_DEFAULT, D3DDEVTYPE_HAL, hWnd, _
                                     D3DCREATE_SOFTWARE_VERTEXPROCESSING, d3dpp)
If g_D3DDevice Is Nothing Then Exit Function
 
' culling
g_D3DDevice.SetRenderState D3DRS_CULLMODE, D3DCULL_NONE
' z-
g_D3DDevice.SetRenderState D3DRS_ZENABLE, 1
' 3d 
g_D3DDevice.SetRenderState D3DRS_LIGHTING, 0
 
InitD3d = True ' Direct3d  
End Function
 
Public Sub Render()
Dim i As Long
 
g_D3DDevice.Clear 0, ByVal 0, D3DCLEAR_TARGET Or D3DCLEAR_ZBUFFER, &HFF&, 1, 0
 
'  
g_D3DDevice.BeginScene
 
SetupMatrices
 
' 3d     (subsets).
'       .
'  3d     :
For i = 0 To g_NumMaterials - 1
    '       
    g_D3DDevice.SetMaterial g_MeshMaterials(i)
    g_D3DDevice.SetTexture 0, g_MeshTextures(i)
    '   3d 
    g_Mesh.DrawSubset i
Next
 
'  
g_D3DDevice.EndScene
 
g_D3DDevice.Present ByVal 0, ByVal 0, 0, ByVal 0
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
Cleanup
End Sub
 
Private Sub Timer1_Timer()
Render
End Sub
 
Sub Cleanup()
    Erase g_MeshTextures
    Erase g_MeshMaterials
    
    Set g_Mesh = Nothing
    Set g_D3DDevice = Nothing
    Set g_D3D = Nothing
End Sub
 
Function InitGeometry() As Boolean
On Local Error Resume Next
 
Dim MtrlBuffer As D3DXBuffer
Dim i As Long
 
Set g_Mesh = g_D3DX.LoadMeshFromX(App.Path + "\Tiger.x", D3DXMESH_MANAGED, _
                               g_D3DDevice, Nothing, MtrlBuffer, g_NumMaterials)
If g_Mesh Is Nothing Then Exit Function
 
ReDim g_MeshMaterials(g_NumMaterials)
ReDim g_MeshTextures(g_NumMaterials)
 
Dim strTexName As String
 
For i = 0 To g_NumMaterials - 1
    '     MtrlBuffer   g_MeshMaterials
    g_D3DX.BufferGetMaterial MtrlBuffer, i, g_MeshMaterials(i)
 
    '     (D3DX   )
    g_MeshMaterials(i).Ambient = g_MeshMaterials(i).diffuse
     
    '  
    strTexName = g_D3DX.BufferGetTextureName(MtrlBuffer, i)
    If strTexName <> "" Then
        Set g_MeshTextures(i) = g_D3DX.CreateTextureFromFile(g_D3DDevice, App.Path + "\" + strTexName)
    End If
Next
 
Set MtrlBuffer = Nothing
 
InitGeometry = True
End Function
Function vec3(x As Single, y As Single, z As Single) As D3DVECTOR
    vec3.x = x
    vec3.y = y
    vec3.z = z
End Function
 
Public Sub SetupMatrices()
Dim matWorld As D3DMATRIX ' 
D3DXMatrixRotationY matWorld, Timer / 4
g_D3DDevice.SetTransform D3DTS_WORLD, matWorld
 
Dim matView As D3DMATRIX ' 
D3DXMatrixLookAtLH matView, vec3(0, 3, -3), _
                            vec3(0, 0, 0), _
                            vec3(0, 1, 0)
                             
g_D3DDevice.SetTransform D3DTS_VIEW, matView
 
Dim matProj As D3DMATRIX ' 
D3DXMatrixPerspectiveFovLH matProj, g_pi / 4, 1, 1, 1000
g_D3DDevice.SetTransform D3DTS_PROJECTION, matProj
 
End Sub


3D , , DirectX 8

, .

frmD3D
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Option Explicit
 
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
  Keyb(KeyCode) = True
End Sub
 
Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
  Keyb(KeyCode) = False
End Sub
 
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
  If Running Then Cancel = 1: Running = False
End Sub
 
Private Sub TimerFPS_Timer()
  Me.Caption = FPS
  FPS = 0
End Sub

modAPI
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
Option Explicit
 
Public Type POINTAPI
  x As Long
  y As Long
End Type
 
Public Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long
Public Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
 
Public Type int64
  dw1 As Long
  dw2 As Long
End Type
 
Public Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As int64) As Long
Public Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As int64) As Long
Dim QSpeed As Double
 
Public Function QTime() As Double
Dim QD As int64, t As Double
  QueryPerformanceCounter QD
  If QD.dw1 < 0& Then t = QD.dw1 + 4294967296# Else t = QD.dw1
  If QD.dw2 < 0& Then t = t + (QD.dw2 + 4294967296#) * 4294967296# Else t = t + QD.dw2 * 4294967296#
  QTime = t * QSpeed
End Function
 
Public Sub QFreqIni()
Dim QD As int64
  QueryPerformanceFrequency QD
  If QD.dw1 < 0& Then QSpeed = QD.dw1 + 4294967296# Else QSpeed = QD.dw1
  If QD.dw2 < 0& Then QSpeed = QSpeed + (QD.dw2 + 4294967296#) * 4294967296# Else QSpeed = QSpeed + QD.dw2 * 4294967296#
  QSpeed = 1# / QSpeed
End Sub

modeControl
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
Option Explicit
 
Public Keyb(255) As Boolean
Public MouseSpeedX As Single
Public MouseSpeedY As Single
Public KeybSpeed As Single
Dim OldTime As Single
Dim Center As POINTAPI
 
Public Sub ControlInit()
Dim n As Long
  For n = 0 To 255
    Keyb(n) = False
  Next n
  OldTime = QTime
  'Center.x = Screen.Width \ Screen.TwipsPerPixelX \ 2
  'Center.y = Screen.Height \ Screen.TwipsPerPixelY \ 2
  'SetCursorPos Center.x, Center.y
End Sub
 
Public Sub DoControl()
Dim mPos As POINTAPI, t As Single
Dim dx As Single, dy As Single, dk As Single
  t = QTime
  dk = (t - OldTime) * KeybSpeed
  OldTime = t
 
 ' GetCursorPos mPos
 ' SetCursorPos Center.x, Center.y
  dx = (mPos.x - Center.x) * MouseSpeedX
  dy = (mPos.y - Center.y) * MouseSpeedY
  CameraAngle = CameraAngle + dx
  If CameraAngle < 0 Then CameraAngle = CameraAngle + 2 * Pi
  If CameraAngle > 2 * Pi Then CameraAngle = CameraAngle - 2 * Pi
  CameraDiff = CameraDiff + dy
  If CameraDiff < -0.5 * Pi Then CameraDiff = -0.5 * Pi
  If CameraDiff > 0.5 * Pi Then CameraDiff = 0.5 * Pi
 
  If Keyb(vbKeyLeft) Then
    CameraPos.x = CameraPos.x - Cos(CameraAngle) * dk
    CameraPos.z = CameraPos.z - Sin(CameraAngle) * dk
  End If
  If Keyb(vbKeyRight) Then
    CameraPos.x = CameraPos.x + Cos(CameraAngle) * dk
    CameraPos.z = CameraPos.z + Sin(CameraAngle) * dk
  End If
  If Keyb(vbKeyUp) Then
    CameraPos.x = CameraPos.x - Sin(CameraAngle) * dk
    CameraPos.z = CameraPos.z + Cos(CameraAngle) * dk
  End If
  If Keyb(vbKeyDown) Then
    CameraPos.x = CameraPos.x + Sin(CameraAngle) * dk
    CameraPos.z = CameraPos.z - Cos(CameraAngle) * dk
  End If
  If Keyb(vbKeyA) Then
    SunAngle = SunAngle - dk
    If SunAngle < 0 Then SunAngle = SunAngle + 2 * Pi
  End If
  If Keyb(vbKeyD) Then
    SunAngle = SunAngle + dk
    If SunAngle > 2 * Pi Then SunAngle = SunAngle - 2 * Pi
  End If
  If Keyb(vbKeyW) Then
    SunDiff = SunDiff + dk
    If SunDiff > 0.5 * Pi Then SunDiff = 0.5 * Pi
  End If
  If Keyb(vbKeyS) Then
    SunDiff = SunDiff - dk
    If SunDiff < 0 Then SunDiff = 0
  End If
End Sub

modDX
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
Option Explicit
 
Public Enum TexF
  TexF_None
  TexF_BiLinear
  TexF_TriLinear
  TexF_Anisotropic
End Enum
 
Public dx8 As New DirectX8
Public d3d As Direct3D8
Public d3dx As New D3DX8
Public d3dDevice As Direct3DDevice8
Public Caps As D3DCAPS8
Public Const Pi = 3.141593
 
Public Sub TexFilter(Stage As Long, TF As TexF, Optional MaxAnisotropy As Long = 2)
  Select Case TF
    Case TexF_None
      d3dDevice.SetTextureStageState Stage, D3DTSS_MIPFILTER, D3DTEXF_NONE
      d3dDevice.SetTextureStageState Stage, D3DTSS_MAGFILTER, D3DTEXF_NONE
      d3dDevice.SetTextureStageState Stage, D3DTSS_MINFILTER, D3DTEXF_NONE
    Case TexF_BiLinear
      d3dDevice.SetTextureStageState Stage, D3DTSS_MIPFILTER, D3DTEXF_POINT
      d3dDevice.SetTextureStageState Stage, D3DTSS_MAGFILTER, D3DTEXF_LINEAR
      d3dDevice.SetTextureStageState Stage, D3DTSS_MINFILTER, D3DTEXF_LINEAR
    Case TexF_TriLinear
      d3dDevice.SetTextureStageState Stage, D3DTSS_MIPFILTER, D3DTEXF_LINEAR
      d3dDevice.SetTextureStageState Stage, D3DTSS_MAGFILTER, D3DTEXF_LINEAR
      d3dDevice.SetTextureStageState Stage, D3DTSS_MINFILTER, D3DTEXF_LINEAR
    Case TexF_Anisotropic
      d3dDevice.SetTextureStageState Stage, D3DTSS_MIPFILTER, D3DTEXF_LINEAR
      d3dDevice.SetTextureStageState Stage, D3DTSS_MAGFILTER, D3DTEXF_LINEAR
      If Caps.MaxAnisotropy >= MaxAnisotropy Then
        d3dDevice.SetTextureStageState Stage, D3DTSS_MINFILTER, D3DTEXF_ANISOTROPIC
        d3dDevice.SetTextureStageState Stage, D3DTSS_MAXANISOTROPY, MaxAnisotropy
      ElseIf Caps.MaxAnisotropy >= 2 Then
        d3dDevice.SetTextureStageState Stage, D3DTSS_MINFILTER, D3DTEXF_ANISOTROPIC
        d3dDevice.SetTextureStageState Stage, D3DTSS_MAXANISOTROPY, Caps.MaxAnisotropy
      Else
        d3dDevice.SetTextureStageState Stage, D3DTSS_MINFILTER, D3DTEXF_LINEAR
      End If
  End Select
End Sub
 
Public Sub D3DInit(hWnd As Long)
Dim DispMode As D3DDISPLAYMODE
Dim d3dpp As D3DPRESENT_PARAMETERS
 
  Set d3d = dx8.Direct3DCreate
  d3d.GetDeviceCaps D3DADAPTER_DEFAULT, D3DDEVTYPE_HAL, Caps
  d3d.GetAdapterDisplayMode D3DADAPTER_DEFAULT, DispMode
 
  d3dpp.Windowed = True
  d3dpp.SwapEffect = D3DSWAPEFFECT_DISCARD
  d3dpp.BackBufferFormat = DispMode.Format
  d3dpp.BackBufferCount = 1
  d3dpp.EnableAutoDepthStencil = True
  d3dpp.AutoDepthStencilFormat = D3DFMT_D16
 
  Set d3dDevice = d3d.CreateDevice(D3DADAPTER_DEFAULT, D3DDEVTYPE_HAL, hWnd, D3DCREATE_SOFTWARE_VERTEXPROCESSING, d3dpp)
End Sub
 
Public Sub D3DTerminate()
  Set d3dx = Nothing
  Set d3dDevice = Nothing
  Set d3d = Nothing
  Set dx8 = Nothing
End Sub
 
Public Function vec3(x As Single, y As Single, z As Single) As D3DVECTOR
  vec3.x = x
  vec3.y = y
  vec3.z = z
End Function
 
Public Function vec2(x As Single, y As Single) As D3DVECTOR2
  vec2.x = x
  vec2.y = y
End Function

modMain
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
Option Explicit
 
Private Type vFormat
  Pos As D3DVECTOR
  Normal As D3DVECTOR
  tu0 As Single
  tv0 As Single
End Type
 
Public Running As Boolean
Public FPS As Long
Public CameraPos As D3DVECTOR
Public CameraAngle As Single
Public CameraDiff As Single
Public SunAngle As Single
Public SunDiff As Single
Dim Light As D3DLIGHT8
Dim Mesh As D3DXMesh
Dim Tex0 As Direct3DTexture8
Dim Tex1 As Direct3DTexture8
 
Public Sub Main()
Dim Mtrx As D3DMATRIX
  frmD3D.Show
  QFreqIni
  D3DInit frmD3D.hWnd
  ControlInit
  InitMatrix
  InitMesh
  Setting
  InitLight
  InitMaterial
  CameraPos = vec3(0, 0, -3)
  CameraAngle = 0
  CameraDiff = 0
  SunAngle = 0
  SunDiff = Pi / 4
  MouseSpeedX = -0.002
  MouseSpeedY = -0.002
  KeybSpeed = 2
  Running = True
'  ShowCursor 0
  Do While Running
    DoEvents
    DoControl
    CameraSet
    Render
    FPS = FPS + 1
  Loop
'  ShowCursor 1
  ClearAll
  Unload frmD3D
End Sub
 
Private Sub Setting()
  Set Tex0 = d3dx.CreateTextureFromFile(d3dDevice, "BrickDot.tga")
  d3dDevice.SetTexture 0, Tex0
  TexFilter 0, TexF_TriLinear
  Set Tex1 = d3dx.CreateTextureFromFile(d3dDevice, "dot.tga")
  d3dDevice.SetTexture 1, Tex1
  TexFilter 1, TexF_TriLinear
 
  d3dDevice.SetTextureStageState 0, D3DTSS_COLOROP, D3DTOP_SELECTARG1
  d3dDevice.SetTextureStageState 0, D3DTSS_COLORARG1, D3DTA_TEXTURE
 
  d3dDevice.SetTextureStageState 1, D3DTSS_COLOROP, D3DTOP_DOTPRODUCT3
  d3dDevice.SetTextureStageState 1, D3DTSS_COLORARG1, D3DTA_TEXTURE
  d3dDevice.SetTextureStageState 1, D3DTSS_COLORARG2, D3DTA_CURRENT
  d3dDevice.SetTextureStageState 1, D3DTSS_TEXCOORDINDEX, D3DTSS_TCI_CAMERASPACENORMAL
  d3dDevice.SetTextureStageState 1, D3DTSS_TEXTURETRANSFORMFLAGS, D3DTTFF_COUNT2
 
  d3dDevice.SetTextureStageState 2, D3DTSS_COLOROP, D3DTOP_MODULATE2X
  d3dDevice.SetTextureStageState 2, D3DTSS_COLORARG1, D3DTA_DIFFUSE
  d3dDevice.SetTextureStageState 2, D3DTSS_COLORARG2, D3DTA_CURRENT
 
  d3dDevice.SetRenderState D3DRS_LIGHTING, 1
  d3dDevice.SetRenderState D3DRS_ZENABLE, D3DZB_TRUE
End Sub
 
Private Sub CameraSet()
Dim Mtrx As D3DMATRIX, v As D3DVECTOR
  D3DXMatrixRotationX Mtrx, CameraDiff
  d3dDevice.SetTransform D3DTS_VIEW, Mtrx
  D3DXMatrixRotationY Mtrx, CameraAngle
  d3dDevice.MultiplyTransform D3DTS_VIEW, Mtrx
  D3DXMatrixTranslation Mtrx, -CameraPos.x, -CameraPos.y, -CameraPos.z
  d3dDevice.MultiplyTransform D3DTS_VIEW, Mtrx
 
  D3DXMatrixTranslation Mtrx, 0.5, 0.5, 0
  d3dDevice.SetTransform D3DTS_TEXTURE1, Mtrx
  D3DXMatrixScaling Mtrx, 0.5, 0.5, 1
  d3dDevice.MultiplyTransform D3DTS_TEXTURE1, Mtrx
  D3DXMatrixRotationX Mtrx, SunDiff - CameraDiff
  d3dDevice.MultiplyTransform D3DTS_TEXTURE1, Mtrx
  D3DXMatrixRotationY Mtrx, SunAngle - CameraAngle
  d3dDevice.MultiplyTransform D3DTS_TEXTURE1, Mtrx
 
  D3DXMatrixRotationX Mtrx, -SunDiff
  D3DXVec3TransformCoord v, vec3(0, 0, 1), Mtrx
  D3DXMatrixRotationY Mtrx, -SunAngle
  D3DXVec3TransformCoord v, v, Mtrx
  Light.Direction = v
  d3dDevice.SetLight 0, Light
End Sub
 
Private Sub InitLight()
  Light.Type = D3DLIGHT_DIRECTIONAL
  Light.diffuse.r = 0.7
  Light.diffuse.g = 0.7
  Light.diffuse.b = 0.7
  d3dDevice.LightEnable 0, 1
End Sub
 
Private Sub InitMaterial()
Dim Mat As D3DMATERIAL8
  Mat.diffuse.r = 1
  Mat.diffuse.g = 1
  Mat.diffuse.b = 1
  d3dDevice.SetMaterial Mat
End Sub
 
Private Sub Render()
  d3dDevice.Clear 0, ByVal 0, D3DCLEAR_TARGET Or D3DCLEAR_ZBUFFER, &H345599, 1, 0
  d3dDevice.BeginScene
 
  Mesh.DrawSubset 0
 
  d3dDevice.EndScene
  d3dDevice.Present ByVal 0, ByVal 0, 0, ByVal 0
End Sub
 
Private Sub InitMesh()
Dim vBuf As Direct3DVertexBuffer8, iBuf As Direct3DIndexBuffer8
Dim n As Long, Vert() As vFormat, Ind() As Integer
  Set Mesh = d3dx.CreateMeshFVF(128, 130, 0, D3DFVF_XYZ Or D3DFVF_NORMAL Or D3DFVF_TEX1, d3dDevice)
  
  Set vBuf = Mesh.GetVertexBuffer
  ReDim Vert(129)
  For n = 0 To 128 Step 2
    Vert(n + 0).Pos = vec3(Sin(2 * Pi * n / 128), 0.7, Cos(2 * Pi * n / 128))
    Vert(n + 0).Normal = vec3(Sin(2 * Pi * n / 128), 0, Cos(2 * Pi * n / 128))
    Vert(n + 0).tv0 = 0
    Vert(n + 0).tu0 = -n * 4 / 128
    Vert(n + 1).Pos = vec3(Sin(2 * Pi * n / 128), -0.7, Cos(2 * Pi * n / 128))
    Vert(n + 1).Normal = vec3(Sin(2 * Pi * n / 128), 0, Cos(2 * Pi * n / 128))
    Vert(n + 1).tv0 = 1
    Vert(n + 1).tu0 = -n * 4 / 128
  Next n
  D3DVertexBuffer8SetData vBuf, 0, 130 * Len(Vert(0)), 0, Vert(0)
  Set vBuf = Nothing
 
  Set iBuf = Mesh.GetIndexBuffer
  ReDim Ind(3 * 128 - 1)
  For n = 0 To 63
    Ind(n * 6 + 0) = n * 2 + 0
    Ind(n * 6 + 1) = n * 2 + 1
    Ind(n * 6 + 2) = n * 2 + 3
    Ind(n * 6 + 3) = n * 2 + 0
    Ind(n * 6 + 4) = n * 2 + 3
    Ind(n * 6 + 5) = n * 2 + 2
  Next n
  D3DIndexBuffer8SetData iBuf, 0, 3 * 128 * Len(Ind(0)), 0, Ind(0)
  Set iBuf = Nothing
End Sub
 
Private Sub InitMatrix()
Dim Mtrx As D3DMATRIX
  D3DXMatrixIdentity Mtrx
  d3dDevice.SetTransform D3DTS_WORLD, Mtrx
 
  D3DXMatrixPerspectiveFovLH Mtrx, Pi / 4, frmD3D.ScaleHeight / frmD3D.ScaleWidth, 0.1, 100
  d3dDevice.SetTransform D3DTS_PROJECTION, Mtrx
End Sub
 
Private Sub ClearAll()
  Set Mesh = Nothing
  Set Tex0 = Nothing
  Set Tex1 = Nothing
  D3DTerminate
End Sub
 : zip 1.zip (397.7 , 102 )
 : zip 2.zip (21.3 , 73 )
 : zip 3.zip (432.6 , 88 )
Dragokas
 Windows FAQ
15772 / 6620 / 796
: 25.12.2011
: 10,238
: 16
23.02.2013, 17:24  []     Visual Basic 6.0 #35
.INI
VBScript ( VB6)

: Keith Lacelle
: Denis St-Pierre, Johan Pol, Rob van der Woude

ReadIni
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
Function ReadIni( myFilePath, mySection, myKey )
     ' This function returns a value read from an INI file
     '
     ' Arguments:
     ' myFilePath  [string]  the (path and) file name of the INI file
     ' mySection   [string]  the section in the INI file to be searched
     ' myKey       [string]  the key whose value is to be returned
     '
     ' Returns:
     ' the [string] value for the specified key in the specified section
     '
     ' CAVEAT:     Will return a space if key exists but value is blank
     '
     ' Written by Keith Lacelle
     ' Modified by Denis St-Pierre and Rob van der Woude
 
     Const ForReading   = 1
     Const ForWriting   = 2
     Const ForAppending = 8
 
     Dim intEqualPos
     Dim objFSO, objIniFile
     Dim strFilePath, strKey, strLeftString, strLine, strSection
 
     Set objFSO = CreateObject( "Scripting.FileSystemObject" )
 
     ReadIni     = ""
     strFilePath = Trim( myFilePath )
     strSection  = Trim( mySection )
     strKey      = Trim( myKey )
 
     If objFSO.FileExists( strFilePath ) Then
         Set objIniFile = objFSO.OpenTextFile( strFilePath, ForReading, False )
         Do While objIniFile.AtEndOfStream = False
             strLine = Trim( objIniFile.ReadLine )
 
             ' Check if section is found in the current line
             If LCase( strLine ) = "[" & LCase( strSection ) & "]" Then
                 strLine = Trim( objIniFile.ReadLine )
 
                 ' Parse lines until the next section is reached
                 Do While Left( strLine, 1 ) <> "["
                     ' Find position of equal sign in the line
                     intEqualPos = InStr( 1, strLine, "=", 1 )
                     If intEqualPos > 0 Then
                         strLeftString = Trim( Left( strLine, intEqualPos - 1 ) )
                         ' Check if item is found in the current line
                         If LCase( strLeftString ) = LCase( strKey ) Then
                             ReadIni = Trim( Mid( strLine, intEqualPos + 1 ) )
                             ' In case the item exists but value is blank
                             If ReadIni = "" Then
                                 ReadIni = " "
                             End If
                             ' Abort loop when item is found
                             Exit Do
                         End If
                     End If
 
                     ' Abort if the end of the INI file is reached
                     If objIniFile.AtEndOfStream Then Exit Do
 
                     ' Continue with next line
                     strLine = Trim( objIniFile.ReadLine )
                 Loop
             Exit Do
             End If
         Loop
         objIniFile.Close
     Else
         msgbox strFilePath & " doesn't exists. Exiting..."
         exit function
     End If
 End Function


WriteIni
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
Sub WriteIni( myFilePath, mySection, myKey, myValue )
     ' This subroutine writes a value to an INI file
     '
     ' Arguments:
     ' myFilePath  [string]  the (path and) file name of the INI file
     ' mySection   [string]  the section in the INI file to be searched
     ' myKey       [string]  the key whose value is to be written
     ' myValue     [string]  the value to be written (myKey will be
     '                       deleted if myValue is <DELETE_THIS_VALUE>)
     '
     ' Returns:
     ' N/A
     '
     ' CAVEAT:     WriteIni function needs ReadIni function to run
     '
     ' Written by Keith Lacelle
     ' Modified by Denis St-Pierre, Johan Pol and Rob van der Woude
 
     Const ForReading   = 1
     Const ForWriting   = 2
     Const ForAppending = 8
 
     Dim blnInSection, blnKeyExists, blnSectionExists, blnWritten
     Dim intEqualPos
     Dim objFSO, objNewIni, objOrgIni, wshShell
     Dim strFilePath, strFolderPath, strKey, strLeftString
     Dim strLine, strSection, strTempDir, strTempFile, strValue
 
     strFilePath = Trim( myFilePath )
     strSection  = Trim( mySection )
     strKey      = Trim( myKey )
     strValue    = Trim( myValue )
 
     Set objFSO   = CreateObject( "Scripting.FileSystemObject" )
     Set wshShell = CreateObject( "WScript.Shell" )
 
     strTempDir  = wshShell.ExpandEnvironmentStrings( "%TEMP%" )
     strTempFile = objFSO.BuildPath( strTempDir, objFSO.GetTempName )
 
     Set objOrgIni = objFSO.OpenTextFile( strFilePath, ForReading, True )
     Set objNewIni = objFSO.CreateTextFile( strTempFile, False, False )
 
     blnInSection     = False
     blnSectionExists = False
     ' Check if the specified key already exists
     blnKeyExists     = ( ReadIni( strFilePath, strSection, strKey ) <> "" )
     blnWritten       = False
 
     ' Check if path to INI file exists, quit if not
     strFolderPath = Mid( strFilePath, 1, InStrRev( strFilePath, "\" ) )
     If Not objFSO.FolderExists ( strFolderPath ) Then
         msgbox "Error: WriteIni failed, folder path (" _
                    & strFolderPath & ") to ini file " _
                    & strFilePath & " not found!"
         Set objOrgIni = Nothing
         Set objNewIni = Nothing
         Set objFSO    = Nothing
         exit function
     End If
 
     While objOrgIni.AtEndOfStream = False
         strLine = Trim( objOrgIni.ReadLine )
         If blnWritten = False Then
             If LCase( strLine ) = "[" & LCase( strSection ) & "]" Then
                 blnSectionExists = True
                 blnInSection = True
             ElseIf InStr( strLine, "[" ) = 1 Then
                 blnInSection = False
             End If
         End If
 
         If blnInSection Then
             If blnKeyExists Then
                 intEqualPos = InStr( 1, strLine, "=", vbTextCompare )
                 If intEqualPos > 0 Then
                     strLeftString = Trim( Left( strLine, intEqualPos - 1 ) )
                     If LCase( strLeftString ) = LCase( strKey ) Then
                         ' Only write the key if the value isn't empty
                         ' Modification by Johan Pol
                         If strValue <> "<DELETE_THIS_VALUE>" Then
                             objNewIni.WriteLine strKey & "=" & strValue
                         End If
                         blnWritten   = True
                         blnInSection = False
                     End If
                 End If
                 If Not blnWritten Then
                     objNewIni.WriteLine strLine
                 End If
             Else
                 objNewIni.WriteLine strLine
                     ' Only write the key if the value isn't empty
                     ' Modification by Johan Pol
                     If strValue <> "<DELETE_THIS_VALUE>" Then
                         objNewIni.WriteLine strKey & "=" & strValue
                     End If
                 blnWritten   = True
                 blnInSection = False
             End If
         Else
             objNewIni.WriteLine strLine
         End If
     Wend
 
     If blnSectionExists = False Then ' section doesn't exist
         objNewIni.WriteLine
         objNewIni.WriteLine "[" & strSection & "]"
             ' Only write the key if the value isn't empty
             ' Modification by Johan Pol
             If strValue <> "<DELETE_THIS_VALUE>" Then
                 objNewIni.WriteLine strKey & "=" & strValue
             End If
     End If
 
     objOrgIni.Close
     objNewIni.Close
 
     ' Delete old INI file
     objFSO.DeleteFile strFilePath, True
     ' Rename new INI file
     objFSO.MoveFile strTempFile, strFilePath
 
     Set objOrgIni = Nothing
     Set objNewIni = Nothing
     Set objFSO    = Nothing
     Set wshShell  = Nothing
 End Sub


:
Visual Basic
1
2
3
4
5
WriteIni "C:\test.ini", "TEST1", "My1stKey", "My1stValue"
WriteIni "C:\test.ini", "TEST2", "My1stKey", "My1stValue"
msgbox ReadIni( "C:\test.ini", "TEST1", "My1stKey" )
WriteIni "C:\test.ini", "TEST1", "My1stKey", "My2ndValue"
msgbox ReadIni( "C:\test.ini", "TEST1", "My1stKey" )
, <DELETE_THIS_VALUE>:
Visual Basic
WriteIni "C:\test.ini", "TEST1", "My1stKey", "<DELETE_THIS_VALUE>"
dev.Free
24.02.2013, 19:08     Visual Basic 6.0 #36
.INI :

:

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" _
        (ByVal lpapplicationname As String, ByVal lpkeyname As Any, ByVal lpdefault As String, _
        ByVal lpreturnedstring As String, ByVal nSize As Long, ByVal lpfilename As String) As Long
Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" _
        (ByVal lpapplicationname As Any, ByVal lpkeyname As Any, _
        ByVal lpstring As Any, ByVal lpfilename As String) As Long
Public Sub writeINI(sINIFile As String, sSection As String, sKey As String, sValue As String)
    Dim n As Integer
    Dim sTemp  As String
    sTemp = sValue
    For n = 1 To Len(sValue)
        If Mid$(sValue, n, 1) = vbCr Or Mid$(sValue, n, 1) = vbLf Then Mid$(sValue, n) = " "
    Next n
    n = WritePrivateProfileString(sSection, sKey, sTemp, sINIFile)
End Sub
Public Function sGetINI(sINIFile As String, sSection As String, sKey As String, sdefault As String)
    Dim sTemp  As String * 256
    Dim nLength As Integer
    sTemp = Space$(256)
    nLength = GetPrivateProfileString(sSection, sKey, sdefault, sTemp, 255, sINIFile)
    sGetINI = Left$(sTemp, nLength)
End Function


:

Visual Basic
1
2
3
4
5
6
7
Private Sub cmdGet_Click()
txtValue = sGetINI(App.Path & "\test.ini", "TestSection", "TestKey", "None")
End Sub
 
Private Sub cmdWrite_Click()
writeINI App.Path & "\test.ini", "TestSection", "TestKey", txtValue
End Sub
Pro_grammer
5927 / 2087 / 399
: 24.04.2011
: 3,543
: 10
12.03.2013, 07:22     Visual Basic 6.0 #37
3D , .

VB6 - (Mathias Kunter).

REVO TRON v 1.4
http://revotron.tripod.com
Copyright by Mathias Kunter. Mail: mathiaskunter@yahoo.de

*************************LEGAL STUFF*************************
REVO TRON is copyrighted by Mathias Kunter, but it's freeware and
open source. This means you're free to copy and edit the game and give
it to other people. You use this game at your own risk, and the game
programmer isn't responsible for any damages on software or hardware
which may occur when playing REVO TRON.
When starting REVO TRON, you agree to these conditions automatically.


. : http://revotron.tripod.com
      Visual Basic 6.0  
 : zip 3DTron.zip (789.7 , 225 )
19.04.2013, 10:50     Visual Basic 6.0 #38
( Test.txt )
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
Option Explicit
 
Sub main()
Dim s As String
Dim a
Dim v
Dim n() As Long
Dim i As Long, j As Long, k As Long
Dim b() As Long
Dim p As Long
Open App.Path & "\Test.txt" For Input As 1
  s = Input$(LOF(1), 1)
Close
a = Split(s, vbCrLf & vbCrLf)
ReDim n(UBound(a))
Randomize
For i = 0 To UBound(n)
  j = Int(Rnd * (i + 1))
  n(i) = n(j)
  n(j) = i
Next i
For i = 0 To UBound(n)
  v = Split(a(n(i)), vbCrLf)
  s = v(0)
  ReDim b(1 To UBound(v))
  For k = 1 To UBound(b)
    j = Int(Rnd * k + 1)
    b(k) = b(j)
    b(j) = k
  Next k
  For k = 1 To UBound(b)
    s = s & vbCrLf & vbCrLf & k & ":  " & v(b(k))
  Next k
  Do
    j = Val(InputBox(s, "   "))
    If j < 1 Or j > UBound(b) Then
      If MsgBox(" - []" & vbCrLf & " - []", vbYesNo, "  !") <> vbYes Then Exit Sub
    Else
      Exit Do
    End If
  Loop
  p = p - (b(j) = 1)
Next i
MsgBox "  " & p & "    " & i
End Sub
      Visual Basic 6.0  
 : zip test.zip (2.9 , 153 )
The trick
6938 / 2402 / 741
: 22.02.2013
: 3,457
: 74
23.04.2013, 21:55     Visual Basic 6.0 #39
, .
      Visual Basic 6.0  
 : rar TrickTest.rar (43.6 , 248 )
MoreAnswers
37091 / 29110 / 5898
: 17.06.2006
: 43,301
24.09.2013, 00:08     Visual Basic 6.0
:
Visual Basic Visual Studio 2010 Visual Basic?
Visual Basic Visual Studio Visual Basic
Visual Basic
Visual Basic Visual Basic Visual studio
Visual Basic Visual Basic



:
Dragokas
 Windows FAQ
15772 / 6620 / 796
: 25.12.2011
: 10,238
: 16
24.09.2013, 00:08  []     Visual Basic 6.0 #40
API Viewer

http://www.activevb.de/rubriken/apiv...g.html#anchor2
Yandex
24.09.2013, 00:08     Visual Basic 6.0

- , ,
-
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2017, vBulletin Solutions, Inc.
@Mail.ru