,   CyberForum.ru

Visual Basic


 
 
:  :  - 2,   - 5.00
Dragokas
 Windows FAQ
15780 / 6628 / 799
: 25.12.2011
: 10,255
: 16
#1

Visual Basic 6.0 - Visual Basic

19.11.2012, 00:34. 167992. 202
( )

( ).

inv.DS ( ), , , , ( - ).

, ,
.

, .
.
, , -
:
  • . - [B][COLOR="Blue"].[/COLOR][/B]
  • , > 4 , - [SPOILER=" ..."][VB] [/VB][/SPOILER]
  • - .
  • (, ...).
  • , , .
  • , .
  • , .
  • :
    1) -
    2) , ,
    ( "Permalink" ).
  • :
    1) - .
    2) .
    ( , - "").
-

: [url="http://www.cyberforum.ru/visual-basic/thread707863.html"] ( )[/url]
:
: VBS


******************* : *******************


+ +

1-
2-
3- ComboBox
4- (Style) CheckBox OptionButton
5- 3
6- .
7- ( )
8-
9-
10- AVI- PictureBox-.
11- Excel. .
12- , , ..
13- ?
14- 3D-
15-
16- (.)
17- , .
18- ListView.
19- E-Mail
20-
21- SQL Server ( )
22-
23-
24- "X"
25- INI
27-
28- .MP3
29- Web-, WinInet API
31- - API
32- (?)
33- ""
34- Microsoft Access
35- API
36-
37- TreeView
38- " 2"
39- API
40-
41- - MD5
42- Label
43- "Doom"
44- ,
45- IP-
46-
47- ,
.TXT .RTF () .
VB6
E-Mail Visual Basic 6.0
1 ?
2 ?
?
?

HEX .


, .
, .
, .
.
dev.Free
21.11.2012, 13:58     Visual Basic 6.0 #2
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
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
    Option Explicit  
      
    Private Const MONITOR_ON = -1&  
    Private Const MONITOR_LOWPOWER = 1&  
    Private Const MONITOR_OFF = 2&  
    Private Const SC_MONITORPOWER = &HF170&  
    Private Const WM_SYSCOMMAND = &H112  
      
    Private Declare Function SendMessage Lib "user32" _  
    Alias "SendMessageA" _  
    (ByVal hWnd As Long, _  
    ByVal wMsg As Long, _  
    ByVal wParam As Long, _  
    lParam As Any) As Long  
 
    Private Sub Form_Load()  
      
    Command1.Caption = "Turn off monitors"  
      
    End Sub  
      
      
    Private Sub Command1_Click()  
      
    'shut monitor(s) off, and enable  
    'a timer that will turn them on again  
    'after 5 seconds (just in case!)  
    Call SendMessage(Me.hWnd, WM_SYSCOMMAND, SC_MONITORPOWER, ByVal MONITOR_OFF)  
      
    With Timer1  
    .Interval = 5000  
    .Enabled = True  
    End With  
      
    End Sub  
      
      
    Private Sub Timer1_Timer()  
      
    Timer1.Enabled = False  
      
    'turn monitor on  
    Call SendMessage(Me.hWnd, WM_SYSCOMMAND, SC_MONITORPOWER, ByVal MONITOR_ON)  
      
    End Sub


2-

...

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
    'nasGetCharCount(strText, strFindChar)   
    ' strText - ,    ;   
    'strFindChar -     
    Public Function nasGetCharCount( _   
        ByVal strText As String, _   
        Optional strFindChar As String = " ") _   
        As Long   
     Dim gccArray() As String   
     If strText = vbNullString Then   
      nasGetCharCount = 0: Exit Function   
     End If   
     gccArray = Split(strText, strFindChar)   
     nasGetCharCount = UBound(gccArray)   
    End Function


3- ComboBox

...

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
    '   ,      ComboBox   
      
    Private Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long  
      
    Private Sub Form_Load()  
     Dim i As Integer  
     For i = 1 To 50  
      Combo1.AddItem Format$(i)  
     Next i  
     Combo1.ListIndex = 0  
     ReSizeCombo Me, Combo1  
    End Sub  
      
    Private Sub Form_Resize()  
     ReSizeCombo Me, Combo1  
    End Sub  
      
    '             
    Public Sub ReSizeCombo(frm As Form, cbo As ComboBox)  
     Dim cboLeft As Long  
     Dim cboTop As Long  
     Dim cboWidth As Long  
     Dim cboHeight As Long  
     Dim oldScaleMode As Long  
     oldScaleMode = frm.ScaleMode  
     frm.ScaleMode = vbPixels  
     cboLeft = cbo.Left  
     cboTop = cbo.Top  
     cboWidth = cbo.Width  
     cboHeight = frm.ScaleHeight - cbo.Top - 5  
     frm.ScaleMode = oldScaleMode  
     MoveWindow cbo.hwnd, cboLeft, cboTop, cboWidth, cboHeight, 1  
    End Sub


4- (Style) CheckBox OptionButton

...

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
    '   ,      CommandButton,   CheckBox   OptionButton  
      
    Option Explicit  
      
    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long  
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long  
    Private Const GWL_STYLE = (-16)  
    Private Const BS_PUSHLIKE = &H1000&  
      
    Public Sub SetGraphicStyle(StyleButton As Control, Flag As Boolean)  
     Dim curstyle As Long  
     Dim newstyle As Long  
     If Not TypeOf StyleButton Is OptionButton And Not TypeOf StyleButton Is CheckBox Then Exit Sub  
     curstyle = GetWindowLong(StyleButton.hwnd, GWL_STYLE)  
     If Flag Then  
      curstyle = curstyle Or BS_PUSHLIKE  
     Else  
      curstyle = curstyle And (Not BS_PUSHLIKE)  
     End If  
     newstyle = SetWindowLong(StyleButton.hwnd, GWL_STYLE, curstyle)  
     StyleButton.Refresh  
    End Sub  
      
    Private Sub Command1_Click()  
     SetGraphicStyle Option1, True  
     SetGraphicStyle Check1, True  
    End Sub  
      
    Private Sub Command2_Click()  
     SetGraphicStyle Option1, False  
     SetGraphicStyle Check1, False  
    End Sub  
      
    Private Sub Command3_Click()  
     Option1.Value = False  
     Check1.Value = False  
    End Sub


5- 3
__ , , ..

...

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
    Private Sub Command1_Click()  
    Dim fNum As Integer  
    Dim sTagIdent As String * 3  
    Dim sTitle As String * 30  
    Dim sArtist As String * 30  
    Dim sAlbum As String * 30  
    Dim sYear As String * 4  
    Dim sComment As String * 30  
    fNum = FreeFile  
    Open "c:\#5_07_Kanikuli malenkoy pandi.mp3" For Binary As fNum  
    Seek #fNum, LOF(fNum) - 127  
    Get #fNum, , sTagIdent  
    If sTagIdent = "TAG" Then  
    Get #fNum, , sTitle  
    Get #fNum, , sArtist  
    Get #fNum, , sAlbum  
    Get #fNum, , sYear  
    Get #fNum, , sComment  
    End If  
    Close #fNum  
    Print "1" & sTitle  
    Print "2" & sArtist  
    Print "3" & sAlbum  
    Print "4" & sYear  
    Print "5" & sComment  
    End Sub


6- .

...

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
    Option Explicit  
    '          
    ':  , 07.11.2007  
    'http://kbyte.ru  
    'mailto:admin@kbyte.ru  
      
    Dim myRegEx As New RegExp  
      
    Private Sub Command1_Click()  
     myRegEx.Pattern = "<(.*?)>" '<(.*?)((/)|(.?))>(.*?)((</(.*?)>)|(.?))  
     myRegEx.Global = True  
     myRegEx.MultiLine = True  
     myRegEx.IgnoreCase = True  
     MsgBox myRegEx.Execute(Text1)(0)  
     Text2 = myRegEx.Replace(Text1, "")  
    End Sub


7- ( )

...

Visual Basic
1
2
3
4
5
6
7
8
9
10
    Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long  
      
    Private Sub Command1_Click()  
    Dim strSysDir As String  
    Dim RetLen As Long  
    strSysDir = String$(256, Chr$(0))  
    RetLen = GetSystemDirectory(strSysDir, 255)  
    strSysDir = Left$(strSysDir, RetLen)  
    Print " : " & strSysDir  
    End Sub


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
    Option Explicit  
      
    Public Declare Function SetWindowLong Lib "user32" _  
    Alias "SetWindowLongA" _  
    (ByVal hwnd As Long, _  
    ByVal nIndex As Long, _  
    ByVal wNewWord As Long) As Long  
      
    Public Declare Function CallWindowProc Lib "user32" _  
    Alias "CallWindowProcA" _  
    (ByVal lpPrevWndFunc As Long, _  
    ByVal hwnd As Long, _  
    ByVal msg As Long, _  
    ByVal wParam As Long, _  
    ByVal lParam As Long) As Long  
      
    Public Const GWL_WNDPROC As Long = (-4)  
    Public Const WM_ACTIVATE As Long = &H6  
    Public Const WM_ACTIVATEAPP As Long = &H1C  
    Public Const WA_INACTIVE As Long = 0  
    Public Const WA_ACTIVE As Long = 1  
    Public Const WA_CLICKACTIVE As Long = 2  
      
    Public OldProc As Long  
      
    Public blnSubclassed As Boolean  
      
    Public Function WndProc(ByVal hwnd As Long, _  
    ByVal uMsg As Long, _  
    ByVal wParam As Long, _  
    ByVal lParam As Long) As Long  
      
    On Error Resume Next  
      
    Select Case uMsg  
      
    Case WM_ACTIVATEAPP  
    Select Case LoWord(wParam)  
    Case WA_ACTIVE  
    Case Else  
    End Select  
    Case Else  
    End Select  
      
    If blnSubclassed = True Then  
    WndProc = CallWindowProc(OldProc, _  
    hwnd, uMsg, wParam, ByVal lParam)  
    Else  
    blnSubclassed = False  
    End If  
      
    End Function  
      
    Public Sub UnSubclass(hwnd As Long)  
    If OldProc Then  
    SetWindowLong hwnd, GWL_WNDPROC, OldProc  
    OldProc = 0  
    End If  
    End Sub  
      
    Public Sub Subclass(hwnd As Long)  
    On Error Resume Next  
      
    OldProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WndProc)  
    End Sub  
      
    Public Function LoWord(dw As Long) As Integer  
    If dw And &H8000 Then  
    LoWord = &H8000 Or (dw And &H7FFF&)  
    Else  
    LoWord = dw And &HFFF&  
    End If  
    End Function  
      
    Option Explicit  
      
    Private Declare Function SendMessage Lib "user32" _  
    Alias "SendMessageA" (ByVal hwnd As Long, _  
    ByVal wMsg As Long, ByVal wParam As Long, _  
    lParam As Long) As Long  
      
    Private Const WM_SETHOTKEY = &H32  
    '// Shift + A  
    Private Const HK_SHIFTA = &H141  
    '// Shift * B  
    Private Const HK_SHIFTB = &H142  
    '// Control + A  
    Private Const HK_CONTROLA = &H241  
    Private Const HK_ALTZ = &H45A  
      
    Private Sub cmdEnd_Click()  
    Unload Me  
    End Sub  
      
    Private Sub Command1_Click()  
      
    End Sub  
      
    Private Sub Form_Load()  
    Subclass Me.hwnd  
      
    '     
    SendMessage Me.hwnd, WM_SETHOTKEY, HK_ALTZ, 0  
    End Sub  
      
    Private Sub Form_Unload(Cancel As Integer)  
    UnSubclass Me.hwnd  
    End Sub


9-

" " " ..". . . , .

...

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
': Randy Birch  
'       :  
  
Option Explicit  
  
Private Type NETRESOURCE  
  dwScope    As Long  
  dwType    As Long  
  dwDisplayType As Long  
  dwUsage    As Long  
  lpLocalName  As String  
  lpRemoteName As String  
  lpComment   As String  
  lpProvider  As String  
End Type  
  
  
  
   
Private Declare Function WNetAddConnection2 Lib "mpr" _  
  Alias "WNetAddConnection2A" _  
  (lpNetResource As NETRESOURCE, _  
  ByVal lpPassword As String, _  
  ByVal lpUserName As String, _  
  ByVal dwFlags As Long) As Long  
      
Private Declare Function WNetCancelConnection2 Lib "mpr" _  
  Alias "WNetCancelConnection2A" _  
  (ByVal lpName As String, _  
  ByVal dwFlags As Long, _  
  ByVal fForce As Long) As Long  
      
Private Declare Function WNetConnectionDialog Lib "mpr" _  
  (ByVal hwnd As Long, ByVal dwType As Long) As Long  
    
Private Declare Function WNetDisconnectDialog Lib "mpr" _  
  (ByVal hwnd As Long, ByVal dwType As Long) As Long  
  
'Private Const RESOURCE_CONNECTED = &H1  
'Private Const RESOURCE_REMEMBERED = &H3  
'Private Const RESOURCEDISPLAYTYPE_DOMAIN = &H1  
'Private Const RESOURCEDISPLAYTYPE_GENERIC = &H0  
'Private Const RESOURCEDISPLAYTYPE_SERVER = &H2  
'Private Const RESOURCEUSAGE_CONTAINER = &H2  
  
