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

Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Const KEYEVENTF_KEYUP = &H2
Const VK_CONTROL = &H11
Const VK_MENU = &H12
Const VK_ESCAPE = &H1B
 
Private Sub ShowStartMenu()
Call keybd_event(VK_CONTROL, 0, 0, 0)
Call keybd_event(VK_ESCAPE, 0, 0, 0)
Call keybd_event(VK_ESCAPE, 0, KEYEVENTF_KEYUP, 0)
Call keybd_event(VK_CONTROL, 0, KEYEVENTF_KEYUP, 0)
End Sub
 
Private Sub Command1_Click()
Call ShowStartMenu
End Sub

Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal sAgent As String, ByVal nAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal nFlags As Long) As Long
Private Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" (ByVal hInternetSession As Long, ByVal sServerName As String, ByVal nServerPort As Integer, ByVal sUserName As String, ByVal sPassword As String, ByVal nService As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Private Declare Function FtpPutFile Lib "wininet.dll" Alias "FtpPutFileA" (ByVal hFtpSession As Long, ByVal lpszLocalFile As String, ByVal lpszRemoteFile As String, ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean
Private Declare Function FtpGetFile Lib "wininet.dll" Alias "FtpGetFileA" (ByVal hFtpSession As Long, ByVal lpszRemoteFile As String, ByVal lpszNewFile As String, ByVal fFailIfExists As Boolean, ByVal dwFlagsAndAttributes As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean
Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer
 
Dim rc&
Dim rs&
 
Private Sub Command1_Click()
    rc& = InternetOpen("", 0, vbNullString, vbNullString, 0)
    rs& = InternetConnect(rc&, "ftp.narod.ru", "21", "Login", "Password", 1, 0, 0)
    If FtpGetFile(rs&, "GetFile.txt", "C:\GetFile.txt", False, 0, 2, 0) = False Then MsgBox "Ошибка получения файла!", vbExclamation
    'If FtpPutFile(rs&, "C:\SendFile.txt", "SendFile.txt", 2, 0) = False Then MsgBox "Ошибка передачи файла!", vbExclamation
    'Параметр dwFlags функции FtpGetFile/FtpPutFile задает тип приема/передачи.
    'Он может принимать следующие значения: 1 - для ASCII; 2 - для Binary
    Call InternetCloseHandle(rs&)
    Call InternetCloseHandle(rc&)
End Sub

'Запись:
'Для записи текста служит функция Print(и Write)
 
Open "c:\1.txt" For Append As #1 'Открываем файл для добавления записи, с номером канала Print #1, "Твой ТЕКСТ"' Записываем в файл 1.txt текст
Close #1 'Закрываем файл
 
'Есть еще функция для определения свободного канала - FreeFile. Например:
f = FreeFile 'Возвращает номер свободного канала
Open "c:\1.txt" For Append As f 'Открываем файл для добавления записи
Print #f, "Твой ТЕКСТ"'Записываем в файл 1.txt текст
Close #f 'Закрываем файл
 
'Чтение:
'Считать данные из файла сложнее чем записать. Есть два способа чтения данных из файла. Первый:
 
f = FreeFile
Open "c:\1.txt" For Input As f' Открываем файл 1.txt для чтения
Text1.Text = Input(LOF(f), f) 'Считываем текст из открытого файла в текстовое поле(Оператор LOF(Len Of File) определяет длину файла)
Close f
 
'Второй:
 
Dim txt as String
 
Open "c:\1.txt" For Input As #1' Открываем файл 1.txt для чтения
Do While Not EOF(1) ' Функция EOF(End Of File) проверяет, достигнут ли конец файла Line Input #1, txt ' Читаем строку данных Text1.Text = txt
Loop
Close #1

Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Const SPI_SETDESKWALLPAPER = 20
 
Private Sub SetWallpaper(File As String)
SystemParametersInfo SPI_SETDESKWALLPAPER, 0, ByVal File, True
End Sub
 
Private Sub Form_Load()
SetWallpaper "D:\123.JPG"
End Sub

Private Declare Function ShellExecute Lib "shell32.dll" Alias _
"ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, _
ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
 
Private Const SW_NORMAL = (1&)
 
Private Sub Command1_Click()
Call ShellExecute(Me.hwnd, "open", "D:\123.JPG", 0&, 0&, SW_NORMAL&)
End Sub

Private Sub Command1_Click()
tex = Text1.text
tex = Replace(tex, " ", "+")
url = "http: // translate.yandex.net/api/v1/tr/translate?lang=en-ru&text=" & tex
WebBrowser1.Navigate url
End Sub
 
 
Private Sub Form_Load()
Dim tex$, tex2$, i%, url$, dv1&, dv2&, txt$
WebBrowser1.Navigate "about:blank"
End Sub
 
Private Sub WebBrowser1_DocumentComplete(ByVal pDisp As Object, url As Variant)
On Error Resume Next
If WebBrowser1.LocationURL = url Then 
txt = WebBrowser1.Document.body.innertext 
dv1 = InStr(1, txt, "")
dv2 = InStr(dv1, txt, "</text>")
nTxt = Mid$(txt, dv1, dv2 - dv1)
Text2.text = nTxt
End If
End Sub

'Декларируем АПИ:
Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long 
 
Private Sub Form_Load() 'При запуске формы, делаем ее круглой:
SetWindowRgn hWnd, CreateEllipticRgn(80, 0, 300, 200), True 'Цифры в скобках означают что - то типо координат, например, изменив первую цифру(80), окно сузится, или расширится
End Sub

Option Explicit
 
Private Sub Form_QueryUnload _
    (Cancel As Integer, _
     UnloadMode As Integer)
   If UnloadMode = vbFormControlMenu Then
    Cancel = True
   End If
End Sub

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

Option Explicit
 
Private Sub Command1_Click()
RichTextBox1.SelPrint (Printer.hDC)
End Sub

Option Explicit
 
Private Sub Command1_Click()
PrintRTF RichTextBox1, 1440, 1440, 1440, 1440
End Sub

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

Option Explicit
 
Private Declare Function SetLocalTime Lib "kernel32.dll" _
                    (lpSystemTime As SystemTime) As Long
 
Private Type SystemTime
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
End Type
 
Dim SetTime As SystemTime
Dim RetVal As Long
 
Private Sub SetNewTime _
    (NewHour As Integer, NewMinute As Integer, NewSecond As Integer)
SetTime.wHour = NewHour
SetTime.wMinute = NewMinute
SetTime.wSecond = NewSecond
SetTime.wMilliseconds = 0
SetTime.wDay = Day(Date)
'Чтобы установить и дату снимите коментарий
'SetTime.wDay = 06
SetTime.wMonth = Month(Date)
'SetTime.wMonth = 8
SetTime.wYear = Year(Date)
'SetTime.wYear = 2006
RetVal = SetLocalTime(SetTime)
End Sub
 
Private Sub Command1_Click()
Call SetNewTime(19, 42, 11)
End Sub

Option Explicit
 
Private Sub Text2_Change()
On Error GoTo ErrLabel
Dim Message As String
Dim NumberM As Integer
Dim FileNum As Byte
Message = String$(1, " ")
FileNum = FreeFile
Open App.Path & "\1.txt" For Binary As FileNum
NumberM = Val(Text2.Text)
Get #FileNum, NumberM, Message
Text1.Text = Message
Close FileNum
Exit Sub
 
ErrLabel:
    Dim errsabj As String
    If Err.Number = 63 Then
    errsabj = MsgBox("Не правильный номер записи, введите цифру!", _
            vbCritical + vbRetryCancel)
        Select Case errsabj
        Case vbCancel
            End
        Case vbRetry
            Text2.Text = ""
            Resume Next
        End Select
    End If
End Sub

'Создать текстовый файл и занести информацию
'И сразу открыть файл блокнотом
Option Explicit
 
Dim FileNum As Byte
 
Private Declare Function ShellExecute Lib "shell32" Alias "ShellExecuteA" _
            (ByVal hwnd As Long, _
            ByVal lpOperation As String, _
            ByVal lpFile As String, _
            ByVal lpParameters As String, _
            ByVal lpDirectory As String, _
            ByVal nShowCmd As Long) As Long
 
Private Const SW_SHOWNORMAL = 1
 
Private Sub Form_Load()
FileNum = FreeFile
Open "D:\Sample.txt" For Append As FileNum
Print #FileNum, "Первая строка текста"
Print #FileNum, "Вторая строка текста"
Close FileNum
 
ShellExecute 0, vbNullString, "D:\Sample.txt", vbNullString, _
                                vbNullString, SW_SHOWNORMAL
End
End Sub

Option Explicit
 
Private Sub Form_Load()
Text1.Text = Replace("Ваш текст, который содержит пробелы", " ", "")
End Sub

Option Explicit
 
Private Sub Command1_Click()
Text1.Text = Replace(Text1.Text, Text3.Text, Text2.Text)
End Sub
 
Private Sub Command2_Click()
Text1.Text = Replace(Text1.Text, Text2.Text, Text3.Text)
End Sub
 
Private Sub Form_Load()
Text1.Text = _
        "Строка в которой ищем текст, для замены с помощью Replace"
Text2.Text = "в"
Text3.Text = "на"
End Sub

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

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

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

Private Sub Form_Load()
    Dim x As Integer
    For x = 0 To 15
        List1.AddItem "Picture1(" & x & ")"
    If x > 0 Then Load Picture1(x)
    Picture(x).AutoRedraw = True
        Picture(x).AutoRedraw = True
        Picture(x).Visible = True
        Picture(x).Left = Picture1(0).Left
        Picture(x).Top = Picture1(0).Top
        Picture(x).Width = Picture1(0).Width
        Picture(x).Height = Picture1(0).Height
        Picture1(x).Print "This is picture " & x
    Next x
    Me.Show: Me.Refresh
    List1.ListIndex = 0
 
End Sub
В VB 4.0, можно использовать следующий синтаксис:
 
With Picture1(x)
    .AutoRedraw = True
    .Visible = True
    .Left = Picture1(0).Left
    .Top = Picture1(0).Top
    .Width = Picture1(0).Width
    .Height = Picture1(0).Height
End With

Option Explicit
 
Public Declare Function mciSendString& Lib "winmm.dll" Alias "mciSendStringA" _
    (ByVal lpstrCommand$, _
    ByVal lpstrReturnString$, _
    ByVal uReturnLength&, _
    ByVal hwndCallback&)
 
Private Const MCI_ALIAS As String = "Media_1" '// Любой псевдоним
 
Sub main()
    Dim strFileName$
    
    strFileName = "u:\Разная\9-para_normalnih vstavay.mp3" '// Задаем имя аудио-файла
    
    '// Обход ошибки пробелов в имени и пути к файлу
    strFileName = Replace(strFileName, Chr(34), "")
    If InStr(strFileName, " ") <> 0 Then strFileName = Chr(34) & strFileName & Chr(34)
    
    '// Проиграть музыку (по-умолчанию в асинхронном режиме - без ожидания завершения трека)
    PlaySnd strFileName
    'PlaySnd strFileName:=strFileName, ASync:=False
    
    MCISend "Pause " & MCI_ALIAS '// Приостановить
    Stop
    
    MCISend "Resume " & MCI_ALIAS '// Продолжить
    Stop
    
    StopSnd '// Остановить
End Sub
 
Sub StopSnd()
    MCISend "Stop " & MCI_ALIAS '// Останавливаем воспроизведение
    MCISend "Close " & MCI_ALIAS '// Закрываем файл
End Sub
 
Sub PlaySnd(strFileName$, Optional ASync As Boolean = True)
        '// Закрываем файл.
        '// Если он не закрыт, воспроизведение будет продолжено с предыдущей позиции
        '// Seek не использую. Приводит к искажениям в начале воспроизведения на некоторых дорожках.
    MCISend "Close " & MCI_ALIAS
    MCISend "Open " & strFileName & " alias " & MCI_ALIAS '// Присваиваем алиас
    MCISend "Play " & MCI_ALIAS & IIf(ASync, "", " wait")
End Sub
 
Sub MCISend(lpstrCommand$)
    mciSendString lpstrCommand, vbNullString, 0&, 0&
End Sub

'Положите на форму элемент CommandButton
'Необходимое предупреждение: после выполнения данного кода компьютер 
'полностью блокируется, и перезагрузить его можно только кнопкой Restart на 
'вашем компьютере.
 
Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
 
Private Sub Command1_Click()
    Dim freez
    
    freez = SetParent(Me.hWnd, Me.hWnd)
End Sub

'Пример 1
'Этот пример покажет время в милисекундах (1000 миллисекунд = 1 секунда). 
'Если хотите получить секунды - разделите на 1000.
 
Private Declare Function GetTickCount Lib "Kernel32" () As Long
 
Private Sub Form_Load()
    MsgBox GetTickCount()
End Sub
 
'Более подробнее расписанная статистика.
 
Private Declare Function GetTickCount Lib "Kernel32" () As Long
 
Private Sub Command1_Click()
    Dim a_hour, a_minute, a_second
    a = Format(GetTickCount() / 1000, "0") 'всего секунд
    a_hour = Int(a / 3600)
    a = a - a_hour * 3600
    a_minute = Int(a / 60)
    a_second = a - a_minute * 60
    MsgBox "Ваш компьютер работает в эту загрузку " & str(a_hour) & " часов " & str(a_minute) & " минут" & str(a_second) & " секунд"
End Sub
 
'ИЛИ ТАКОЙ ПРИМЕР
'Расположите на форме элемент ListBox и элемент Timer
 
Private Declare Function GetTickCount& Lib "Kernel32" ()
 
Private Sub Form_Load()
    Timer1.Interval = 1000
End Sub
 
Private Sub Timer1_Timer()
    MS = GetTickCount()
    SekGesamt = MS \ 1000
    Std = (SekGesamt \ 3600)
    Min = (SekGesamt - (Std * 3600)) \ 60
    Sek = (SekGesamt - (Std * 3600) - (Min * 60))
    t = Format(Std, "00") & ":" & Format(Min, "00") & ":" & Format(Sek, "00")
    Label1.Caption = t
End Sub

'Для изменения внешнего вида кнопки ПУСК вам нужна любая картинка 
'размером 55 пикс * 22 пикс. под именем temp.bmp
 
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
 
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
 
Const SRCCOPY = &HCC0020
 
Dim hwndTB As Long ' handle taskbar'а
Dim hWndSB As Long ' handle окна кнопки ПУСК
Dim hDcSB As Long ' handle содержимого кнопки ПУСК
Dim mRect As RECT ' координаты кнопки ПУСК
Dim hDcTmp As Long ' handle новой картинки
Dim hBmpTmp As Long ' временная картинка
Dim hBmpTmp2 As Long ' временная картинка
Dim nWidth As Long ' ширина кнопки ПУСК
Dim nHeight As Long ' высота кнопки ПУСК
Dim sPath As String ' путь к картинке
 
Private Sub Form_Load()
    ' получить handle taskbar и кнопки ПУСК
    hwndTB = FindWindow("Shell_TrayWnd", "")
    hWndSB = FindWindowEx(hwndTB, 0, "button", vbNullString)
    ' получить dc кнопки ПУСК
    hDcSB = GetWindowDC(hWndSB)
    ' получить координаты кнопки ПУСК
    Call GetWindowRect(hWndSB, mRect)
    ' ширина и высота
    nWidth = mRect.Right - mRect.Left
    nHeight = mRect.Bottom - mRect.Top
    hDcTmp = CreateCompatibleDC(hDcSB)
    hBmpTmp = CreateCompatibleBitmap(hDcTmp, nWidth, nHeight)
    ' установить путь для загрузки картинки
    sPath = App.Path & "\temp.bmp"
    hBmpTmp2 = SelectObject(hDcTmp, LoadPicture(sPath))
End Sub
 
Private Sub tmrPaint_Timer()
    ' рисовать кнопку ПУСК
    Call BitBlt(hDcSB, 0, 0, nWidth, nHeight, hDcTmp, 0, 0, SRCCOPY)
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
    ' очистить кнопку ПУСК
    hBmpTmp = SelectObject(hDcTmp, hBmpTmp2)
    DeleteObject hBmpTmp
    DeleteDC hDcTmp
End Sub

'На создавшейся вместе с проектом форме разместите таймер и метку. Имя 
'таймера timer1, interval = 50. Имя метки lblTime, Top = 0, left = 0
 
'Функция для поиска окна первого уровня
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
'Функция для поиска дочернего окна
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
'Функция назначает окну нового родителя
Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
 
Private Sub Form_Load()
    Dim hnd As Long
    
    'Часики является дочерним окном трея
    'И в свою очередь трей является дочерним окном панели задач
    'Ищем манипулятор панели задач (класс панели задач: Shell_TrayWnd)
    hnd = FindWindow("Shell_TrayWnd", vbNullString)
    'Ищем манипулятор трея (класс трея: TrayNotifyWnd)
    hnd = FindWindowEx(hnd, 0, "TrayNotifyWnd", vbNullString)
    'Ищем манипулятор часиков (класс часиков: TrayClockWClass)
    hnd = FindWindowEx(hnd, 0, "TrayClockWClass", vbNullString)
    'Вставляем нашу формы вместо часиков
    Me.Left = 0
    Me.Top = 0
    SetParent Me.hwnd, hnd
End Sub
 
Private Sub Timer1_Timer()
    lblTime = Time
End Sub

Private Declare Function SetSysColors Lib "user32" (ByVal nChanges As Long, lpSysColor As Long, lpColorValues As Long) As Long
 
Private Declare Function GetSysColor& Lib "user32" (ByVal nIndex As Long)
 
'Можно использовать следующие константы
Private Const COLOR_SCROLLBAR = 0 'The Scrollbar colour
Private Const COLOR_BACKGROUND = 1 'Colour of the background With no wallpaper
Private Const COLOR_ACTIVECAPTION = 2 'Caption of Active Window
Private Const COLOR_INACTIVECAPTION = 3 'Caption of Inactive window
Private Const COLOR_MENU = 4 'Menu
Private Const COLOR_WINDOW = 5 'Windows background
Private Const COLOR_WINDOWFRAME = 6 'Window frame
Private Const COLOR_MENUTEXT = 7 'Window Text
Private Const COLOR_WINDOWTEXT = 8 '3D dark shadow (Win95)
Private Const COLOR_CAPTIONTEXT = 9 'Text in window caption
Private Const COLOR_ACTIVEBORDER = 10 'Border of active window
Private Const COLOR_INACTIVEBORDER = 11 'Border of inactive window
Private Const COLOR_APPWORKSPACE = 12 'Background of MDI desktop
Private Const COLOR_HIGHLIGHT = 13 'Selected item background
Private Const COLOR_HIGHLIGHTTEXT = 14 'Selected menu item
Private Const COLOR_BTNFACE = 15 'Button
Private Const COLOR_BTNSHADOW = 16 '3D shading of button
Private Const COLOR_GRAYTEXT = 17 'Grey text, of zero If dithering Is used.
Private Const COLOR_BTNTEXT = 18 'Button text
Private Const COLOR_INACTIVECAPTIONTEXT = 19 'Text of inactive window
Private Const COLOR_BTNHIGHLIGHT = 20 '3D highlight of button
 
Dim OldColor As Long
 
Private Sub Form_Load()
    'Эапоминаем текущий цвет
    OldColor = GetSysColor(COLOR_ACTIVECAPTION)
    
    SetSysColors 1, COLOR_ACTIVECAPTION, RGB(255, 0, 0)
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
    'Восстанавливаем текущий цвет
    SetSysColors 1, COLOR_ACTIVECAPTION, OldColor
End Sub

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

Declare Function Shell_NotifyIconA Lib "SHELL32" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Integer
 
Public Const NIM_ADD = 0
Public Const NIM_MODIFY = 1
Public Const NIM_DELETE = 2
Public Const NIF_MESSAGE = 1
Public Const NIF_ICON = 2
Public Const NIF_TIP = 4
 
Type NOTIFYICONDATA
    cbSize As Long
    hWnd As Long
    uID As Long
    uFlags As Long
    uCallbackMessage As Long
    hIcon As Long
    szTip As String * 64
End Type
 
Public Function SetTrayIcon(Mode As Long, hWnd As Long, Icon As Long, tip As String) As Long
    Dim nidTemp As NOTIFYICONDATA
    nidTemp.cbSize = Len(nidTemp)
    nidTemp.hWnd = hWnd
    nidTemp.uID = 0&
    nidTemp.uFlags = NIF_ICON Or NIF_TIP
    nidTemp.uCallbackMessage = 0&
    nidTemp.hIcon = Icon
    nidTemp.szTip = tip & Chr$(0)
    SetTrayIcon = Shell_NotifyIconA(Mode, nidTemp)
End Function
 
Добавить в форму:
Private Sub Form_Click()
SetTrayIcon NIM_MODIFY, Me.hWnd, Me.Icon, "Работает? Работает!"
End Sub
Private Sub Form_Load()
SetTrayIcon NIM_ADD, Me.hWnd, Me.Icon, "Проверка"
End Sub
Private Sub Form_Unload(Cancel As Integer)
SetTrayIcon NIM_DELETE, Me.hWnd, 0&, ""
End Sub

'Если вы хотите запустить любую задачу из Панели Управления, вам достаточно 
'использовать функцию SHELL: Shell "rundll32.exe shell32.dll,Control_RunDLL " 
'& FileName, vbNormalFocus,
'где FileName - имя файла с расширением ".CPL", которые расположены в 
'директории %windir/system%
'Данный пример покажет все файлы с расширением ".CPL".
'Первая кнопка запускает проводник со всеми расширениями, вторая - запускает 
'конкретный сервис.
'Добавьте 2 CommandButton и 1 FileListBox на форму. Вставьте следующий код в 
'события формы.
 
Public Sub RunControlPanelExtension(FileName As String)
    Shell "rundll32.exe shell32.dll,Control_RunDLL " & FileName, vbNormalFocus
End Sub
 
Private Sub Command2_Click()
    RunControlPanelExtension File1.FileName
End Sub
 
Private Sub Command1_Click()
    Shell "rundll32.exe shell32.dll,Control_RunDLL", vbNormalFocus
End Sub
 
Private Sub Form_Load()
    File1.Pattern = "*.CPL"
    'В Windows NT замените 'C:\Windows\SYSTEM' на 'C:\WINNT\SYSTEM32'
    File1.FileName = "C:\Windows\SYSTEM"
End Sub
 
'Примеры использования:
 
'Установка оборудования
'Call Shell("rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl @1", 5)
'Установка и удаление программ
'Call Shell("rundll32.exe shell32.dll,Control_RunDLL appwiz.cpl,,1", 5)
'Свойства экрана
'Call Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,0", 5)
'Настройки Интернета
'Call Shell("rundll32.exe shell32.dll,Control_RunDLL inetcpl.cpl,,0", 5)
'Клавиатура
'Call Shell("rundll32.exe shell32.dll,Control_RunDLL main.cpl @1", 5)
'Мастер установки принтера
'Call Shell("rundll32.exe shell32.dll,SHHelpShortcuts_RunDLL AddPrinter", vbNormalFocus)
'Свойства модема
'Call Shell("rundll32.exe shell32.dll,Control_RunDLL modem.cpl", 5)
'Свойства мыши
'Call Shell("rundll32.exe shell32.dll,Control_RunDLL main.cpl @0", 5)
'Настройки сети
'Call Shell("rundll32.exe shell32.dll,Control_RunDLL netcpl.cpl", 5)
'Окно "Пароли"
'Call Shell("rundll32.exe shell32.dll,Control_RunDLL password.cpl", 5)
'Окно "Язык и стандарты"
'Shell("rundll32.exe shell32.dll,Control_RunDLL intl.cpl,,0", 5)
'Окно "Звук"
'Call Shell("rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl @1", 5)
'Настройки системы
'Call Shell("rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl,,0", 5)
'Настройка даты и времени
'Call Shell("rundll32.exe shell32.dll,Control_RunDLL timedate.cpl", 5)
 
'ВАРИАНТ 2
'С использованием ShellExecute.
 
Private Declare Function GetDesktopWindow Lib "user32.dll" () As Long
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
 
Const SW_SHOWNORMAL = 1
 
Function StartCPLApp(AppName As String) As Long
    Dim Scr_hDC As Long
    
    Scr_hDC = GetDesktopWindow()
    MsgBox Scr_hDC
    StartCPLApp = ShellExecute(Scr_hDC, "Open", "Control", AppName, "C:\", SW_SHOWNORMAL)
End Function
 
Private Sub Command1_Click()
    StartCPLApp "DESK.CPL"
End Sub

'Добавьте на форму 2 CommandButton. Первая кнопка помещает на рабочий стол 
'любой ваш рисунок, вторая - убирает этот рисунок.
 
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As String, ByVal fuWinIni As Long) As Long
 
Const SPI_SETDESKWALLPAPER = 20
 
Private Sub Command1_Click()
    SystemParametersInfo SPI_SETDESKWALLPAPER, 0, "D:\Basic\tmpProj\Load.bmp", True
    'Заменить путь D:\Basic\tmpProj\Load.bmp на нужный вам файл рисунка в формате bmp
End Sub
 
Private Sub Command2_Click()
    SystemParametersInfo SPI_SETDESKWALLPAPER, 0, 0, False
End Sub

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

'важно!
'd3dpp.AutoDepthStencilFormat = D3DFMT_D16
'Вместо D3DFMT_D16 надо использовать константу,
'соответствующую настройкам Вашего монитора.
 
Option Explicit
 
Dim g_DX As New DirectX8
Dim g_D3DX As New D3DX8
Dim g_D3D As Direct3D8
Dim g_D3DDevice As Direct3DDevice8
Dim g_Mesh As D3DXMesh                  ' Наш 3d объект
Dim g_MeshMaterials() As D3DMATERIAL8   ' Данные о материалах 3d объекта
Dim g_MeshTextures() As Direct3DTexture8 ' Текстуры 3d объекта
Dim g_NumMaterials As Long
 
Const g_pi = 3.1415
 
 
Private Sub Form_Load()
Me.Show
If Not InitD3d(Form1.hWnd) Then
   MsgBox "Невозможно инициализировать Direct3d."
   End
End If
If Not InitGeometry() Then
   MsgBox "Невозможно инициализировать буфер вершин."
   End
End If
Timer1.Enabled = True
End Sub
 
Function InitD3d(hWnd As Long) As Boolean
On Local Error Resume Next 'чтобы при ошибке программа продолжала работать дальше
 
Set g_D3D = g_DX.Direct3DCreate() 'получаем объект Direct3d
If g_D3D Is Nothing Then Exit Function  'если ничего не происходит - выход из функции
 
Dim Mode As D3DDISPLAYMODE
g_D3D.GetAdapterDisplayMode D3DADAPTER_DEFAULT, Mode
 
Dim d3dpp As D3DPRESENT_PARAMETERS
d3dpp.Windowed = 1
d3dpp.SwapEffect = D3DSWAPEFFECT_COPY_VSYNC
d3dpp.BackBufferFormat = Mode.Format
d3dpp.BackBufferCount = 1
d3dpp.EnableAutoDepthStencil = 1
d3dpp.AutoDepthStencilFormat = D3DFMT_D16
 
'создаём  устройство рендеринга
Set g_D3DDevice = g_D3D.CreateDevice(D3DADAPTER_DEFAULT, D3DDEVTYPE_HAL, hWnd, _
                                     D3DCREATE_SOFTWARE_VERTEXPROCESSING, d3dpp)
If g_D3DDevice Is Nothing Then Exit Function
 
'выключаем culling
g_D3DDevice.SetRenderState D3DRS_CULLMODE, D3DCULL_NONE
'включаем z-буфферинг
g_D3DDevice.SetRenderState D3DRS_ZENABLE, 1
'выключаем 3d освещение
g_D3DDevice.SetRenderState D3DRS_LIGHTING, 0
 
InitD3d = True 'инициализация Direct3d прошла успешно
End Function
 
Public Sub Render()
Dim i As Long
 
g_D3DDevice.Clear 0, ByVal 0, D3DCLEAR_TARGET Or D3DCLEAR_ZBUFFER, &HFF&, 1, 0
 
' Начало сцены
g_D3DDevice.BeginScene
 
SetupMatrices
 
' 3d объекты разделены на части (subsets).
' У каждой части свой материал и текстура.
' Рендеринг 3d объекта по частям в цикле:
For i = 0 To g_NumMaterials - 1
    ' Установка материала и текстуры для каждой части
    g_D3DDevice.SetMaterial g_MeshMaterials(i)
    g_D3DDevice.SetTexture 0, g_MeshTextures(i)
    ' Прорисовка части 3d объекта
    g_Mesh.DrawSubset i
Next
 
' Конец сцены
g_D3DDevice.EndScene
 
g_D3DDevice.Present ByVal 0, ByVal 0, 0, ByVal 0
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
Cleanup
End Sub
 
Private Sub Timer1_Timer()
Render
End Sub
 
Sub Cleanup()
    Erase g_MeshTextures
    Erase g_MeshMaterials
    
    Set g_Mesh = Nothing
    Set g_D3DDevice = Nothing
    Set g_D3D = Nothing
End Sub
 
Function InitGeometry() As Boolean
On Local Error Resume Next
 
Dim MtrlBuffer As D3DXBuffer
Dim i As Long
 
Set g_Mesh = g_D3DX.LoadMeshFromX(App.Path + "\Tiger.x", D3DXMESH_MANAGED, _
                               g_D3DDevice, Nothing, MtrlBuffer, g_NumMaterials)
If g_Mesh Is Nothing Then Exit Function
 
ReDim g_MeshMaterials(g_NumMaterials)
ReDim g_MeshTextures(g_NumMaterials)
 
Dim strTexName As String
 
For i = 0 To g_NumMaterials - 1
    ' Копирование материала из буфера MtrlBuffer в массив g_MeshMaterials
    g_D3DX.BufferGetMaterial MtrlBuffer, i, g_MeshMaterials(i)
 
    ' Установка окружающего цвета материала (D3DX этого не делает)
    g_MeshMaterials(i).Ambient = g_MeshMaterials(i).diffuse
     
    ' Создание текстуры
    strTexName = g_D3DX.BufferGetTextureName(MtrlBuffer, i)
    If strTexName <> "" Then
        Set g_MeshTextures(i) = g_D3DX.CreateTextureFromFile(g_D3DDevice, App.Path + "\" + strTexName)
    End If
Next
 
Set MtrlBuffer = Nothing
 
InitGeometry = True
End Function
Function vec3(x As Single, y As Single, z As Single) As D3DVECTOR
    vec3.x = x
    vec3.y = y
    vec3.z = z
End Function
 
Public Sub SetupMatrices()
Dim matWorld As D3DMATRIX 'Матрица Мира
D3DXMatrixRotationY matWorld, Timer / 4
g_D3DDevice.SetTransform D3DTS_WORLD, matWorld
 
Dim matView As D3DMATRIX 'Матрица Обзора
D3DXMatrixLookAtLH matView, vec3(0, 3, -3), _
                            vec3(0, 0, 0), _
                            vec3(0, 1, 0)
                             
g_D3DDevice.SetTransform D3DTS_VIEW, matView
 
Dim matProj As D3DMATRIX 'Матрица Проекции
D3DXMatrixPerspectiveFovLH matProj, g_pi / 4, 1, 1, 1000
g_D3DDevice.SetTransform D3DTS_PROJECTION, matProj
 
End Sub

Option Explicit
 
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
  Keyb(KeyCode) = True
End Sub
 
Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
  Keyb(KeyCode) = False
End Sub
 
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
  If Running Then Cancel = 1: Running = False
End Sub
 
Private Sub TimerFPS_Timer()
  Me.Caption = FPS
  FPS = 0
End Sub

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

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

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

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

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

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

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

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

Option Explicit
 
Sub main()
Dim s As String
Dim a
Dim v
Dim n() As Long
Dim i As Long, j As Long, k As Long
Dim b() As Long
Dim p As Long
Open App.Path & "\Test.txt" For Input As 1
  s = Input$(LOF(1), 1)
Close
a = Split(s, vbCrLf & vbCrLf)
ReDim n(UBound(a))
Randomize
For i = 0 To UBound(n)
  j = Int(Rnd * (i + 1))
  n(i) = n(j)
  n(j) = i
Next i
For i = 0 To UBound(n)
  v = Split(a(n(i)), vbCrLf)
  s = v(0)
  ReDim b(1 To UBound(v))
  For k = 1 To UBound(b)
    j = Int(Rnd * k + 1)
    b(k) = b(j)
    b(j) = k
  Next k
  For k = 1 To UBound(b)
    s = s & vbCrLf & vbCrLf & k & ":  " & v(b(k))
  Next k
  Do
    j = Val(InputBox(s, "Введите номер правильного ответа"))
    If j < 1 Or j > UBound(b) Then
      If MsgBox("Повторить - [Да]" & vbCrLf & "Выйти - [Нет]", vbYesNo, "Не корректный ввод!") <> vbYes Then Exit Sub
    Else
      Exit Do
    End If
  Loop
  p = p - (b(j) = 1)
Next i
MsgBox "Вы дали " & p & " правильных ответов из " & i
End Sub