Private Const ERROR_SUCCESS = 0  
Private Const CONNECT_UPDATE_PROFILE = &H1  
Private Const RESOURCETYPE_DISK = &H1  
Private Const RESOURCETYPE_PRINT = &H2  
Private Const RESOURCETYPE_ANY = &H0  
Private Const RESOURCE_GLOBALNET = &H2  
Private Const RESOURCEDISPLAYTYPE_SHARE = &H3  
Private Const RESOURCEUSAGE_CONNECTABLE = &H1  
  
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 Command1_Click(Index As Integer)  
  
  Dim x As Long  
    
  Select Case Index  
   Case 0: '     
       '   ,     
       ' ERROR_SUCCESS (0).    ""  
       '   &HFFFFFFFF ( -1).  
       '  
       '    hwnd,     
       '    .      
       ' 0&,     .  
        Call WNetConnectionDialog(Me.hwnd, RESOURCETYPE_DISK)  
     
   Case 1: '    
       '      
       'ERROR_SUCCESS (0).    &HFFFFFFFF.  
       '  
       '    hwnd,     
       '    .      
       ' 0&,     .  
        Call WNetDisconnectDialog(Me.hwnd, RESOURCETYPE_DISK)  
          
   Case 2: '  .  
       '    ,    :  
       '"rundll32.exe shell32.dll,SHHelpShortcuts_RunDLL AddPrinter"  
       '  .  
        Call Shell("rundll32.exe shell32.dll," & _  
             "SHHelpShortcuts_RunDLL AddPrinter", _  
              vbNormalFocus)  
       ' Windows NT,       
       '     API  -  
       'ConnectToPrinterDlg.       
       '  Visual Basic  Windows 95.  
       '  ,       
       '    MSDN "Add Printer Wizard"  
       '(KB article Q154007)  
          
   Case 3: '    
       '      
       'ERROR_SUCCESS (0).    &HFFFFFFFF.  
       '  
       '    hwnd,     
       '    .      
       ' 0&,     .  
        Call WNetDisconnectDialog(Me.hwnd, RESOURCETYPE_PRINT)  
     
   Case 4: '      
        MsgBox ConnectThisNetworkDrive("\\someserver\c$", "G:")  
     
   Case 5: '        
        MsgBox ConnectNextFreeNetworkDrive("\\someserver\c$")  
     
   Case 6: '   
        Call ShellExecute(0&, "Open", _  
                 "explorer.exe", "/e,/n,c:\", _  
                 0&, SW_SHOWNORMAL)  
   Case 7: '   
        Unload Me  
     
  End Select  
    
End Sub  
  
  
Private Function ConnectNextFreeNetworkDrive(sServer As String) As String  
  
  Dim NETR As NETRESOURCE  
  Dim errInfo As Long  
  Dim x As Long  
  Dim testDrv As String  
    
 '    C (ASCII 67),  ,    
 ',  .  
  x = 67  
    
  Do  
     
   '   D:  
   x = x + 1  
   testDrv = Chr$(x) & ":"  
     
   With NETR  
     .dwScope = RESOURCE_GLOBALNET  
     .dwType = RESOURCETYPE_DISK  
     .dwDisplayType = RESOURCEDISPLAYTYPE_SHARE  
     .dwUsage = RESOURCEUSAGE_CONNECTABLE  
     .lpRemoteName = sServer  
     .lpLocalName = testDrv  
   End With  
     
   errInfo = WNetAddConnection2(NETR, _  
                  vbNullString, _  
                  "username", _  
                  CONNECT_UPDATE_PROFILE)  
     
  Loop Until x = 90 Or errInfo = ERROR_SUCCESS  '90 = "z"  
    
    
 '      
  If errInfo = ERROR_SUCCESS Then  
     ConnectNextFreeNetworkDrive = testDrv  
  Else: ConnectNextFreeNetworkDrive = "no dice"  
  End If  
    
End Function  
  
  
Private Function ConnectThisNetworkDrive(sServer As String, _  
                     sDrv As String) As Boolean  
  
 '     
 '  .  
 '  ,  ErrInfo=ERROR_SUCCESS  
  
  Dim NETR As NETRESOURCE  
  Dim errInfo As Long  
    
  With NETR  
   .dwScope = RESOURCE_GLOBALNET  
   .dwType = RESOURCETYPE_DISK  
   .dwDisplayType = RESOURCEDISPLAYTYPE_SHARE  
   .dwUsage = RESOURCEUSAGE_CONNECTABLE  
   .lpRemoteName = sServer  
   .lpLocalName = sDrv  
  End With  
    
  errInfo = WNetAddConnection2(NETR, _  
                vbNullString, _  
                "username", _  
                CONNECT_UPDATE_PROFILE)  
    
  ConnectThisNetworkDrive = errInfo = ERROR_SUCCESS  
  
End Function


10- AVI- PictureBox-.

...

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
    Private Declare Function mciSendString Lib "winmm" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long  
    Private Declare Function mciGetErrorString Lib "winmm" Alias "mciGetErrorStringA" (ByVal dwError As Long, ByVal lpstrBuffer As String, ByVal uLength As Long) As Long  
    Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long  
    Const WS_CHILD = &H40000000  
    Sub PlayAVIPictureBox(FileName As String, ByVal Window As PictureBox)  
    Dim RetVal As Long  
    Dim CommandString As String  
    Dim ShortFileName As String * 260  
    Dim deviceIsOpen As Boolean  
    'Retrieve short file name format  
    RetVal = GetShortPathName(FileName, ShortFileName, Len(ShortFileName))  
    FileName = Left$(ShortFileName, RetVal)  
    'Open the device  
    CommandString = "Open " & FileName & " type AVIVideo alias AVIFile parent " & CStr(Window.hWnd) & " style " & CStr(WS_CHILD)  
    RetVal = mciSendString(CommandString, vbNullString, 0, 0&)  
    If RetVal Then GoTo Error  
    'remember that the device is now open  
    deviceIsOpen = True  
    'Resize the movie to PictureBox size  
    CommandString = "put AVIFile window at 0 0 " & CStr(Window.ScaleWidth / _  
    Screen.TwipsPerPixelX) & " " & CStr(Window.ScaleHeight / _  
    Screen.TwipsPerPixelY)  
    RetVal = mciSendString(CommandString, vbNullString, 0, 0&)  
    If RetVal <> 0 Then GoTo Error  
    'Play the file  
    CommandString = "Play AVIFile wait"  
    RetVal = mciSendString(CommandString, vbNullString, 0, 0&)  
    If RetVal <> 0 Then GoTo Error  
    'Close the device  
    CommandString = "Close AVIFile"  
    RetVal = mciSendString(CommandString, vbNullString, 0, 0&)  
    If RetVal <> 0 Then GoTo Error  
    Exit Sub  
    Error:  
    'An error occurred.  
    'Get the error description  
    Dim ErrorString As String  
    ErrorString = Space$(256)  
    mciGetErrorString RetVal, ErrorString, Len(ErrorString)  
    ErrorString = Left$(ErrorString, InStr(ErrorString, vbNullChar) - 1)  
    'close the device if necessary  
    If deviceIsOpen Then  
    CommandString = "Close AVIFile"  
    mciSendString CommandString, vbNullString, 0, 0&  
    End If  
    'raise a custom error, with the proper description  
    Err.Raise 999, , ErrorString  
    End Sub  
      
    Private Sub Command1_Click()  
    'replace 'c:\myfile.avi' with the name of the AVI file you want to play  
    PlayAVIPictureBox "C:\Program Files\Microsoft Visual Studio\VB98\Wizards\PDWizard\Working.avi", Picture1  
    End Sub


11- Excel. .

...

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
    Dim tFile As String  
        tFile = ""  
        tFile = Path.GetTempFileName()  
        Dim myFileInfo As New FileInfo(tFile)  
        myFileInfo.Attributes = FileAttributes.Temporary  
      
        Using Wr As StreamWriter = New StreamWriter(tFile, False, Encoding.GetEncoding(1251))  
          Wr.WriteLine(" .." & vbTab & _  
                 "." & vbTab & _  
                 " ." & vbTab & _  
                 " " & vbTab & _  
                 "" & vbTab & _  
                 ".")  
          For i = 1 To fTab.GetUpperBound(0)  
            Wr.WriteLine(i & vbTab & _  
             fTab(i).FIO & vbTab & _  
             fTab(i).DatR & vbTab & _  
             fTab(i).Mest & vbTab & _  
             fTab(i).Pol & vbTab & _  
             fTab(i).Prim)  
            My.Application.DoEvents()  
          Next  
          Wr.Close()  
        End Using  
        Dim oExcel As New Microsoft.Office.Interop.Excel.Application  
        Dim oBook As Microsoft.Office.Interop.Excel.Workbook  
        Dim oSheet As Microsoft.Office.Interop.Excel.Worksheet  
        oExcel = New Microsoft.Office.Interop.Excel.Application  
        oBook = oExcel.Workbooks.Open(tFile)  
        oSheet = oBook.Sheets(1)  
        oExcel.Visible = True  
        oSheet.Rows("1:1").HorizontalAlignment = -4108  
        oSheet.Rows("1:1").VerticalAlignment = -4108  
        oSheet.Rows("1:1").Font.FontStyle = ""  
        oSheet.Columns("A:A").HorizontalAlignment = -4108  
        oSheet.Columns("A:A").VerticalAlignment = -4108  
        oSheet.Columns("B:B").HorizontalAlignment = -4108  
        oSheet.Columns("B:B").VerticalAlignment = -4108  
        oSheet.Columns("C:C").HorizontalAlignment = -4108  
        oSheet.Columns("C:C").VerticalAlignment = -4108  
        oSheet.Columns("F:F").HorizontalAlignment = -4108  
        oSheet.Columns("F:F").VerticalAlignment = -4108  
        oSheet.Columns("C:C").Interior.ColorIndex = 35  
        oSheet.Columns("E:E").Interior.ColorIndex = 35  
        oSheet.Cells.EntireColumn.AutoFit()  
        oSheet.Range("A2").Select()  
        oExcel.ActiveWindow.FreezePanes = True  
    End Sub


12- , , ..

...

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
    Public Function nasRound(Num As Double, d As Integer) As Double  
     Dim a As Double  
     Dim r As Double  
     Dim b As Double  
     a = Num Mod d  
     If a > (d / 2) Then  
      b = d - a  
      r = Num + b  
     Else  
      r = Num - a  
     End If  
     nasRound = r  
    End Function


13- ?

...

Visual Basic
1
2
3
4
5
    Private Sub Command1_Click()  
    '    0  99  
    Randomize '    
    MsgBox Int(100 * Rnd)  
    End Sub


14- 3D-

...

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
    '   AutoRedraw  True  
    Private Sub Form_Load()   
    Dim ShadowX   
    Dim ShadowY   
    ScaleMode = 3   
    ForeColor = "&H808080"   
    ShadowY = 5   
    ShadowX = 5   
    For I = 0 To 5   
    CurrentX = ShadowX + I   
    CurrentY = ShadowY + I   
    If I = 5 Then Form1.ForeColor = vbWhite   
    Form1.Print "3D Text!!!"   
    Next   
    End Sub

: 3D :

15-

...

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
    Function FIO(fi As String, im As String, ot As String, pol As String) As String  
      
    fi = StrConv(Trim(fi), vbLowerCase)  
    im = StrConv(Trim(im), vbLowerCase)  
    ot = StrConv(Trim(ot), vbLowerCase)  
    pol = pol  
      
      
    fi_s = Len(fi)  
    im_s = Len(im)  
    ot_s = Len(ot)  
    If pol = "" Then  
        
      For i = fi_s To fi_s - (fi_s + 2) Step -1  
      If fi_s = 0 Then GoTo fi  
      k = Mid(fi, i, 1)  
        If k = "" Or k = "" Or k = "" Or k = "" Or k = "" Or _  
          k = "" Or k = "" Or k = "" Then  
           k = Mid(fi, i - 1, 1)  
            If k = "" Or k = "" Or k = "" Or k = "" Or k = "" Or _  
                k = "" Or k = "" Or k = "" Then  
              
            Else  
              k = Mid(fi, i - 2, 1)  
              
              If k = "" Or k = "" Or k = "" Or k = "" Or k = "" Or _  
                k = "" Or k = "" Or k = "" Then  
                fi_str = Left(fi, i - 1) & ""  
                Exit For  
              Else  
              
                fi_str = fi  
                Exit For  
              End If  
              
            End If  
              
        Else  
          fi_str = fi  
          Exit For  
        End If  
      Next  
    fi:  
      For i = im_s To im_s - (im_s + 2) Step -1  
         If im_s = 0 Then GoTo im  
         k = Mid(im, i, 1)  
        'MsgBox k  
        If k = "" Or k = "" Or k = "" Or k = "" Or k = "" Or _  
          k = "" Or k = "" Or k = "" Then  
          'If i > 1 Then  
            k = Mid(im, i - 1, 1)  
            If k = "" Or k = "" Or k = "" Or k = "" Or k = "" Or _  
                k = "" Or k = "" Or k = "" Then  
              im_str = Left(im, i - 2) & ""  
              Exit For  
              
            Else  
              im_str = Left(im, i - 1) & ""  
              Exit For  
            End If  
          'End If  
        ElseIf k = "" Then  
          im_str = Left(im, i - 1) & ""  
          Exit For  
        Else  
          im_str = im  
          Exit For  
        End If  
      Next  
    im:  
      If ot_s <> 0 Then  
        ot_str = Left(ot, Len(ot) - 1) & ""  
      End If  
    ElseIf pol = "" Then  
      'MsgBox " -   "  
        
      For i = fi_s To fi_s - (fi_s + 2) Step -1  
      If fi_s = 0 Then GoTo fi1  
      k = Mid(fi, i, 1)  
        If k = "" Or k = "" Or k = "" Or k = "" Or k = "" Or _  
          k = "" Or k = "" Or k = "" Then  
          fi_str = fi  
          Exit For  
        Else  
          fi_str = fi & ""  
          Exit For  
            
        End If  
      Next  
    fi1:  
      For i = im_s To im_s - (im_s + 2) Step -1  
      If im_s = 0 Then GoTo im1  
        k = Mid(im, i, 1)  
        If k = "" Or k = "" Then  
          im_str = Left(im, Len(im) - 1) & ""  
          Exit For  
        Else  
          im_str = im & ""  
          Exit For  
        End If  
      Next  
    im1:  
      If ot_s <> 0 Then  
        ot_str = ot & ""  
      End If  
    End If  
    FIO = StrConv(fi_str, vbProperCase) & " " & StrConv(im_str, vbProperCase) & " " & StrConv(ot_str, vbProperCase)  
    End Function  
      
      
    Function FIO(fi As String, im As String, ot As String, pol As String) As String  
      
    fi = StrConv(Trim(fi), vbLowerCase)  
    im = StrConv(Trim(im), vbLowerCase)  
    ot = StrConv(Trim(ot), vbLowerCase)  
    pol = pol  
      
      
    fi_s = Len(fi)  
    im_s = Len(im)  
    ot_s = Len(ot)  
    If pol = "" Then  
        
      For i = fi_s To fi_s - (fi_s + 2) Step -1  
      If fi_s = 0 Then GoTo fi  
      k = Mid(fi, i, 1)  
        If k = "" Or k = "" Or k = "" Or k = "" Or k = "" Or _  
          k = "" Or k = "" Or k = "" Then  
           k = Mid(fi, i - 1, 1)  
            If k = "" Or k = "" Or k = "" Or k = "" Or k = "" Or _  
                k = "" Or k = "" Or k = "" Then  
              
            Else  
              k = Mid(fi, i - 2, 1)  
              
              If k = "" Or k = "" Or k = "" Or k = "" Or k = "" Or _  
                k = "" Or k = "" Or k = "" Then  
                fi_str = Left(fi, i - 1) & ""  
                Exit For  
              Else  
              
                fi_str = fi  
                Exit For  
              End If  
              
            End If  
              
        Else  
          fi_str = fi  
          Exit For  
        End If  
      Next  
    fi:  
      For i = im_s To im_s - (im_s + 2) Step -1  
         If im_s = 0 Then GoTo im  
         k = Mid(im, i, 1)  
        'MsgBox k  
        If k = "" Or k = "" Or k = "" Or k = "" Or k = "" Or _  
          k = "" Or k = "" Or k = "" Then  
          'If i > 1 Then  
            k = Mid(im, i - 1, 1)  
            If k = "" Or k = "" Or k = "" Or k = "" Or k = "" Or _  
                k = "" Or k = "" Or k = "" Then  
              im_str = Left(im, i - 2) & ""  
              Exit For  
              
            Else  
              im_str = Left(im, i - 1) & ""  
              Exit For  
            End If  
          'End If  
        ElseIf k = "" Then  
          im_str = Left(im, i - 1) & ""  
          Exit For  
        Else  
          im_str = im  
          Exit For  
        End If  
      Next  
    im:  
      If ot_s <> 0 Then  
        ot_str = Left(ot, Len(ot) - 1) & ""  
      End If  
    ElseIf pol = "" Then  
      'MsgBox " -   "  
        
      For i = fi_s To fi_s - (fi_s + 2) Step -1  
      If fi_s = 0 Then GoTo fi1  
      k = Mid(fi, i, 1)  
        If k = "" Or k = "" Or k = "" Or k = "" Or k = "" Or _  
          k = "" Or k = "" Or k = "" Then  
          fi_str = fi  
          Exit For  
        Else  
          fi_str = fi & ""  
          Exit For  
            
        End If  
      Next  
    fi1:  
      For i = im_s To im_s - (im_s + 2) Step -1  
      If im_s = 0 Then GoTo im1  
        k = Mid(im, i, 1)  
        If k = "" Or k = "" Then  
          im_str = Left(im, Len(im) - 1) & ""  
          Exit For  
        Else  
          im_str = im & ""  
          Exit For  
        End If  
      Next  
    im1:  
      If ot_s <> 0 Then  
        ot_str = ot & ""  
      End If  
    End If  
    FIO = StrConv(fi_str, vbProperCase) & " " & StrConv(im_str, vbProperCase) & " " & StrConv(ot_str, vbProperCase)  
    End Function


16- (.)

...

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
Public Function GetOrdinal(ByVal Number As Integer) As String  
  ' Accepts an integer, returns the ordinal suffix  
  ' Handles special case three digit numbers ending  
  ' with 11, 12 or 13 - ie, 111th, 112th, 113th, 211th, et al  
  If CType(Number, String).Length > 2 Then  
   Dim intEndNum As Integer = CType(CType(Number, String). _  
     Substring(CType(Number, String).Length - 2, 2), Integer)  
   If intEndNum >= 11 And intEndNum <= 13 Then  
    Select Case intEndNum  
     Case 11, 12, 13  
      Return "th"  
    End Select  
   End If  
  End If  
  If Number >= 21 Then  
   ' Handles 21st, 22nd, 23rd, et al  
   Select Case CType(Number.ToString.Substring( _  
     Number.ToString.Length - 1, 1), Integer)  
    Case 1  
     Return "st"  
    Case 2  
     Return "nd"  
    Case 3  
     Return "rd"  
    Case 0, 4 To 9  
     Return "th"  
   End Select  
  Else  
   ' Handles 1st to 20th  
   Select Case Number  
    Case 1  
     Return "st"  
    Case 2  
     Return "nd"  
    Case 3  
     Return "rd"  
    Case 4 To 20  
     Return "th"  
   End Select  
  End If  
 End Function  
  
 Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load  
  Dim strNumber As String  
  strNumber = "2" & GetOrdinal(38)  
  MessageBox.Show(strNumber)  
 End Sub


17- , .
, CommandButton Command1.

...

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
    Private Declare Function GetWindowLong& Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long)  
    Private Declare Function SetWindowLong& Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long)  
    Private Const A_CENTER = &H300&  
    Private Const A_TOP = &H400&  
    Private Const A_TOPLEFT = &H500&  
    Private Const A_TOPRIGHT = &H600&  
    Private Const A_BOTTOM = &H800&  
    Private Const A_BOTTOMLEFT = &H900&  
    Private Const A_BOTTOMRIGHT = &HA00&  
    Private Const A_LEFT = &H100&  
    Private Const A_RIGHT = &H200&  
    Private Const GWL_STYLE& = (-16)  
      
    Private Sub Form_Load()  
     Dim tmpValue As Long, Align As Long, ret As Long  
     fAlignment = A_BOTTOMRIGHT  
     tmpValue = GetWindowLong&(Command1.hwnd, GWL_STYLE) And Not BS_RIGHT  
     ret = SetWindowLong&(Command1.hwnd, GWL_STYLE, tmpValue Or fAlignment)  
     Command1.Refresh  
    End Sub


18- ListView.

...

Visual Basic
1
2
3
4
5
6
7
8
    ListView1.Groups.Add(New ListViewGroup("Group 1", HorizontalAlignment.Left))
 
'        
      
    ListView1.Groups.Add("Group 1", HorizontalAlignment.Left))  
    ListView1.Groups.RemoveAt(0)'    
    ListView1.Groups.Clear()'    
    ListView1.Items.Item(0).Group = ListView1.Groups(0)' 


19- E-Mail

...

Visual Basic
1
2
3
4
5
6
7
8
    Private Sub Form_Load()  
     Dim strMail As String  
    rep:  
     strMail = InputBox(" e-mail:")  
     If Len(strMail) <= 0 Then MsgBox "E-Mail  !": GoTo rep  
     If InStr(1, strMail, "@") <= 0 Or InStr(1, strMail, ".") <= 0 Then MsgBox "  e-mail!": GoTo rep  
     MsgBox "!  e-mail - " & strMail  
    End Sub
dev.Free
21.11.2012, 14:03     Visual Basic 6.0 #3
20-

Visual Basic
1
2
3
4
5
 Dim S As Double '
 S = 0
 For i = 1 To UBound(arrA) 'Step 2 -            
  If arrA(i) < 0 Then S = S + arrA(i)
 Next i
dev.Free
21.11.2012, 17:23     Visual Basic 6.0 #4
21- SQL Server ( )

...

:

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
Public conn As New ADODB.Connection
Public rs As New ADODB.Recordset
 
Public conn2 As New ADODB.Connection
Public rs2 As New ADODB.Recordset
Public rs3 As New ADODB.Recordset
 
Sub Main()
 
    OpenDB
    Form1.Show
 
End Sub
 
Sub OpenDB()
    Set conn = Nothing
    Set conn = New ADODB.Connection
    conn = "Provider=SQLNCLI10;Server=;Database=  ;Trusted_Connection=yes;"
    conn.Open
    If conn.State = 1 Then
        MsgBox "Ñîåäè*å*èå óñò**îâëå*î"
    Else
        MsgBox "Ñîåäè*å*èå *å óñò**îâëå*î"
    End If
:

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
Private Sub Form_Load()
    Call UpdateConnect
End Sub
 
Sub UpdateConnect()
    Set rs = Nothing
    Set rs = New ADODB.Recordset
    SQL = " SQL "
    rs.Open SQL, conn, 3, 3
    Set DataGrid1.DataSource = rs
End Sub


22-

...

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
Option Explicit
 
Private Declare Function SetWindowPos Lib "user32" _
    (ByVal hwnd As Long, _
     ByVal hWndInsertAfter As Long, _
     ByVal X As Long, _
     ByVal Y As Long, _
     ByVal cx As Long, _
     ByVal cy As Long, _
     ByVal wFlags As Long) As Long
Private Const HWND_NOTOPMOST = -2
Private Const HWND_TOPMOST = -1
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
 
Private Sub SetFormPosition(frmHandl As Long, TopPosition As Boolean)
If TopPosition Then
    SetWindowPos frmHandl, HWND_TOPMOST, 0, 0, 0, 0, _
    SWP_NOACTIVATE Or SWP_NOSIZE Or SWP_NOMOVE
Else
    SetWindowPos frmHandl, HWND_NOTOPMOST, 0, 0, 0, 0, _
    SWP_NOSIZE Or SWP_NOMOVE
End If
End Sub
 
Private Sub Form_Load()
Call SetFormPosition(Me.hwnd, True)
End Sub


23-

: 1 , 1 , 1 Label.

...

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


24- "X"

...

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Private Declare Function DeleteMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private Declare Function GetSystemMenu Lib "user32" (ByVal hWnd As Long, ByVal bRevert As Long) As Long
 
Private Const MF_BYPOSITION = &H400&
 
Private Sub Form_Load()
    RemoveMenus
End Sub
 
Private Sub RemoveMenus()
    Dim hMenu As Long
    '     .
    hMenu = GetSystemMenu(hWnd, False)
    DeleteMenu hMenu, 6, MF_BYPOSITION
End Sub


25- 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


26-

...

:

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
Option Explicit
 
 
Private Const WH_KEYBOARD_LL = 13&     'enables monitoring of keyboard
                                       'input events about to be posted
                                       'in a thread input queue
                                       
Private Const HC_ACTION = 0&           'wParam and lParam parameters
                                       'contain information about a
                                       'keyboard message
 
Private Const LLKHF_EXTENDED = &H1&    'test the extended-key flag
Private Const LLKHF_INJECTED = &H10&   'test the event-injected flag
Private Const LLKHF_ALTDOWN = &H20&    'test the context code
Private Const LLKHF_UP = &H80&         'test the transition-state flag
 
 
Private Const VK_TAB = &H9             'virtual key constants
Private Const VK_CONTROL = &H11
Private Const VK_ESCAPE = &H1B
 
Private Const VK_LWIN = &H5B
Private Const VK_RWIN = &H5C
Private Const VK_APPS = &H5D
 
 
Private Type KBDLLHOOKSTRUCT
  vkCode As Long        'a virtual-key code in the range 1 to 254
  scanCode As Long      'hardware scan code for the key
  flags As Long         'specifies the extended-key flag,
                        'event-injected flag, context code,
                        'and transition-state flag
  time As Long          'time stamp for this message
  dwExtraInfo As Long   'extra info associated with the message
End Type
 
Private Declare Function SetWindowsHookEx Lib "user32" _
   Alias "SetWindowsHookExA" _
  (ByVal idHook As Long, _
   ByVal lpfn As Long, _
   ByVal hmod As Long, _
   ByVal dwThreadId As Long) As Long
   
Private Declare Function UnhookWindowsHookEx Lib "user32" _
  (ByVal hHook As Long) As Long
 
Private Declare Function CallNextHookEx Lib "user32" _
  (ByVal hHook As Long, _
   ByVal nCode As Long, _
   ByVal wParam As Long, _
   ByVal lParam As Long) As Long
   
Private Declare Sub CopyMemory Lib "kernel32" _
   Alias "RtlMoveMemory" _
  (pDest As Any, _
   pSource As Any, _
   ByVal cb As Long)
 
Private Declare Function GetAsyncKeyState Lib "user32" _
   (ByVal vKey As Long) As Integer
 
Private m_hDllKbdHook As Long  'private variable holding
                               'the handle to the hook procedure
 
 
Public Sub SetKeyboardHook()
On Error GoTo xErr
 
    If m_hDllKbdHook = 0 Then m_hDllKbdHook = SetWindowsHookEx(WH_KEYBOARD_LL, _
                                   AddressOf LowLevelKeyboardProc, _
                                   App.hInstance, _
                                   0&)
 
Exit Sub
''''''''''''''''''''''''''''
xErr:
Unload Form1
End
''''''''''''''''''''''''''''
End Sub
 
 
Public Sub RemoveKeyboardHook()
On Error Resume Next
    If m_hDllKbdHook <> 0 Then UnhookWindowsHookEx m_hDllKbdHook: m_hDllKbdHook = 0
End Sub
 
 
 
Public Function LowLevelKeyboardProc(ByVal nCode As Long, _
                                     ByVal wParam As Long, _
                                     ByVal lParam As Long) As Long
 
  'Application-defined callback function
  'used with the SetWindowsHookEx function.
  'The system calls this function every
  'time a new keyboard input event is about
  'to be posted into a thread input queue.
  'The keyboard input can come from the local
  'keyboard driver or from calls to the
  'keybd_event function. If the input comes
  'from a call to keybd_event, the input
  'was "injected".
 
   Static kbdllhs As KBDLLHOOKSTRUCT
  
  'If nCode is less than zero, the hook
  'procedure must return the value returned
  'by CallNextHookEx.
  '
  'If nCode is greater than or equal to zero,
  'and the hook procedure did not process the
  'message, it is highly recommended that you
  'call CallNextHookEx and return the value it
  'returns; otherwise, other applications that
  'have installed WH_KEYBOARD_LL hooks will not
  'receive hook notifications and may behave
  'incorrectly as a result.
  '
  'If the hook procedure processed the message,
  'it may return a nonzero value to prevent the
  'system from passing the message to the rest
  'of the hook chain or the target window procedure.
    
   
   If nCode = HC_ACTION Then
   
     'nCode specifies a code the hook
     'procedure uses to determine how
     'to process the message. HC_ACTION
     'is the only valid code.
     
     'On receipt of the HC_ACTION code,
     'wParam and lParam contain information
     'about a keyboard message, and lParam
     'holds the pointer to a KBDLLHOOKSTRUCT
     'structure.
      Call CopyMemory(kbdllhs, ByVal lParam, Len(kbdllhs))
 
     'WIN --------------
      If (kbdllhs.vkCode = VK_LWIN) Or _
            (kbdllhs.vkCode = VK_RWIN) Or _
                (kbdllhs.vkCode = VK_APPS) Then
                
        LowLevelKeyboardProc = 1
        Exit Function
        
      End If
 
   End If  'nCode = HC_ACTION
  
  LowLevelKeyboardProc = CallNextHookEx(m_hDllKbdHook, _
                                        nCode, _
                                        wParam, _
                                        lParam)
  
End Function
:

Visual Basic
1
2
3
4
5
6
7
Private Sub Form_Load()
  SetKeyboardHook
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
  RemoveKeyboardHook
End Sub


27-

...

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Option Explicit
Private Sub Command1_Click()
   Dim i As Integer, s As String, ss As String
   s = "/\:*?<>|" & Chr(34)
   For i = 1 To Len(s)
      ss = ss + Str(Asc(Mid(s, i, 1)))
   Next i
   MsgBox ss
   Debug.Print ss
End Sub
Private Function false_symbol(sfalse As String) As Boolean
   Dim i As Integer, s As String
   s = "/\:*?<>|" & Chr(34)    ' Èñêëþ÷å*èÿ (34 - ê*âû÷êè)
   false_symbol = InStr(1, s, sfalse)
End Function
Private Sub Form_Load()
   Label1.Caption = "Ç*ïðåùå*û ñèìâîëû: " & "/\:*?<>|" & Chr(34)
End Sub
Private Sub Text1_KeyPress(KeyAscii As Integer)
   Text1.Locked = false_symbol(Chr(KeyAscii))
End Sub


28- .MP3

...

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
Option Explicit
Private Declare Function mciExecute Lib "winmm.dll" (ByVal lpstrCommand As String) As Long
Dim p As String
Private Sub Form_Load()
p = "c:\101.mp3"
End Sub
' 
Private Sub Command2_Click()
Dim f As Long, s As String
s = StrConv(LoadResData(101, "CUSTOM"), vbUnicode)
f = FreeFile
Open p For Binary As #f
Put #f, , s
Close #f
Call mciExecute("play " & p)
End Sub
 
'
Private Sub Command1_Click()
On Error Resume Next
Call mciExecute("close " & p)
Kill p
End Sub


29- Web-, WinInet API

...

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
Private Const INTERNET_OPEN_TYPE_PRECONFIG = 0
Private Const INTERNET_OPEN_TYPE_DIRECT = 1
Private Const INTERNET_OPEN_TYPE_PROXY = 3
Private Const scUserAgent = "VB Project"
Private Const INTERNET_FLAG_RELOAD = &H80000000
Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Private Declare Function InternetOpenUrl Lib "wininet.dll" Alias "InternetOpenUrlA" (ByVal hOpen As Long, ByVal sUrl As String, ByVal sHeaders As String, ByVal lLength As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Function InternetReadFile Lib "wininet.dll" (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer
Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer
 
Private Function OpenURL(ByVal sUrl As String) As String
Dim hOpen As Long
Dim hOpenUrl As Long
Dim bDoLoop As Boolean
Dim bRet As Boolean
Dim sReadBuffer As String * 2048
Dim lNumberOfBytesRead As Long
Dim sBuffer As String
hOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
hOpenUrl = InternetOpenUrl(hOpen, sUrl, vbNullString, 0, INTERNET_FLAG_RELOAD, 0)
bDoLoop = True
While bDoLoop
sReadBuffer = vbNullString
bRet = InternetReadFile(hOpenUrl, sReadBuffer, Len(sReadBuffer), lNumberOfBytesRead)
sBuffer = sBuffer & Left$(sReadBuffer, lNumberOfBytesRead)
If Not CBool(lNumberOfBytesRead) Then bDoLoop = False
Wend
If hOpenUrl <> 0 Then InternetCloseHandle (hOpenUrl)
If hOpen <> 0 Then InternetCloseHandle (hOpen)
OpenURL = sBuffer
End Function
 
Private Sub Command1_Click()
Text1 = OpenURL("http://www.yandex.ru/")
End Sub

.
dilloYa
12 / 12 / 0
: 03.09.2012
: 43
24.11.2012, 13:00     Visual Basic 6.0 #5
31- - API

...

Visual Basic
1
2
3
4
5
Private Sub Command1_Click()
Label1.Caption = Environ("SYSTEMROOT") '    Windows
Label2.Caption = Environ("TEMP") '    TEMP
Label3.Caption = Environ("PATH") '    
End Sub


32- (?)

...

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
Private Sub Command1_Click()
  Dim EnvString As String, tmpString As String
  Dim m As Integer
   m = 1
   Do
     EnvString = Environ(m)
     tmpString = tmpString & Chr(13) & Environ(m)
     m = m + 1
   Loop Until EnvString = ""
   MsgBox tmpString
End Sub

.
dzug
668 / 208 / 15
: 17.01.2011
: 530
: 1
24.11.2012, 17:48     Visual Basic 6.0 #6
44- , .

...

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
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Sub Djek() ' 
Dim Lex(1 To 10000) As String, s1$, ii&, s$
'     
s1 = Environ("temp") & "\Temp_2.log"
'URL 
s = "http://nato-ukr.narod.ru"
' 
URLDownloadToFile 0, s, s1, 0, 0
    fi% = FreeFile
    ' 
    Open s1 For Binary Access Read As #fi%
      LF& = LOF(fi%)
      Buf$ = Space$(LF&)
      Get #fi%, , Buf$
    Close #fi%
    Parse Buf$, Lex$, n%
    For i% = 1 To n%
      '      .  
      If Len(Lex(i%)) > 3 Then
        ii = ii + 1
        '   
        Debug.Print Lex(i%)
      End If
    Next i%
Kill s1
End Sub
 
Sub Parse(Buf As String, Lex() As String, ptr As Integer)
'      Catstail
Tmp$ = ""
ptr = 0
For i& = 1 To Len(Buf)
  s$ = Mid$(Buf, i&, 1)
  Select Case (s$)
  Case Chr$(10), Chr$(13)
    Case ">"
      Tmp$ = Trim$(Tmp$)
      If (Left$(Tmp$, 1) <> "<") And _
         (Left$(Tmp$, 1) <> "/") And _
         (Left$(Tmp$, 1) <> ">") And _
         Len(Tmp$) > 0 Then
         ptr% = ptr% + 1
         Lex(ptr%) = Tmp$
      End If
      Tmp$ = ""
    Case "<"
      Tmp$ = Trim$(Tmp$)
      If (Left$(Tmp$, 1) <> "<") And _
         (Left$(Tmp$, 1) <> "/") And _
         (Left$(Tmp$, 1) <> ">") And _
         Len(Tmp$) > 0 Then
         ptr% = ptr% + 1
         Lex(ptr%) = Tmp$
      End If
      Tmp$ = "<"
    Case Else
      Tmp$ = Tmp$ + s$
  End Select
Next i&
End Sub


45- WEB- IP-.
, , IP- .

, IP-.
"http://www.softholm.com/services/address_ip.php" ,
" IP : <b>" IP-, .

:
1. , , Aut_22.txt.
2. , " IP : <b>" .
3. , InStr(), " IP : <b>" .
4. IP , .
5. IP- .

...
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
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
 
    Sub main()
       s = I_PI
   End Sub 
 
   Private Function I_PI()
     Dim s, ss$, s1$, i&, sx$, ii&, sa$
      s1 = Environ("temp") & "\Aut_22.txt"
      s = "http://www.softholm.com/services/address_ip.php"
      URLDownloadToFile 0, s, s1, 0, 0
      ss = " IP : <b>"
       Open s1 For Input As #1
         While Not EOF(1)
           Line Input #1, s
           If InStr(s, ss) > 0 Then
             i = InStr(s, ss) + Len(ss)
             ii = i
               Do
                sa = Mid(s, ii, 1)
                ii = ii + 1
                sx = sx & sa
               Loop Until sa = "<"
             sx = Mid(sx, 1, Len(sx) - 1)
             GoTo xren
           End If
        Wend
xren:
      Close #1
      Kill s1
      MsgBox sx
        '   IP    
         With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
           .SetText sx
           .PutInClipboard
        End With
 
      I_PI = sx
   End Function
Denri
101 / 52 / 2
: 10.07.2012
: 343
: 2
25.11.2012, 14:24     Visual Basic 6.0 #7
45- IP

:
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Public Event ErrorDownload(FromPathName As String, ToPathName As String)
Public Event DownloadComplete(FromPathName As String, ToPathName As String)
 
 
Public Function DownloadFile(FromPathName As String, ToPathName As String)
If URLDownloadToFile(0, FromPathName, ToPathName, 0, 0) = 0 Then
    DownloadFile = True
    RaiseEvent DownloadComplete(FromPathName, ToPathName)
  Else
    DownloadFile = False
    RaiseEvent ErrorDownload(FromPathName, ToPathName)
End If
End Function
 
Private Sub Command1_Click()
Label2.Caption "IP Host Name: " & GetIPHostName()
Label1.Caption "IP Address: " & GetIPAddress()
Call DownloadFile("http://visua/Banner.htm", "c:\ttt.htm")
End Sub


:
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
'   
 
Public Const MAX_WSADescription = 256
Public Const MAX_WSASYSStatus = 128
Public Const ERROR_SUCCESS As Long = 0
Public Const WS_VERSION_REQD As Long = &H101
Public Const WS_VERSION_MAJOR As Long = WS_VERSION_REQD \ &H100 And &HFF&
Public Const WS_VERSION_MINOR As Long = WS_VERSION_REQD And &HFF&
Public Const MIN_SOCKETS_REQD As Long = 1
Public Const SOCKET_ERROR As Long = -1
 
Public Type HOSTENT
    hName As Long
    hAliases As Long
    hAddrType As Integer
    hLen As Integer
    hAddrList As Long
End Type
 
Public Type WSADATA
    wVersion As Integer
    wHighVersion As Integer
    szDescription(0 To MAX_WSADescription) As Byte
    szSystemStatus(0 To MAX_WSASYSStatus) As Byte
    wMaxSockets As Integer
    wMaxUDPDG As Integer
    dwVendorInfo As Long
End Type
 
Public Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long
Public Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired As Long, lpWSADATA As WSADATA) As Long
Public Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
Public Declare Function gethostname Lib "WSOCK32.DLL" (ByVal szHost As String, ByVal dwHostLen As Long) As Long
Public Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal szHost As String) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
 
 
Public Function GetIPAddress() As String
Dim sHostName As String * 256
Dim lpHost As Long
Dim HOST As HOSTENT
Dim dwIPAddr As Long
Dim tmpIPAddr() As Byte
Dim i As Integer
Dim sIPAddr As String
 
If Not SocketsInitialize() Then
    GetIPAddress = ""
    Exit Function
End If
 
If gethostname(sHostName, 256) = SOCKET_ERROR Then
    GetIPAddress = ""
    MsgBox "Windows Sockets error " & Str$(WSAGetLastError()) & " has occurred. Unable to successfully get Host Name."
    SocketsCleanup
    Exit Function
End If
 
sHostName = Trim$(sHostName)
lpHost = gethostbyname(sHostName)
 
If lpHost = 0 Then
    GetIPAddress = ""
    MsgBox "Windows Sockets are not responding. " & "Unable to successfully get Host Name."
    SocketsCleanup
    Exit Function
End If
 
CopyMemory HOST, lpHost, Len(HOST)
CopyMemory dwIPAddr, HOST.hAddrList, 4
 
ReDim tmpIPAddr(1 To HOST.hLen)
 
CopyMemory tmpIPAddr(1), dwIPAddr, HOST.hLen
 
For i = 1 To HOST.hLen
    sIPAddr = sIPAddr & tmpIPAddr(i) & "."
Next
 
GetIPAddress = Mid$(sIPAddr, 1, Len(sIPAddr) - 1)
 
SocketsCleanup
 
End Function
 
 
Public Function GetIPHostName() As String
Dim sHostName As String * 256
 
If Not SocketsInitialize() Then
    GetIPHostName = ""
    Exit Function
End If
 
If gethostname(sHostName, 256) = SOCKET_ERROR Then
    GetIPHostName = ""
    MsgBox "Windows Sockets error " & Str$(WSAGetLastError()) & " has occurred. Unable to successfully get Host Name."
    SocketsCleanup
    Exit Function
End If
 
GetIPHostName = Left$(sHostName, InStr(sHostName, Chr(0)) - 1)
 
SocketsCleanup
 
End Function
 
 
Public Function HiByte(ByVal wParam As Integer)
HiByte = wParam \ &H100 And &HFF&
End Function
 
 
Public Function LoByte(ByVal wParam As Integer)
LoByte = wParam And &HFF&
End Function
 
 
Public Sub SocketsCleanup()
If WSACleanup() <> ERROR_SUCCESS Then
    MsgBox "Socket error occurred in Cleanup."
End If
End Sub
 
 
Public Function SocketsInitialize() As Boolean
Dim WSAD As WSADATA
Dim sLoByte As String
Dim sHiByte As String
 
If WSAStartup(WS_VERSION_REQD, WSAD) <> ERROR_SUCCESS Then
    MsgBox "The 32-bit Windows Socket is not responding."
    SocketsInitialize = False
    Exit Function
End If
 
If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then
    MsgBox "This application requires a minimum of " & CStr(MIN_SOCKETS_REQD) & " supported sockets."
    SocketsInitialize = False
    Exit Function
End If
 
If LoByte(WSAD.wVersion) < WS_VERSION_MAJOR Or (LoByte(WSAD.wVersion) = WS_VERSION_MAJOR And HiByte(WSAD.wVersion) < WS_VERSION_MINOR) Then
    sHiByte = CStr(HiByte(WSAD.wVersion))
    sLoByte = CStr(LoByte(WSAD.wVersion))
    MsgBox "Sockets version " & sLoByte & "." & sHiByte & " is not supported by 32-bit Windows Sockets."
    SocketsInitialize = False
    Exit Function
End If
 
SocketsInitialize = True
 
End Function


   
, :
IP
Rat!
25.11.2012, 17:43     Visual Basic 6.0 #8
33- ""


      Visual Basic 6.0


70_3dmaze.rar

34- Microsoft Access

MS Access.

Visual Basic
1
2
3
4
5
6
7
8
9
10
Private Sub Command1_Click()
Dim myobj As New Access.Application
'îòêðûâ*åì ÁÄ, â êîò. **õîäèòñÿ îò÷¸ò
myobj.OpenCurrentDatabase ("D:\Database2.mdb")
'ç*ïóñê*åì â ÁÄ ôîðìó, êîò. â ñâîþ î÷åðåäü ç*ïóñòèò îò÷¸ò
myobj.DoCmd.OpenReport "Ò*áëèö*1", acViewReport
'âûâîäèì ïðèëîæå*èå ** ýêð**
 
myobj.Visible = True
End Sub


35- API

6 : Command1, Command2 Command6

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
'This project needs 6 command buttons
Option Explicit
Const FW_NORMAL = 400
Const DEFAULT_CHARSET = 1
Const OUT_DEFAULT_PRECIS = 0
Const CLIP_DEFAULT_PRECIS = 0
Const DEFAULT_QUALITY = 0
Const DEFAULT_PITCH = 0
Const FF_ROMAN = 16
Const CF_PRINTERFONTS = &H2
Const CF_SCREENFONTS = &H1
Const CF_BOTH = (CF_SCREENFONTS Or CF_PRINTERFONTS)
Const CF_EFFECTS = &H100&
Const CF_FORCEFONTEXIST = &H10000
Const CF_INITTOLOGFONTSTRUCT = &H40&
Const CF_LIMITSIZE = &H2000&
Const REGULAR_FONTTYPE = &H400
Const LF_FACESIZE = 32
Const CCHDEVICENAME = 32
Const CCHFORMNAME = 32
Const GMEM_MOVEABLE = &H2
Const GMEM_ZEROINIT = &H40
Const DM_DUPLEX = &H1000&
Const DM_ORIENTATION = &H1&
Const PD_PRINTSETUP = &H40
Const PD_DISABLEPRINTTOFILE = &H80000
Private Type POINTAPI
    x As Long
    y As Long
End Type
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private Type OPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type
Private Type PAGESETUPDLG
    lStructSize As Long
    hwndOwner As Long
    hDevMode As Long
    hDevNames As Long
    flags As Long
    ptPaperSize As POINTAPI
    rtMinMargin As RECT
    rtMargin As RECT
    hInstance As Long
    lCustData As Long
    lpfnPageSetupHook As Long
    lpfnPagePaintHook As Long
    lpPageSetupTemplateName As String
    hPageSetupTemplate As Long
End Type
Private Type CHOOSECOLOR
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    rgbResult As Long
    lpCustColors As String
    flags As Long
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type
Private Type LOGFONT
        lfHeight As Long
        lfWidth As Long
        lfEscapement As Long
        lfOrientation As Long
        lfWeight As Long
        lfItalic As Byte
        lfUnderline As Byte
        lfStrikeOut As Byte
        lfCharSet As Byte
        lfOutPrecision As Byte
        lfClipPrecision As Byte
        lfQuality As Byte
        lfPitchAndFamily As Byte
        lfFaceName As String * 31
End Type
Private Type CHOOSEFONT
        lStructSize As Long
        hwndOwner As Long          '  caller's window handle
        hDC As Long                '  printer DC/IC or NULL
        lpLogFont As Long          '  ptr. to a LOGFONT struct
        iPointSize As Long         '  10 * size in points of selected font
        flags As Long              '  enum. type flags
        rgbColors As Long          '  returned text color
        lCustData As Long          '  data passed to hook fn.
        lpfnHook As Long           '  ptr. to hook function
        lpTemplateName As String     '  custom template name
        hInstance As Long          '  instance handle of.EXE that
                                       '    contains cust. dlg. template
        lpszStyle As String          '  return the style field here
                                       '  must be LF_FACESIZE or bigger
        nFontType As Integer          '  same value reported to the EnumFonts
                                       '    call back with the extra FONTTYPE_
                                       '    bits added
        MISSING_ALIGNMENT As Integer
        nSizeMin As Long           '  minimum pt size allowed &
        nSizeMax As Long           '  max pt size allowed if
                                       '    CF_LIMITSIZE is used
End Type
Private Type PRINTDLG_TYPE
    lStructSize As Long
    hwndOwner As Long
    hDevMode As Long
    hDevNames As Long
    hDC As Long
    flags As Long
    nFromPage As Integer
    nToPage As Integer
    nMinPage As Integer
    nMaxPage As Integer
    nCopies As Integer
    hInstance As Long
    lCustData As Long
    lpfnPrintHook As Long
    lpfnSetupHook As Long
    lpPrintTemplateName As String
    lpSetupTemplateName As String
    hPrintTemplate As Long
    hSetupTemplate As Long
End Type
Private Type DEVNAMES_TYPE
    wDriverOffset As Integer
    wDeviceOffset As Integer
    wOutputOffset As Integer
    wDefault As Integer
    extra As String * 100
End Type
Private Type DEVMODE_TYPE
    dmDeviceName As String * CCHDEVICENAME
    dmSpecVersion As Integer
    dmDriverVersion As Integer
    dmSize As Integer
    dmDriverExtra As Integer
    dmFields As Long
    dmOrientation As Integer
    dmPaperSize As Integer
    dmPaperLength As Integer
    dmPaperWidth As Integer
    dmScale As Integer
    dmCopies As Integer
    dmDefaultSource As Integer
    dmPrintQuality As Integer
    dmColor As Integer
    dmDuplex As Integer
    dmYResolution As Integer
    dmTTOption As Integer
    dmCollate As Integer
    dmFormName As String * CCHFORMNAME
    dmUnusedPadding As Integer
    dmBitsPerPel As Integer
    dmPelsWidth As Long
    dmPelsHeight As Long
    dmDisplayFlags As Long
    dmDisplayFrequency As Long
End Type
Private Declare Function CHOOSECOLOR Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As CHOOSECOLOR) As Long
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function PrintDialog Lib "comdlg32.dll" Alias "PrintDlgA" (pPrintdlg As PRINTDLG_TYPE) As Long
Private Declare Function PAGESETUPDLG Lib "comdlg32.dll" Alias "PageSetupDlgA" (pPagesetupdlg As PAGESETUPDLG) As Long
Private Declare Function CHOOSEFONT Lib "comdlg32.dll" Alias "ChooseFontA" (pChoosefont As CHOOSEFONT) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Dim OFName As OPENFILENAME
Dim CustomColors() As Byte
Private Sub Command1_Click()
    Dim sFile As String
    sFile = ShowOpen
    If sFile <> "" Then
        MsgBox "You chose this file: " + sFile
    Else
        MsgBox "You pressed cancel"
    End If
End Sub
Private Sub Command2_Click()
    Dim sFile As String
    sFile = ShowSave
    If sFile <> "" Then
        MsgBox "You chose this file: " + sFile
    Else
        MsgBox "You pressed cancel"
    End If
End Sub
Private Sub Command3_Click()
    Dim NewColor As Long
    NewColor = ShowColor
    If NewColor <> -1 Then
        Me.BackColor = NewColor
    Else
        MsgBox "You chose cancel"
    End If
End Sub
Private Sub Command4_Click()
    MsgBox ShowFont
End Sub
Private Sub Command5_Click()
    ShowPrinter Me
End Sub
Private Sub Command6_Click()
    ShowPageSetupDlg
End Sub
Private Sub Form_Load()
    'KPD-Team 1998
    'URL: [url]http://www.allapi.net/[/url]
    'E-Mail: [email]KPDTeam@Allapi.net[/email]
    'Redim the variables to store the cutstom colors
    ReDim CustomColors(0 To 16 * 4 - 1) As Byte
    Dim i As Integer
    For i = LBound(CustomColors) To UBound(CustomColors)
        CustomColors(i) = 0
    Next i
    'Set the captions
    Command1.Caption = "ShowOpen"
    Command2.Caption = "ShowSave"
    Command3.Caption = "ShowColor"
    Command4.Caption = "ShowFont"
    Command5.Caption = "ShowPrinter"
    Command6.Caption = "ShowPageSetupDlg"
End Sub
Private Function ShowColor() As Long
    Dim cc As CHOOSECOLOR
    Dim Custcolor(16) As Long
    Dim lReturn As Long
 
    'set the structure size
    cc.lStructSize = Len(cc)
    'Set the owner
    cc.hwndOwner = Me.hWnd
    'set the application's instance
    cc.hInstance = App.hInstance
    'set the custom colors (converted to Unicode)
    cc.lpCustColors = StrConv(CustomColors, vbUnicode)
    'no extra flags
    cc.flags = 0
 
    'Show the 'Select Color'-dialog
    If CHOOSECOLOR(cc) <> 0 Then
        ShowColor = cc.rgbResult
        CustomColors = StrConv(cc.lpCustColors, vbFromUnicode)
    Else
        ShowColor = -1
    End If
End Function
Private Function ShowOpen() As String
    'Set the structure size
    OFName.lStructSize = Len(OFName)
    'Set the owner window
    OFName.hwndOwner = Me.hWnd
    'Set the application's instance
    OFName.hInstance = App.hInstance
    'Set the filet
    OFName.lpstrFilter = "Text Files (*.txt)" + Chr$(0) + "*.txt" + Chr$(0) + "All Files (*.*)" + Chr$(0) + "*.*" + Chr$(0)
    'Create a buffer
    OFName.lpstrFile = Space$(254)
    'Set the maximum number of chars
    OFName.nMaxFile = 255
    'Create a buffer
    OFName.lpstrFileTitle = Space$(254)
    'Set the maximum number of chars
    OFName.nMaxFileTitle = 255
    'Set the initial directory
    OFName.lpstrInitialDir = "C:\"
    'Set the dialog title
    OFName.lpstrTitle = "Open File - KPD-Team 1998"
    'no extra flags
    OFName.flags = 0
 
    'Show the 'Open File'-dialog
    If GetOpenFileName(OFName) Then
        ShowOpen = Trim$(OFName.lpstrFile)
    Else
        ShowOpen = ""
    End If
End Function
Private Function ShowFont() As String
    Dim cf As CHOOSEFONT, lfont As LOGFONT, hMem As Long, pMem As Long
    Dim fontname As String, retval As Long
    lfont.lfHeight = 0  ' determine default height
    lfont.lfWidth = 0  ' determine default width
    lfont.lfEscapement = 0  ' angle between baseline and escapement vector
    lfont.lfOrientation = 0  ' angle between baseline and orientation vector
    lfont.lfWeight = FW_NORMAL  ' normal weight i.e. not bold
    lfont.lfCharSet = DEFAULT_CHARSET  ' use default character set
    lfont.lfOutPrecision = OUT_DEFAULT_PRECIS  ' default precision mapping
    lfont.lfClipPrecision = CLIP_DEFAULT_PRECIS  ' default clipping precision
    lfont.lfQuality = DEFAULT_QUALITY  ' default quality setting
    lfont.lfPitchAndFamily = DEFAULT_PITCH Or FF_ROMAN  ' default pitch, proportional with serifs
    lfont.lfFaceName = "Times New Roman" & vbNullChar  ' string must be null-terminated
    ' Create the memory block which will act as the LOGFONT structure buffer.
    hMem = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(lfont))
    pMem = GlobalLock(hMem)  ' lock and get pointer
    CopyMemory ByVal pMem, lfont, Len(lfont)  ' copy structure's contents into block
    ' Initialize dialog box: Screen and printer fonts, point size between 10 and 72.
    cf.lStructSize = Len(cf)  ' size of structure
    cf.hwndOwner = Form1.hWnd  ' window Form1 is opening this dialog box
    cf.hDC = Printer.hDC  ' device context of default printer (using VB's mechanism)
    cf.lpLogFont = pMem   ' pointer to LOGFONT memory block buffer
    cf.iPointSize = 120  ' 12 point font (in units of 1/10 point)
    cf.flags = CF_BOTH Or CF_EFFECTS Or CF_FORCEFONTEXIST Or CF_INITTOLOGFONTSTRUCT Or CF_LIMITSIZE
    cf.rgbColors = RGB(0, 0, 0)  ' black
    cf.nFontType = REGULAR_FONTTYPE  ' regular font type i.e. not bold or anything
    cf.nSizeMin = 10  ' minimum point size
    cf.nSizeMax = 72  ' maximum point size
    ' Now, call the function.  If successful, copy the LOGFONT structure back into the structure
    ' and then print out the attributes we mentioned earlier that the user selected.
    retval = CHOOSEFONT(cf)  ' open the dialog box
    If retval <> 0 Then  ' success
        CopyMemory lfont, ByVal pMem, Len(lfont)  ' copy memory back
        ' Now make the fixed-length string holding the font name into a "normal" string.
        ShowFont = Left(lfont.lfFaceName, InStr(lfont.lfFaceName, vbNullChar) - 1)
        Debug.Print  ' end the line
    End If
    ' Deallocate the memory block we created earlier.  Note that this must
    ' be done whether the function succeeded or not.
    retval = GlobalUnlock(hMem)  ' destroy pointer, unlock block
    retval = GlobalFree(hMem)  ' free the allocated memory
End Function
Private Function ShowSave() As String
    'Set the structure size
    OFName.lStructSize = Len(OFName)
    'Set the owner window
    OFName.hwndOwner = Me.hWnd
    'Set the application's instance
    OFName.hInstance = App.hInstance
    'Set the filet
    OFName.lpstrFilter = "Text Files (*.txt)" + Chr$(0) + "*.txt" + Chr$(0) + "All Files (*.*)" + Chr$(0) + "*.*" + Chr$(0)
    'Create a buffer
    OFName.lpstrFile = Space$(254)
    'Set the maximum number of chars
    OFName.nMaxFile = 255
    'Create a buffer
    OFName.lpstrFileTitle = Space$(254)
    'Set the maximum number of chars
    OFName.nMaxFileTitle = 255
    'Set the initial directory
    OFName.lpstrInitialDir = "C:\"
    'Set the dialog title
    OFName.lpstrTitle = "Save File - KPD-Team 1998"
    'no extra flags
    OFName.flags = 0
 
    'Show the 'Save File'-dialog
    If GetSaveFileName(OFName) Then
        ShowSave = Trim$(OFName.lpstrFile)
    Else
        ShowSave = ""
    End If
End Function
Private Function ShowPageSetupDlg() As Long
    Dim m_PSD As PAGESETUPDLG
    'Set the structure size
    m_PSD.lStructSize = Len(m_PSD)
    'Set the owner window
    m_PSD.hwndOwner = Me.hWnd
    'Set the application instance
    m_PSD.hInstance = App.hInstance
    'no extra flags
    m_PSD.flags = 0
 
    'Show the pagesetup dialog
    If PAGESETUPDLG(m_PSD) Then
        ShowPageSetupDlg = 0
    Else
        ShowPageSetupDlg = -1
    End If
End Function
Public Sub ShowPrinter(frmOwner As Form, Optional PrintFlags As Long)
    '-> Code by Donald Grover
    Dim PrintDlg As PRINTDLG_TYPE
    Dim DevMode As DEVMODE_TYPE
    Dim DevName As DEVNAMES_TYPE
 
    Dim lpDevMode As Long, lpDevName As Long
    Dim bReturn As Integer
    Dim objPrinter As Printer, NewPrinterName As String
 
    ' Use PrintDialog to get the handle to a memory
    ' block with a DevMode and DevName structures
 
    PrintDlg.lStructSize = Len(PrintDlg)
    PrintDlg.hwndOwner = frmOwner.hWnd
 
    PrintDlg.flags = PrintFlags
    On Error Resume Next
    'Set the current orientation and duplex setting
    DevMode.dmDeviceName = Printer.DeviceName
    DevMode.dmSize = Len(DevMode)
    DevMode.dmFields = DM_ORIENTATION Or DM_DUPLEX
    DevMode.dmPaperWidth = Printer.Width
    DevMode.dmOrientation = Printer.Orientation
    DevMode.dmPaperSize = Printer.PaperSize
    DevMode.dmDuplex = Printer.Duplex
    On Error GoTo 0
 
    'Allocate memory for the initialization hDevMode structure
    'and copy the settings gathered above into this memory
    PrintDlg.hDevMode = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(DevMode))
    lpDevMode = GlobalLock(PrintDlg.hDevMode)
    If lpDevMode > 0 Then
        CopyMemory ByVal lpDevMode, DevMode, Len(DevMode)
        bReturn = GlobalUnlock(PrintDlg.hDevMode)
    End If
 
    'Set the current driver, device, and port name strings
    With DevName
        .wDriverOffset = 8
        .wDeviceOffset = .wDriverOffset + 1 + Len(Printer.DriverName)
        .wOutputOffset = .wDeviceOffset + 1 + Len(Printer.Port)
        .wDefault = 0
    End With
 
    With Printer
        DevName.extra = .DriverName & Chr(0) & .DeviceName & Chr(0) & .Port & Chr(0)
    End With
 
    'Allocate memory for the initial hDevName structure
    'and copy the settings gathered above into this memory
    PrintDlg.hDevNames = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(DevName))
    lpDevName = GlobalLock(PrintDlg.hDevNames)
    If lpDevName > 0 Then
        CopyMemory ByVal lpDevName, DevName, Len(DevName)
        bReturn = GlobalUnlock(lpDevName)
    End If
 
    'Call the print dialog up and let the user make changes
    If PrintDialog(PrintDlg) <> 0 Then
 
        'First get the DevName structure.
        lpDevName = GlobalLock(PrintDlg.hDevNames)
        CopyMemory DevName, ByVal lpDevName, 45
        bReturn = GlobalUnlock(lpDevName)
        GlobalFree PrintDlg.hDevNames
 
        'Next get the DevMode structure and set the printer
        'properties appropriately
        lpDevMode = GlobalLock(PrintDlg.hDevMode)
        CopyMemory DevMode, ByVal lpDevMode, Len(DevMode)
        bReturn = GlobalUnlock(PrintDlg.hDevMode)
        GlobalFree PrintDlg.hDevMode
        NewPrinterName = UCase$(Left(DevMode.dmDeviceName, InStr(DevMode.dmDeviceName, Chr$(0)) - 1))
        If Printer.DeviceName <> NewPrinterName Then
            For Each objPrinter In Printers
                If UCase$(objPrinter.DeviceName) = NewPrinterName Then
                    Set Printer = objPrinter
                    'set printer toolbar name at this point
                End If
            Next
        End If
 
        On Error Resume Next
        'Set printer object properties according to selections made
        'by user
        Printer.Copies = DevMode.dmCopies
        Printer.Duplex = DevMode.dmDuplex
        Printer.Orientation = DevMode.dmOrientation
        Printer.PaperSize = DevMode.dmPaperSize
        Printer.PrintQuality = DevMode.dmPrintQuality
        Printer.ColorMode = DevMode.dmColor
        Printer.PaperBin = DevMode.dmDefaultSource
        On Error GoTo 0
    End If
End Sub


36-

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
Const ERROR_ACCESS_DENIED = 8&
 
Private Const HKEY_CLASSES_ROOT = &H80000000
Private Const MAX_PATH = 260&
Private Const REG_SZ = 1
 
Private Sub Command1_Click()
    Dim sKeyName As String
    Dim sKeyValue As String
    Dim ret&
    Dim lphKey&
    
    'Ñîçä**èå êëþ÷* "MyApp".
    sKeyName = "MyApp"
    sKeyValue = "My Application"
    ret& = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName, lphKey&)
    ret& = RegSetValue&(lphKey&, "", REG_SZ, sKeyValue, 0&)
    'Ñîçä**èå êëþ÷*, ñâÿç***îãî ñ "MyApp".
    sKeyName = ".BAR"
    sKeyValue = "MyApp"
    ret& = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName, lphKey&)
    ret& = RegSetValue&(lphKey&, "", REG_SZ, sKeyValue, 0&)
    'Êîìì**ä**ÿ ëè*èÿ äëÿ ïðèëîæå*èÿ"MyApp".
    sKeyName = "MyApp"
    sKeyValue = "D:\Basic\MyProjects\SharPad\SharPad.exe %1"
    ret& = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName, lphKey&)
    ret& = RegSetValue&(lphKey&, "shell\open\command", REG_SZ, sKeyValue, MAX_PATH)
End Sub


37- TreeView

TreeView TreeView1, . , "TreeView".

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
Dim Categories As Node
 
Private Sub Form_Load()
With TreeView1.Nodes
    Set cat = .Add(, , "root", "  ")
    Set cat = .Add("root", tvwChild, , "1 ")
    Set cat = .Add("root", tvwChild, , "2 ")
    Set cat = .Add("root", tvwChild, , "3 ")
    
    Set cat = .Add(, , "root1", "  ")
    Set cat = .Add("root1", tvwChild, , "1    ")
    Set cat = .Add("root1", tvwChild, , "2    ")
    Set cat = .Add("root1", tvwChild, , "3    ")
End With
End Sub
 
Private Sub TreeView1_NodeClick(ByVal Node As MSComctlLib.Node)
Select Case Node
    Case Is = "1 "
        MsgBox "  1 "
    Case Is = "2 "
        MsgBox "  2 "
    Case Is = "3 "
        MsgBox "  3 "
End Select
End Sub

.

46-
X Y

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
'Ñòðîèò ãð*ôèê ëþáîé ô-öèè
'Àâòîì*òè÷åñêè ïîäáèð*åò ì*ñøò*á ïî X è Y
Option Explicit
 
Private Sub Form_Load()
  Dim MinX As Double
  Dim MaxX As Double
  Dim MinY As Double
  Dim MaxY As Double
  Dim dx As Double
  Dim x1 As Double
  Dim x2 As Double
  Dim y1 As Double
  Dim y2 As Double
 
  ScaleMode = vbPixels
  BackColor = RGB(255, 255, 255)
  Show
 
  'Çäåñü ç*ä*éòå äè*ï*çî* ïî X
  MinX = -3 'ìè*èìóì
  MaxX = 3  'ì*êñèìóì
  dx = (MaxX - MinX) / ScaleWidth 'Ø*ã X/Pixel
  'Èùåì ìè*èì*ëü*îå è ì*êñèì*ëü*îå ç**÷å*èÿ ô-öèè â äè*ï*çî*å
  MinY = F(MinX)
  MaxY = F(MinX)
  For x1 = MinX To MaxX Step dx
    If MinY > F(x1) Then MinY = F(x1)
    If MaxY < F(x1) Then MaxY = F(x1)
  Next x1
  'Ïåðå**ñòð*èâ*åì ScaleMode îê**
  ScaleLeft = MinX
  ScaleWidth = MaxX - MinX
  ScaleTop = MaxY
  ScaleHeight = MinY - MaxY
  'Îòîáð*æ*åì îñè êîîðäè**ò
  Line (MinX, 0)-(MaxX, 0), RGB(0, 0, 0)
  Line (0, MinY)-(0, MaxY), RGB(0, 0, 0)
  'Ñòðîèì ãð*ôèê
  For x1 = MinX To MaxX Step dx
    x2 = x1 + dx
    y1 = F(x1)
    y2 = F(x2)
    Line (x1, y1)-(x2, y2), RGB(0, 0, 255)
  Next x1
End Sub
 
'Ç*ä*éòå çäåñü ñâîþ ô-öèþ
Private Function F(ByVal x As Double) As Double
  F = 1 / (x ^ 2 + 2 * x + 2) - 0.25
End Function
Denri
101 / 52 / 2
: 10.07.2012
: 343
: 2
25.11.2012, 22:49     Visual Basic 6.0 #9
39-

.
Visual Basic
1
2
3
4
5
6
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
End Sub
, .
, :
Visual Basic
1
2
3
4
5
6
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(0, 0, 600, 450), True
End Sub
, .

, . .
( - Timer1), Interval=10. , . . .
...
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
Private Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As POINTAPI, ByVal nCount As Long, ByVal nPolyFillMode 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 Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
 
Private Type POINTAPI
   X As Long
   Y As Long
End Type
 
Private rgnPts() As POINTAPI
 
Private Const SM_CYCAPTION = 4
Private Const SM_CXFRAME = 32
Private Const SM_CYFRAME = 33
Private Const nPts& = 36
 
 
Private Sub Form_Load()
   
   m_FillMode = ALTERNATE
 
   With Me
      .ScaleMode = vbPixels
      .Width = Screen.Width \ 2
      .Height = .Width
      .Move (Screen.Width - .Width) \ 2, (Screen.Height - .Height) \ 2
      .Icon = Nothing
   End With
 
End Sub
 
 
Private Static Sub Timer1_Timer()
 
   Dim nRet As Long
   Dim hRgn As Long
 
   CalcRgnPoints
 
   hRgn = CreatePolygonRgn(rgnPts(0), nPts, m_FillMode)
   nRet = SetWindowRgn(Me.hWnd, hRgn, True)
 
End Sub
 
 
Private Static Sub CalcRgnPoints()
 
   ReDim scnPts(0 To nPts) As POINTAPI
   ReDim rgnPts(0 To nPts) As POINTAPI
 
   Dim offset As Long
   Dim angle As Long
   Dim theta As Double
   Dim radius1 As Long
   Dim radius2 As Long
   Dim x1 As Long
   Dim y1 As Long
   Dim xOff As Long
   Dim yOff As Long
   Dim n As Long
 
Const Pi# = 3.14159265358979
Const DegToRad# = Pi / 180
 
'  
 
x1 = Me.ScaleWidth \ 2
y1 = Me.ScaleHeight \ 2
 
   If x1 > y1 Then
      radius1 = y1 * 0.85
   Else
      radius1 = x1 * 0.85
   End If
 
   radius2 = radius1 * 0.5
 
'   
 
xOff = GetSystemMetrics(SM_CXFRAME)
 
   yOff = GetSystemMetrics(SM_CYFRAME) + GetSystemMetrics(SM_CYCAPTION)
 
' 10   
 
n = 0
 
   For angle = 0 To 360 Step 10
 
      theta = (angle - offset) * DegToRad
 
'   
 
If n Mod 2 Then
         scnPts(n).X = x1 + (radius1 * (Sin(theta)))
         scnPts(n).Y = y1 + (radius1 * (Cos(theta)))
      Else
         scnPts(n).X = x1 + (radius2 * (Sin(theta)))
         scnPts(n).Y = y1 + (radius2 * (Cos(theta)))
      End If
 
rgnPts(n).X = scnPts(n).X + xOff
 
      rgnPts(n).Y = scnPts(n).Y + yOff
      n = n + 1
 
   Next angle
 
   offset = (offset + 2) Mod 360
 
End Sub

.
Cricket93
143 / 44 / 1
: 06.11.2012
: 283
26.11.2012, 03:25     Visual Basic 6.0 #10
38- " 2"


      Visual Basic 6.0
 : rar 2.rar (4.6 , 643 )
Denri
101 / 52 / 2
: 10.07.2012
: 343
: 2
26.11.2012, 08:22     Visual Basic 6.0 #11
40-
, , . :

...

Visual Basic
1
2
3
4
5
Dim X As String * 3 '  X  3 
Private Sub Form_Load()
X = "123456"
MsgBox X ' 123
End Sub
anny05
D
1359 / 110 / 19
: 14.10.2012
: 100
26.11.2012, 23:47     Visual Basic 6.0 #12
41- - MD5

1 () - API (cryptdll).
: Vista ntdll.dll ( ).

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
Option Explicit
 
Private Type MD5_CTX
  i(1 To 2) As Long
  buf(1 To 4) As Long
  inp(1 To 64) As Byte
  digest(1 To 16) As Byte
End Type
 
Private Declare Sub MD5Init Lib "cryptdll" (Context As MD5_CTX)
Private Declare Sub MD5Update Lib "cryptdll" (Context As MD5_CTX, ByVal strInput As String, ByVal lLen As 
 
Long)
Private Declare Sub MD5Final Lib "cryptdll" (Context As MD5_CTX)
 
Private Sub Command1_Click()
    MsgBox CalcMD5("C:\Win32_BIOS.txt")
    MsgBox CalcMD5_String("C:\Win32_BIOS.txt")
End Sub
 
Private Function CalcMD5_String(strBuffer As String) As String
    Dim myContext As MD5_CTX
    Dim result As String
    Dim lp As Long
    Dim MD5 As String
 
    MD5Init myContext
    MD5Update myContext, strBuffer, Len(strBuffer)
    MD5Final myContext
 
    result = StrConv(myContext.digest, vbUnicode)
    
    For lp = 1 To Len(result)
            CalcMD5_String = CalcMD5_String & Right("00" & Hex(Asc(Mid(result, lp, 1))), 2)
    Next
End Function
 
Private Function CalcMD5(strFilename As String) As String
    Dim strBuffer As String
    Dim myContext As MD5_CTX
    Dim result As String
    Dim lp As Long
    Dim MD5 As String
 
    strBuffer = Space(FileLen(strFilename))
 
    Open strFilename For Binary Access Read As #1
        Get #1, , strBuffer
    Close #1
 
    MD5Init myContext
    MD5Update myContext, strBuffer, Len(strBuffer)
    MD5Final myContext
 
    result = StrConv(myContext.digest, vbUnicode)
    
    For lp = 1 To Len(result)
            CalcMD5 = CalcMD5 & Right("00" & Hex(Asc(Mid(result, lp, 1))), 2)
    Next
    
End Function


2 (). MD5 VB/VBA.

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
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "MD5_Hash"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
 
Option Explicit
 
'/******************************************************************************
' *  Copyright (C) 2000 by Robert Hubley.                                      *
' *  All rights reserved.                                                      *
' *                                                                            *
' *  This software is provided ``AS IS'' and any express or implied            *
' *  warranties, including, but not limited to, the implied warranties of      *
' *  merchantability and fitness for a particular purpose, are disclaimed.     *
' *  In no event shall the authors be liable for any direct, indirect,         *
' *  incidental, special, exemplary, or consequential damages (including, but  *
' *  not limited to, procurement of substitute goods or services; loss of use, *
' *  data, or profits; or business interruption) however caused and on any     *
' *  theory of liability, whether in contract, strict liability, or tort       *
' *  (including negligence or otherwise) arising in any way out of the use of  *
' *  this software, even if advised of the possibility of such damage.         *
' *                                                                            *
' ******************************************************************************
'
'  CLASS: MD5
'
'  DESCRIPTION:
'     This is a class which encapsulates a set of MD5 Message Digest functions.
'     MD5 algorithm produces a 128 bit digital fingerprint (signature) from an
'     dataset of arbitrary length.  For details see RFC 1321 (summarized below).
'     This implementation is derived from the RSA Data Security, Inc. MD5 Message-Digest
'     algorithm reference implementation (originally written in C)
'
'  AUTHOR:
'     Robert M. Hubley 12/1999
'
'
'  NOTES:
'      Network Working Group                                    R. Rivest
'      Request for Comments: 1321     MIT Laboratory for Computer Science
'                                             and RSA Data Security, Inc.
'                                                              April 1992
'
'
'                           The MD5 Message-Digest Algorithm
'
'      Summary
'
'         This document describes the MD5 message-digest algorithm. The
'         algorithm takes as input a message of arbitrary length and produces
'         as output a 128-bit "fingerprint" or "message digest" of the input.
'         It is conjectured that it is computationally infeasible to produce
'         two messages having the same message digest, or to produce any
'         message having a given prespecified target message digest. The MD5
'         algorithm is intended for digital signature applications, where a
'         large file must be "compressed" in a secure manner before being
'         encrypted with a private (secret) key under a public-key cryptosystem
'         such as RSA.
'
'         The MD5 algorithm is designed to be quite fast on 32-bit machines. In
'         addition, the MD5 algorithm does not require any large substitution
'         tables; the algorithm can be coded quite compactly.
'
'         The MD5 algorithm is an extension of the MD4 message-digest algorithm
'         1,2]. MD5 is slightly slower than MD4, but is more "conservative" in
'         design. MD5 was designed because it was felt that MD4 was perhaps
'         being adopted for use more quickly than justified by the existing
'         critical review; because MD4 was designed to be exceptionally fast,
'         it is "at the edge" in terms of risking successful cryptanalytic
'         attack. MD5 backs off a bit, giving up a little in speed for a much
'         greater likelihood of ultimate security. It incorporates some
'         suggestions made by various reviewers, and contains additional
'         optimizations. The MD5 algorithm is being placed in the public domain
'         for review and possible adoption as a standard.
'
'         RFC Author:
'         Ronald L.Rivest
'         Massachusetts Institute of Technology
'         Laboratory for Computer Science
'         NE43 -324545    Technology Square
'         Cambridge, MA  02139-1986
'         Phone: (617) 253-5880
'         EMail:    Rivest@ theory.lcs.mit.edu
'
'
'
'  CHANGE HISTORY:
'
'     0.1.0  RMH    1999/12/29      Original version
'
'
 
 
'=
'= Class Constants
'=
Private Const OFFSET_4 = 4294967296#
Private Const MAXINT_4 = 2147483647
 
Private Const S11 = 7
Private Const S12 = 12
Private Const S13 = 17
Private Const S14 = 22
Private Const S21 = 5
Private Const S22 = 9
Private Const S23 = 14
Private Const S24 = 20
Private Const S31 = 4
Private Const S32 = 11
Private Const S33 = 16
Private Const S34 = 23
Private Const S41 = 6
Private Const S42 = 10
Private Const S43 = 15
Private Const S44 = 21
 
 
'=
'= Class Variables
'=
Private state(4) As Long
Private ByteCounter As Long
Private ByteBuffer(63) As Byte
 
 
'=
'= Class Properties
'=
Property Get RegisterA() As String
    RegisterA = state(1)
End Property
 
Property Get RegisterB() As String
    RegisterB = state(2)
End Property
 
Property Get RegisterC() As String
    RegisterC = state(3)
End Property
 
Property Get RegisterD() As String
    RegisterD = state(4)
End Property
 
 
'=
'= Class Functions
'=
 
'
' Function to quickly digest a file into a hex string
'
Public Function DigestFileToHexStr(FileName As String) As String
    Open FileName For Binary Access Read As #1
    MD5Init
    Do While Not EOF(1)
        Get #1, , ByteBuffer
        If Loc(1) < LOF(1) Then
            ByteCounter = ByteCounter + 64
            MD5Transform ByteBuffer
        End If
    Loop
    ByteCounter = ByteCounter + (LOF(1) Mod 64)
    Close #1
    MD5Final
    DigestFileToHexStr = GetValues
End Function
 
'
' Function to digest a text string and output the result as a string
' of hexadecimal characters.
'
Public Function DigestStrToHexStr(SourceString As String) As String
    MD5Init
    MD5Update Len(SourceString), StringToArray(SourceString)
    MD5Final
    DigestStrToHexStr = GetValues
End Function
 
'
' A utility function which converts a string into an array of
' bytes.
'
Private Function StringToArray(InString As String) As Byte()
    Dim i As Integer
    Dim bytBuffer() As Byte
    ReDim bytBuffer(Len(InString))
    For i = 0 To Len(InString) - 1
        bytBuffer(i) = Asc(Mid(InString, i + 1, 1))
    Next i
    StringToArray = bytBuffer
End Function
 
'
' Concatenate the four state vaules into one string
'
Public Function GetValues() As String
    GetValues = LongToString(state(1)) & LongToString(state(2)) & LongToString(state(3)) & 
 
LongToString(state(4))
End Function
 
'
' Convert a Long to a Hex string
'
Private Function LongToString(Num As Long) As String
        Dim a As Byte
        Dim b As Byte
        Dim c As Byte
        Dim d As Byte
        
        a = Num And &HFF&
        If a < 16 Then
            LongToString = "0" & Hex(a)
        Else
            LongToString = Hex(a)
        End If
               
        b = (Num And &HFF00&) \ 256
        If b < 16 Then
            LongToString = LongToString & "0" & Hex(b)
        Else
            LongToString = LongToString & Hex(b)
        End If
        
        c = (Num And &HFF0000) \ 65536
        If c < 16 Then
            LongToString = LongToString & "0" & Hex(c)
        Else
            LongToString = LongToString & Hex(c)
        End If
       
        If Num < 0 Then
            d = ((Num And &H7F000000) \ 16777216) Or &H80&
        Else
            d = (Num And &HFF000000) \ 16777216
        End If
        
        If d < 16 Then
            LongToString = LongToString & "0" & Hex(d)
        Else
            LongToString = LongToString & Hex(d)
        End If
    
End Function
 
'
' Initialize the class
'   This must be called before a digest calculation is started
'
Public Sub MD5Init()
    ByteCounter = 0
    state(1) = UnsignedToLong(1732584193#)
    state(2) = UnsignedToLong(4023233417#)
    state(3) = UnsignedToLong(2562383102#)
    state(4) = UnsignedToLong(271733878#)
End Sub
 
'
' MD5 Final
'
Public Sub MD5Final()
    Dim dblBits As Double
    
    Dim padding(72) As Byte
    Dim lngBytesBuffered As Long
    
    padding(0) = &H80
    
    dblBits = ByteCounter * 8
    
    ' Pad out
    lngBytesBuffered = ByteCounter Mod 64
    If lngBytesBuffered <= 56 Then
        MD5Update 56 - lngBytesBuffered, padding
    Else
        MD5Update 120 - ByteCounter, padding
    End If
    
    
    padding(0) = UnsignedToLong(dblBits) And &HFF&
    padding(1) = UnsignedToLong(dblBits) \ 256 And &HFF&
    padding(2) = UnsignedToLong(dblBits) \ 65536 And &HFF&
    padding(3) = UnsignedToLong(dblBits) \ 16777216 And &HFF&
    padding(4) = 0
    padding(5) = 0
    padding(6) = 0
    padding(7) = 0
    
    MD5Update 8, padding
End Sub
 
'
' Break up input stream into 64 byte chunks
'
Public Sub MD5Update(InputLen As Long, InputBuffer() As Byte)
    Dim II As Integer
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim lngBufferedBytes As Long
    Dim lngBufferRemaining As Long
    Dim lngRem As Long
    
    lngBufferedBytes = ByteCounter Mod 64
    lngBufferRemaining = 64 - lngBufferedBytes
    ByteCounter = ByteCounter + InputLen
    ' Use up old buffer results first
    If InputLen >= lngBufferRemaining Then
        For II = 0 To lngBufferRemaining - 1
            ByteBuffer(lngBufferedBytes + II) = InputBuffer(II)
        Next II
        MD5Transform ByteBuffer
        
        lngRem = (InputLen) Mod 64
        ' The transfer is a multiple of 64 lets do some transformations
        For i = lngBufferRemaining To InputLen - II - lngRem Step 64
            For j = 0 To 63
                ByteBuffer(j) = InputBuffer(i + j)
            Next j
            MD5Transform ByteBuffer
        Next i
        lngBufferedBytes = 0
    Else
      i = 0
    End If
    
    ' Buffer any remaining input
    For k = 0 To InputLen - i - 1
        ByteBuffer(lngBufferedBytes + k) = InputBuffer(i + k)
    Next k
    
End Sub
 
'
' MD5 Transform
'
Private Sub MD5Transform(Buffer() As Byte)
    Dim x(16) As Long
    Dim a As Long
    Dim b As Long
    Dim c As Long
    Dim d As Long
    
    a = state(1)
    b = state(2)
    c = state(3)
    d = state(4)
    
    Decode 64, x, Buffer
 
    ' Round 1
    FF a, b, c, d, x(0), S11, -680876936
    FF d, a, b, c, x(1), S12, -389564586
    FF c, d, a, b, x(2), S13, 606105819
    FF b, c, d, a, x(3), S14, -1044525330
    FF a, b, c, d, x(4), S11, -176418897
    FF d, a, b, c, x(5), S12, 1200080426
    FF c, d, a, b, x(6), S13, -1473231341
    FF b, c, d, a, x(7), S14, -45705983
    FF a, b, c, d, x(8), S11, 1770035416
    FF d, a, b, c, x(9), S12, -1958414417
    FF c, d, a, b, x(10), S13, -42063
    FF b, c, d, a, x(11), S14, -1990404162
    FF a, b, c, d, x(12), S11, 1804603682
    FF d, a, b, c, x(13), S12, -40341101
    FF c, d, a, b, x(14), S13, -1502002290
    FF b, c, d, a, x(15), S14, 1236535329
    
    ' Round 2
    GG a, b, c, d, x(1), S21, -165796510
    GG d, a, b, c, x(6), S22, -1069501632
    GG c, d, a, b, x(11), S23, 643717713
    GG b, c, d, a, x(0), S24, -373897302
    GG a, b, c, d, x(5), S21, -701558691
    GG d, a, b, c, x(10), S22, 38016083
    GG c, d, a, b, x(15), S23, -660478335
    GG b, c, d, a, x(4), S24, -405537848
    GG a, b, c, d, x(9), S21, 568446438
    GG d, a, b, c, x(14), S22, -1019803690
    GG c, d, a, b, x(3), S23, -187363961
    GG b, c, d, a, x(8), S24, 1163531501
    GG a, b, c, d, x(13), S21, -1444681467
    GG d, a, b, c, x(2), S22, -51403784
    GG c, d, a, b, x(7), S23, 1735328473
    GG b, c, d, a, x(12), S24, -1926607734
    
    ' Round 3
    HH a, b, c, d, x(5), S31, -378558
    HH d, a, b, c, x(8), S32, -2022574463
    HH c, d, a, b, x(11), S33, 1839030562
    HH b, c, d, a, x(14), S34, -35309556
    HH a, b, c, d, x(1), S31, -1530992060
    HH d, a, b, c, x(4), S32, 1272893353
    HH c, d, a, b, x(7), S33, -155497632
    HH b, c, d, a, x(10), S34, -1094730640
    HH a, b, c, d, x(13), S31, 681279174
    HH d, a, b, c, x(0), S32, -358537222
    HH c, d, a, b, x(3), S33, -722521979
    HH b, c, d, a, x(6), S34, 76029189
    HH a, b, c, d, x(9), S31, -640364487
    HH d, a, b, c, x(12), S32, -421815835
    HH c, d, a, b, x(15), S33, 530742520
    HH b, c, d, a, x(2), S34, -995338651
    
    ' Round 4
    II a, b, c, d, x(0), S41, -198630844
    II d, a, b, c, x(7), S42, 1126891415
    II c, d, a, b, x(14), S43, -1416354905
    II b, c, d, a, x(5), S44, -57434055
    II a, b, c, d, x(12), S41, 1700485571
    II d, a, b, c, x(3), S42, -1894986606
    II c, d, a, b, x(10), S43, -1051523
    II b, c, d, a, x(1), S44, -2054922799
    II a, b, c, d, x(8), S41, 1873313359
    II d, a, b, c, x(15), S42, -30611744
    II c, d, a, b, x(6), S43, -1560198380
    II b, c, d, a, x(13), S44, 1309151649
    II a, b, c, d, x(4), S41, -145523070
    II d, a, b, c, x(11), S42, -1120210379
    II c, d, a, b, x(2), S43, 718787259
    II b, c, d, a, x(9), S44, -343485551
    
    
    state(1) = LongOverflowAdd(state(1), a)
    state(2) = LongOverflowAdd(state(2), b)
    state(3) = LongOverflowAdd(state(3), c)
    state(4) = LongOverflowAdd(state(4), d)
 
'  /* Zeroize sensitive information.
'*/
'  MD5_memset ((POINTER)x, 0, sizeof (x));
    
End Sub
 
Private Sub Decode(Length As Integer, OutputBuffer() As Long, InputBuffer() As Byte)
    Dim intDblIndex As Integer
    Dim intByteIndex As Integer
    Dim dblSum As Double
    
    intDblIndex = 0
    For intByteIndex = 0 To Length - 1 Step 4
        dblSum = InputBuffer(intByteIndex) + _
                                    InputBuffer(intByteIndex + 1) * 256# + _
                                    InputBuffer(intByteIndex + 2) * 65536# + _
                                    InputBuffer(intByteIndex + 3) * 16777216#
        OutputBuffer(intDblIndex) = UnsignedToLong(dblSum)
        intDblIndex = intDblIndex + 1
    Next intByteIndex
End Sub
 
'
' FF, GG, HH, and II transformations for rounds 1, 2, 3, and 4.
' Rotation is separate from addition to prevent recomputation.
'
Private Function FF(a As Long, _
                    b As Long, _
                    c As Long, _
                    d As Long, _
                    x As Long, _
                    s As Long, _
                    ac As Long) As Long
    a = LongOverflowAdd4(a, (b And c) Or (Not (b) And d), x, ac)
    a = LongLeftRotate(a, s)
    a = LongOverflowAdd(a, b)
End Function
 
Private Function GG(a As Long, _
                    b As Long, _
                    c As Long, _
                    d As Long, _
                    x As Long, _
                    s As Long, _
                    ac As Long) As Long
    a = LongOverflowAdd4(a, (b And d) Or (c And Not (d)), x, ac)
    a = LongLeftRotate(a, s)
    a = LongOverflowAdd(a, b)
End Function
 
Private Function HH(a As Long, _
                    b As Long, _
                    c As Long, _
                    d As Long, _
                    x As Long, _
                    s As Long, _
                    ac As Long) As Long
    a = LongOverflowAdd4(a, b Xor c Xor d, x, ac)
    a = LongLeftRotate(a, s)
    a = LongOverflowAdd(a, b)
End Function
 
Private Function II(a As Long, _
                    b As Long, _
                    c As Long, _
                    d As Long, _
                    x As Long, _
                    s As Long, _
                    ac As Long) As Long
    a = LongOverflowAdd4(a, c Xor (b Or Not (d)), x, ac)
    a = LongLeftRotate(a, s)
    a = LongOverflowAdd(a, b)
End Function
 
'
' Rotate a long to the right
'
Function LongLeftRotate(value As Long, bits As Long) As Long
    Dim lngSign As Long
    Dim lngI As Long
    bits = bits Mod 32
    If bits = 0 Then LongLeftRotate = value: Exit Function
    For lngI = 1 To bits
        lngSign = value And &HC0000000
        value = (value And &H3FFFFFFF) * 2
        value = value Or ((lngSign < 0) And 1) Or (CBool(lngSign And _
                &H40000000) And &H80000000)
    Next
    LongLeftRotate = value
End Function
 
'
' Function to add two unsigned numbers together as in C.
' Overflows are ignored!
'
Private Function LongOverflowAdd(Val1 As Long, Val2 As Long) As Long
    Dim lngHighWord As Long
    Dim lngLowWord As Long
    Dim lngOverflow As Long
 
    lngLowWord = (Val1 And &HFFFF&) + (Val2 And &HFFFF&)
    lngOverflow = lngLowWord \ 65536
    lngHighWord = (((Val1 And &HFFFF0000) \ 65536) + ((Val2 And &HFFFF0000) \ 65536) + lngOverflow) And 
 
&HFFFF&
    LongOverflowAdd = UnsignedToLong((lngHighWord * 65536#) + (lngLowWord And &HFFFF&))
End Function
 
'
' Function to add two unsigned numbers together as in C.
' Overflows are ignored!
'
Private Function LongOverflowAdd4(Val1 As Long, Val2 As Long, val3 As Long, val4 As Long) As Long
    Dim lngHighWord As Long
    Dim lngLowWord As Long
    Dim lngOverflow As Long
 
    lngLowWord = (Val1 And &HFFFF&) + (Val2 And &HFFFF&) + (val3 And &HFFFF&) + (val4 And &HFFFF&)
    lngOverflow = lngLowWord \ 65536
    lngHighWord = (((Val1 And &HFFFF0000) \ 65536) + _
                   ((Val2 And &HFFFF0000) \ 65536) + _
                   ((val3 And &HFFFF0000) \ 65536) + _
                   ((val4 And &HFFFF0000) \ 65536) + _
                   lngOverflow) And &HFFFF&
    LongOverflowAdd4 = UnsignedToLong((lngHighWord * 65536#) + (lngLowWord And &HFFFF&))
End Function
 
'
' Convert an unsigned double into a long
'
Private Function UnsignedToLong(value As Double) As Long
        If value < 0 Or value >= OFFSET_4 Then Error 6 ' Overflow
        If value <= MAXINT_4 Then
          UnsignedToLong = value
        Else
          UnsignedToLong = value - OFFSET_4
        End If
      End Function
 
'
' Convert a long to an unsigned Double
'
Private Function LongToUnsigned(value As Long) As Double
        If value < 0 Then
          LongToUnsigned = value + OFFSET_4
        Else
          LongToUnsigned = value
        End If
End Function

:

", , "

Denri
101 / 52 / 2
: 10.07.2012
: 343
: 2
27.11.2012, 13:00     Visual Basic 6.0 #13
42- Label
Label Text1
Label1 Label2 BackStyle = 0 AutoSize = True
ForeColor
...

Visual Basic
1
2
3
4
5
6
7
8
9
Private Sub Form_Load() 
Label1.Left = Label2.Left + 75
Label1.Top = Label2.Top 
Label1.ZOrder (1)
End Sub
Private Sub Text1_Change() '   (     )
Label2.Caption = Text1.Text
Label1.Caption = Text1.Text
End Sub
 : zip New Folder.zip (1.6 , 150 )
Denri
101 / 52 / 2
: 10.07.2012
: 343
: 2
30.11.2012, 00:31     Visual Basic 6.0 #14
43- "Doom".

VB6 3D directx !!! ( , ).

: , , , 12 .
, , ). . 5 .
( - ).

:
.
 : rar doom.rar (1.09 , 587 )
MoreAnswers
37091 / 29110 / 5898
: 17.06.2006
: 43,301
15.12.2012, 14:47     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



:
dev.Free
15.12.2012, 14:47     Visual Basic 6.0 #15
.TXT .RTF () .

2 , Skype, , . .TXT .RTF , , :

1. .TXT .RTF .
2. RithtextBox.
3. 1 , ( ).


.

:

1. CommonDialog.
2. RithtextBox .TXT .RTF.
3. .
 : rar .rar (332.6 , 266 )
Yandex
15.12.2012, 14:47     Visual Basic 6.0

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