Готовые решения и полезные коды на Visual Basic 6.0

    Option Explicit  
      
    Private Const MONITOR_ON = -1&  
    Private Const MONITOR_LOWPOWER = 1&  
    Private Const MONITOR_OFF = 2&  
    Private Const SC_MONITORPOWER = &HF170&  
    Private Const WM_SYSCOMMAND = &H112  
      
    Private Declare Function SendMessage Lib "user32" _  
    Alias "SendMessageA" _  
    (ByVal hWnd As Long, _  
    ByVal wMsg As Long, _  
    ByVal wParam As Long, _  
    lParam As Any) As Long  
 
    Private Sub Form_Load()  
      
    Command1.Caption = "Turn off monitors"  
      
    End Sub  
      
      
    Private Sub Command1_Click()  
      
    'shut monitor(s) off, and enable  
    'a timer that will turn them on again  
    'after 5 seconds (just in case!)  
    Call SendMessage(Me.hWnd, WM_SYSCOMMAND, SC_MONITORPOWER, ByVal MONITOR_OFF)  
      
    With Timer1  
    .Interval = 5000  
    .Enabled = True  
    End With  
      
    End Sub  
      
      
    Private Sub Timer1_Timer()  
      
    Timer1.Enabled = False  
      
    'turn monitor on  
    Call SendMessage(Me.hWnd, WM_SYSCOMMAND, SC_MONITORPOWER, ByVal MONITOR_ON)  
      
    End Sub

    'nasGetCharCount(strText, strFindChar)   
    'где strText - текст, в котором ведется поиск;   
    'strFindChar - искомый символ   
    Public Function nasGetCharCount( _   
        ByVal strText As String, _   
        Optional strFindChar As String = " ") _   
        As Long   
     Dim gccArray() As String   
     If strText = vbNullString Then   
      nasGetCharCount = 0: Exit Function   
     End If   
     gccArray = Split(strText, strFindChar)   
     nasGetCharCount = UBound(gccArray)   
    End Function

    'Для проверки работы примера, разместите на форме один элемент ComboBox   
      
    Private Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long  
      
    Private Sub Form_Load()  
     Dim i As Integer  
     For i = 1 To 50  
      Combo1.AddItem Format$(i)  
     Next i  
     Combo1.ListIndex = 0  
     ReSizeCombo Me, Combo1  
    End Sub  
      
    Private Sub Form_Resize()  
     ReSizeCombo Me, Combo1  
    End Sub  
      
    ' Процедура меняет размер выпадающей части комбобокса в соответствии с высотой формы  
    Public Sub ReSizeCombo(frm As Form, cbo As ComboBox)  
     Dim cboLeft As Long  
     Dim cboTop As Long  
     Dim cboWidth As Long  
     Dim cboHeight As Long  
     Dim oldScaleMode As Long  
     oldScaleMode = frm.ScaleMode  
     frm.ScaleMode = vbPixels  
     cboLeft = cbo.Left  
     cboTop = cbo.Top  
     cboWidth = cbo.Width  
     cboHeight = frm.ScaleHeight - cbo.Top - 5  
     frm.ScaleMode = oldScaleMode  
     MoveWindow cbo.hwnd, cboLeft, cboTop, cboWidth, cboHeight, 1  
    End Sub

    'Для проверки работы примера, разместите на форме три элемента CommandButton, один элемент CheckBox и один OptionButton  
      
    Option Explicit  
      
    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long  
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long  
    Private Const GWL_STYLE = (-16)  
    Private Const BS_PUSHLIKE = &H1000&  
      
    Public Sub SetGraphicStyle(StyleButton As Control, Flag As Boolean)  
     Dim curstyle As Long  
     Dim newstyle As Long  
     If Not TypeOf StyleButton Is OptionButton And Not TypeOf StyleButton Is CheckBox Then Exit Sub  
     curstyle = GetWindowLong(StyleButton.hwnd, GWL_STYLE)  
     If Flag Then  
      curstyle = curstyle Or BS_PUSHLIKE  
     Else  
      curstyle = curstyle And (Not BS_PUSHLIKE)  
     End If  
     newstyle = SetWindowLong(StyleButton.hwnd, GWL_STYLE, curstyle)  
     StyleButton.Refresh  
    End Sub  
      
    Private Sub Command1_Click()  
     SetGraphicStyle Option1, True  
     SetGraphicStyle Check1, True  
    End Sub  
      
    Private Sub Command2_Click()  
     SetGraphicStyle Option1, False  
     SetGraphicStyle Check1, False  
    End Sub  
      
    Private Sub Command3_Click()  
     Option1.Value = False  
     Check1.Value = False  
    End Sub

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

    Option Explicit  
    'Пример удаления тегов из текста с использованием регулярных выражений  
    'Автор: Немиро Алексей, 07.11.2007  
    'http://kbyte.ru  
    'mailto:admin@kbyte.ru  
      
    Dim myRegEx As New RegExp  
      
    Private Sub Command1_Click()  
     myRegEx.Pattern = "<(.*?)>" '<(.*?)((/)|(.?))>(.*?)((</(.*?)>)|(.?))  
     myRegEx.Global = True  
     myRegEx.MultiLine = True  
     myRegEx.IgnoreCase = True  
     MsgBox myRegEx.Execute(Text1)(0)  
     Text2 = myRegEx.Replace(Text1, "")  
    End Sub

    Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long  
      
    Private Sub Command1_Click()  
    Dim strSysDir As String  
    Dim RetLen As Long  
    strSysDir = String$(256, Chr$(0))  
    RetLen = GetSystemDirectory(strSysDir, 255)  
    strSysDir = Left$(strSysDir, RetLen)  
    Print "Системная папка: " & strSysDir  
    End Sub

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

'Автор: Randy Birch  
'Добавьте на форму восемь кнопок и следующий код:  
  
Option Explicit  
  
Private Type NETRESOURCE  
  dwScope    As Long  
  dwType    As Long  
  dwDisplayType As Long  
  dwUsage    As Long  
  lpLocalName  As String  
  lpRemoteName As String  
  lpComment   As String  
  lpProvider  As String  
End Type  
  
  
  
   
Private Declare Function WNetAddConnection2 Lib "mpr" _  
  Alias "WNetAddConnection2A" _  
  (lpNetResource As NETRESOURCE, _  
  ByVal lpPassword As String, _  
  ByVal lpUserName As String, _  
  ByVal dwFlags As Long) As Long  
      
Private Declare Function WNetCancelConnection2 Lib "mpr" _  
  Alias "WNetCancelConnection2A" _  
  (ByVal lpName As String, _  
  ByVal dwFlags As Long, _  
  ByVal fForce As Long) As Long  
      
Private Declare Function WNetConnectionDialog Lib "mpr" _  
  (ByVal hwnd As Long, ByVal dwType As Long) As Long  
    
Private Declare Function WNetDisconnectDialog Lib "mpr" _  
  (ByVal hwnd As Long, ByVal dwType As Long) As Long  
  
'Private Const RESOURCE_CONNECTED = &H1  
'Private Const RESOURCE_REMEMBERED = &H3  
'Private Const RESOURCEDISPLAYTYPE_DOMAIN = &H1  
'Private Const RESOURCEDISPLAYTYPE_GENERIC = &H0  
'Private Const RESOURCEDISPLAYTYPE_SERVER = &H2  
'Private Const RESOURCEUSAGE_CONTAINER = &H2  
  
Private Const ERROR_SUCCESS = 0  
Private Const CONNECT_UPDATE_PROFILE = &H1  
Private Const RESOURCETYPE_DISK = &H1  
Private Const RESOURCETYPE_PRINT = &H2  
Private Const RESOURCETYPE_ANY = &H0  
Private Const RESOURCE_GLOBALNET = &H2  
Private Const RESOURCEDISPLAYTYPE_SHARE = &H3  
Private Const RESOURCEUSAGE_CONNECTABLE = &H1  
  
Private Declare Function ShellExecute Lib "shell32" _  
  Alias "ShellExecuteA" _  
  (ByVal hwnd As Long, _  
  ByVal lpOperation As String, _  
  ByVal lpFile As String, _  
  ByVal lpParameters As String, _  
  ByVal lpDirectory As String, _  
  ByVal nShowCmd As Long) As Long  
    
Private Const SW_SHOWNORMAL = 1  
  
       
Private Sub Command1_Click(Index As Integer)  
  
  Dim x As Long  
    
  Select Case Index  
   Case 0: 'Диалог подключения сетевого диска  
       'Если функция выполнена успешно, то возвращённое значение  
       'будет ERROR_SUCCESS (0). Если пользователь нажал "отмену"  
       'то вернётся значение &HFFFFFFFF (или -1).  
       '  
       'Если в функцию передать hwnd, то диалог отобразится  
       'модально по отношению к форме. Если вместо этого параметра  
       'передать 0&, то родительским будет рабочий стол.  
        Call WNetConnectionDialog(Me.hwnd, RESOURCETYPE_DISK)  
     
   Case 1: 'Отключение сетевого диска  
       'В случае удачи вернётся значение  
       'ERROR_SUCCESS (0). В случае отмены &HFFFFFFFF.  
       '  
       'Если в функцию передать hwnd, то диалог отобразится  
       'модально по отношению к форме. Если вместо этого параметра  
       'передать 0&, то родительским будет рабочий стол.  
        Call WNetDisconnectDialog(Me.hwnd, RESOURCETYPE_DISK)  
          
   Case 2: 'Подключаем сетевой принтер.  
       'если писать в одну строку, то должно быть так:  
       '"rundll32.exe shell32.dll,SHHelpShortcuts_RunDLL AddPrinter"  
       'без дополнительных пробелов.  
        Call Shell("rundll32.exe shell32.dll," & _  
             "SHHelpShortcuts_RunDLL AddPrinter", _  
              vbNormalFocus)  
       'В Windows NT, можно вызвать встроенный системный диалог  
       'подключения сетевого принтера при помощи API функции -  
       'ConnectToPrinterDlg. Однако этот диалог не получится  
       'вызвать из Visual Basic в Windows 95.  
       'Тем не менее, Вы должны использовать командную строку  
       'как описано в статье MSDN "Add Printer Wizard"  
       '(KB article Q154007)  
          
   Case 3: 'Отключаем сетевой принтер  
       'В случае удачи вернётся значение  
       'ERROR_SUCCESS (0). В случае отмены &HFFFFFFFF.  
       '  
       'Если в функцию передать hwnd, то диалог отобразится  
       'модально по отношению к форме. Если вместо этого параметра  
       'передать 0&, то родительским будет рабочий стол.  
        Call WNetDisconnectDialog(Me.hwnd, RESOURCETYPE_PRINT)  
     
   Case 4: 'Подключаем ресурс как букву диска  
        MsgBox ConnectThisNetworkDrive("\\someserver\c$", "G:")  
     
   Case 5: 'Подключаем ресурс к следующей свободной букве диска  
        MsgBox ConnectNextFreeNetworkDrive("\\someserver\c$")  
     
   Case 6: 'показываем проводник  
        Call ShellExecute(0&, "Open", _  
                 "explorer.exe", "/e,/n,c:\", _  
                 0&, SW_SHOWNORMAL)  
   Case 7: 'Завершаем программу  
        Unload Me  
     
  End Select  
    
End Sub  
  
  
Private Function ConnectNextFreeNetworkDrive(sServer As String) As String  
  
  Dim NETR As NETRESOURCE  
  Dim errInfo As Long  
  Dim x As Long  
  Dim testDrv As String  
    
 'устанавливаем первую букву как C (ASCII 67), а затем, в случае  
 'неудачи, увеличиваем её.  
  x = 67  
    
  Do  
     
   'пробуем использовать букву D:  
   x = x + 1  
   testDrv = Chr$(x) & ":"  
     
   With NETR  
     .dwScope = RESOURCE_GLOBALNET  
     .dwType = RESOURCETYPE_DISK  
     .dwDisplayType = RESOURCEDISPLAYTYPE_SHARE  
     .dwUsage = RESOURCEUSAGE_CONNECTABLE  
     .lpRemoteName = sServer  
     .lpLocalName = testDrv  
   End With  
     
   errInfo = WNetAddConnection2(NETR, _  
                  vbNullString, _  
                  "username", _  
                  CONNECT_UPDATE_PROFILE)  
     
  Loop Until x = 90 Or errInfo = ERROR_SUCCESS  '90 = "z"  
    
    
 'в случае удачи возвращаем диск  
  If errInfo = ERROR_SUCCESS Then  
     ConnectNextFreeNetworkDrive = testDrv  
  Else: ConnectNextFreeNetworkDrive = "no dice"  
  End If  
    
End Function  
  
  
Private Function ConnectThisNetworkDrive(sServer As String, _  
                     sDrv As String) As Boolean  
  
 'Пытаемся подключить сетевой ресурс  
 'как указанный диск.  
 'если всё впорядке, то ErrInfo=ERROR_SUCCESS  
  
  Dim NETR As NETRESOURCE  
  Dim errInfo As Long  
    
  With NETR  
   .dwScope = RESOURCE_GLOBALNET  
   .dwType = RESOURCETYPE_DISK  
   .dwDisplayType = RESOURCEDISPLAYTYPE_SHARE  
   .dwUsage = RESOURCEUSAGE_CONNECTABLE  
   .lpRemoteName = sServer  
   .lpLocalName = sDrv  
  End With  
    
  errInfo = WNetAddConnection2(NETR, _  
                vbNullString, _  
                "username", _  
                CONNECT_UPDATE_PROFILE)  
    
  ConnectThisNetworkDrive = errInfo = ERROR_SUCCESS  
  
End Function

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

    Dim tFile As String  
        tFile = ""  
        tFile = Path.GetTempFileName()  
        Dim myFileInfo As New FileInfo(tFile)  
        myFileInfo.Attributes = FileAttributes.Temporary  
      
        Using Wr As StreamWriter = New StreamWriter(tFile, False, Encoding.GetEncoding(1251))  
          Wr.WriteLine("№ п.п." & vbTab & _  
                 "ФИО." & vbTab & _  
                 "Дата рожд." & vbTab & _  
                 "Место рождения" & vbTab & _  
                 "Пол" & vbTab & _  
                 "Примечание.")  
          For i = 1 To fTab.GetUpperBound(0)  
            Wr.WriteLine(i & vbTab & _  
             fTab(i).FIO & vbTab & _  
             fTab(i).DatR & vbTab & _  
             fTab(i).Mest & vbTab & _  
             fTab(i).Pol & vbTab & _  
             fTab(i).Prim)  
            My.Application.DoEvents()  
          Next  
          Wr.Close()  
        End Using  
        Dim oExcel As New Microsoft.Office.Interop.Excel.Application  
        Dim oBook As Microsoft.Office.Interop.Excel.Workbook  
        Dim oSheet As Microsoft.Office.Interop.Excel.Worksheet  
        oExcel = New Microsoft.Office.Interop.Excel.Application  
        oBook = oExcel.Workbooks.Open(tFile)  
        oSheet = oBook.Sheets(1)  
        oExcel.Visible = True  
        oSheet.Rows("1:1").HorizontalAlignment = -4108  
        oSheet.Rows("1:1").VerticalAlignment = -4108  
        oSheet.Rows("1:1").Font.FontStyle = "полужирный"  
        oSheet.Columns("A:A").HorizontalAlignment = -4108  
        oSheet.Columns("A:A").VerticalAlignment = -4108  
        oSheet.Columns("B:B").HorizontalAlignment = -4108  
        oSheet.Columns("B:B").VerticalAlignment = -4108  
        oSheet.Columns("C:C").HorizontalAlignment = -4108  
        oSheet.Columns("C:C").VerticalAlignment = -4108  
        oSheet.Columns("F:F").HorizontalAlignment = -4108  
        oSheet.Columns("F:F").VerticalAlignment = -4108  
        oSheet.Columns("C:C").Interior.ColorIndex = 35  
        oSheet.Columns("E:E").Interior.ColorIndex = 35  
        oSheet.Cells.EntireColumn.AutoFit()  
        oSheet.Range("A2").Select()  
        oExcel.ActiveWindow.FreezePanes = True  
    End Sub

    Public Function nasRound(Num As Double, d As Integer) As Double  
     Dim a As Double  
     Dim r As Double  
     Dim b As Double  
     a = Num Mod d  
     If a > (d / 2) Then  
      b = d - a  
      r = Num + b  
     Else  
      r = Num - a  
     End If  
     nasRound = r  
    End Function

    Private Sub Command1_Click()  
    'генерирует случайное число от 0 до 99  
    Randomize 'перемешиваем счетчик относительно системного времени
    MsgBox Int(100 * Rnd)  
    End Sub

    'Установите свойство формы AutoRedraw как True  
    Private Sub Form_Load()   
    Dim ShadowX   
    Dim ShadowY   
    ScaleMode = 3   
    ForeColor = "&H808080"   
    ShadowY = 5   
    ShadowX = 5   
    For I = 0 To 5   
    CurrentX = ShadowX + I   
    CurrentY = ShadowY + I   
    If I = 5 Then Form1.ForeColor = vbWhite   
    Form1.Print "3D Text!!!"   
    Next   
    End Sub

    Function FIO(fi As String, im As String, ot As String, pol As String) As String  
      
    fi = StrConv(Trim(fi), vbLowerCase)  
    im = StrConv(Trim(im), vbLowerCase)  
    ot = StrConv(Trim(ot), vbLowerCase)  
    pol = pol  
      
      
    fi_s = Len(fi)  
    im_s = Len(im)  
    ot_s = Len(ot)  
    If pol = "ж" Then  
        
      For i = fi_s To fi_s - (fi_s + 2) Step -1  
      If fi_s = 0 Then GoTo fi  
      k = Mid(fi, i, 1)  
        If k = "а" Or k = "у" Or k = "е" Or k = "э" Or k = "о" Or _  
          k = "я" Or k = "и" Or k = "ю" Then  
           k = Mid(fi, i - 1, 1)  
            If k = "а" Or k = "у" Or k = "е" Or k = "э" Or k = "о" Or _  
                k = "я" Or k = "и" Or k = "ю" Then  
              
            Else  
              k = Mid(fi, i - 2, 1)  
              
              If k = "а" Or k = "у" Or k = "е" Or k = "э" Or k = "о" Or _  
                k = "я" Or k = "и" Or k = "ю" Then  
                fi_str = Left(fi, i - 1) & "ой"  
                Exit For  
              Else  
              
                fi_str = fi  
                Exit For  
              End If  
              
            End If  
              
        Else  
          fi_str = fi  
          Exit For  
        End If  
      Next  
    fi:  
      For i = im_s To im_s - (im_s + 2) Step -1  
         If im_s = 0 Then GoTo im  
         k = Mid(im, i, 1)  
        'MsgBox k  
        If k = "а" Or k = "у" Or k = "е" Or k = "э" Or k = "о" Or _  
          k = "я" Or k = "и" Or k = "ю" Then  
          'If i > 1 Then  
            k = Mid(im, i - 1, 1)  
            If k = "а" Or k = "у" Or k = "е" Or k = "э" Or k = "о" Or _  
                k = "я" Or k = "и" Or k = "ю" Then  
              im_str = Left(im, i - 2) & "ии"  
              Exit For  
              
            Else  
              im_str = Left(im, i - 1) & "е"  
              Exit For  
            End If  
          'End If  
        ElseIf k = "ь" Then  
          im_str = Left(im, i - 1) & "и"  
          Exit For  
        Else  
          im_str = im  
          Exit For  
        End If  
      Next  
    im:  
      If ot_s <> 0 Then  
        ot_str = Left(ot, Len(ot) - 1) & "е"  
      End If  
    ElseIf pol = "м" Then  
      'MsgBox "м - пол не готов"  
        
      For i = fi_s To fi_s - (fi_s + 2) Step -1  
      If fi_s = 0 Then GoTo fi1  
      k = Mid(fi, i, 1)  
        If k = "а" Or k = "у" Or k = "е" Or k = "э" Or k = "о" Or _  
          k = "я" Or k = "и" Or k = "ю" Then  
          fi_str = fi  
          Exit For  
        Else  
          fi_str = fi & "у"  
          Exit For  
            
        End If  
      Next  
    fi1:  
      For i = im_s To im_s - (im_s + 2) Step -1  
      If im_s = 0 Then GoTo im1  
        k = Mid(im, i, 1)  
        If k = "й" Or k = "ь" Then  
          im_str = Left(im, Len(im) - 1) & "ю"  
          Exit For  
        Else  
          im_str = im & "у"  
          Exit For  
        End If  
      Next  
    im1:  
      If ot_s <> 0 Then  
        ot_str = ot & "у"  
      End If  
    End If  
    FIO = StrConv(fi_str, vbProperCase) & " " & StrConv(im_str, vbProperCase) & " " & StrConv(ot_str, vbProperCase)  
    End Function  
      
      
    Function FIO(fi As String, im As String, ot As String, pol As String) As String  
      
    fi = StrConv(Trim(fi), vbLowerCase)  
    im = StrConv(Trim(im), vbLowerCase)  
    ot = StrConv(Trim(ot), vbLowerCase)  
    pol = pol  
      
      
    fi_s = Len(fi)  
    im_s = Len(im)  
    ot_s = Len(ot)  
    If pol = "ж" Then  
        
      For i = fi_s To fi_s - (fi_s + 2) Step -1  
      If fi_s = 0 Then GoTo fi  
      k = Mid(fi, i, 1)  
        If k = "а" Or k = "у" Or k = "е" Or k = "э" Or k = "о" Or _  
          k = "я" Or k = "и" Or k = "ю" Then  
           k = Mid(fi, i - 1, 1)  
            If k = "а" Or k = "у" Or k = "е" Or k = "э" Or k = "о" Or _  
                k = "я" Or k = "и" Or k = "ю" Then  
              
            Else  
              k = Mid(fi, i - 2, 1)  
              
              If k = "а" Or k = "у" Or k = "е" Or k = "э" Or k = "о" Or _  
                k = "я" Or k = "и" Or k = "ю" Then  
                fi_str = Left(fi, i - 1) & "ой"  
                Exit For  
              Else  
              
                fi_str = fi  
                Exit For  
              End If  
              
            End If  
              
        Else  
          fi_str = fi  
          Exit For  
        End If  
      Next  
    fi:  
      For i = im_s To im_s - (im_s + 2) Step -1  
         If im_s = 0 Then GoTo im  
         k = Mid(im, i, 1)  
        'MsgBox k  
        If k = "а" Or k = "у" Or k = "е" Or k = "э" Or k = "о" Or _  
          k = "я" Or k = "и" Or k = "ю" Then  
          'If i > 1 Then  
            k = Mid(im, i - 1, 1)  
            If k = "а" Or k = "у" Or k = "е" Or k = "э" Or k = "о" Or _  
                k = "я" Or k = "и" Or k = "ю" Then  
              im_str = Left(im, i - 2) & "ии"  
              Exit For  
              
            Else  
              im_str = Left(im, i - 1) & "е"  
              Exit For  
            End If  
          'End If  
        ElseIf k = "ь" Then  
          im_str = Left(im, i - 1) & "и"  
          Exit For  
        Else  
          im_str = im  
          Exit For  
        End If  
      Next  
    im:  
      If ot_s <> 0 Then  
        ot_str = Left(ot, Len(ot) - 1) & "е"  
      End If  
    ElseIf pol = "м" Then  
      'MsgBox "м - пол не готов"  
        
      For i = fi_s To fi_s - (fi_s + 2) Step -1  
      If fi_s = 0 Then GoTo fi1  
      k = Mid(fi, i, 1)  
        If k = "а" Or k = "у" Or k = "е" Or k = "э" Or k = "о" Or _  
          k = "я" Or k = "и" Or k = "ю" Then  
          fi_str = fi  
          Exit For  
        Else  
          fi_str = fi & "у"  
          Exit For  
            
        End If  
      Next  
    fi1:  
      For i = im_s To im_s - (im_s + 2) Step -1  
      If im_s = 0 Then GoTo im1  
        k = Mid(im, i, 1)  
        If k = "й" Or k = "ь" Then  
          im_str = Left(im, Len(im) - 1) & "ю"  
          Exit For  
        Else  
          im_str = im & "у"  
          Exit For  
        End If  
      Next  
    im1:  
      If ot_s <> 0 Then  
        ot_str = ot & "у"  
      End If  
    End If  
    FIO = StrConv(fi_str, vbProperCase) & " " & StrConv(im_str, vbProperCase) & " " & StrConv(ot_str, vbProperCase)  
    End Function

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

    Private Declare Function GetWindowLong& Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long)  
    Private Declare Function SetWindowLong& Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long)  
    Private Const A_CENTER = &H300&  
    Private Const A_TOP = &H400&  
    Private Const A_TOPLEFT = &H500&  
    Private Const A_TOPRIGHT = &H600&  
    Private Const A_BOTTOM = &H800&  
    Private Const A_BOTTOMLEFT = &H900&  
    Private Const A_BOTTOMRIGHT = &HA00&  
    Private Const A_LEFT = &H100&  
    Private Const A_RIGHT = &H200&  
    Private Const GWL_STYLE& = (-16)  
      
    Private Sub Form_Load()  
     Dim tmpValue As Long, Align As Long, ret As Long  
     fAlignment = A_BOTTOMRIGHT  
     tmpValue = GetWindowLong&(Command1.hwnd, GWL_STYLE) And Not BS_RIGHT  
     ret = SetWindowLong&(Command1.hwnd, GWL_STYLE, tmpValue Or fAlignment)  
     Command1.Refresh  
    End Sub

    ListView1.Groups.Add(New ListViewGroup("Group 1", HorizontalAlignment.Left))
 
'Добавить группу     или  
      
    ListView1.Groups.Add("Group 1", HorizontalAlignment.Left))  
    ListView1.Groups.RemoveAt(0)'Удалить одну группу  
    ListView1.Groups.Clear()'удалить все группы  
    ListView1.Items.Item(0).Group = ListView1.Groups(0)'Установить группу

    Private Sub Form_Load()  
     Dim strMail As String  
    rep:  
     strMail = InputBox("Введите e-mail:")  
     If Len(strMail) <= 0 Then MsgBox "E-Mail не указан!": GoTo rep  
     If InStr(1, strMail, "@") <= 0 Or InStr(1, strMail, ".") <= 0 Then MsgBox "Указан некорректный e-mail!": GoTo rep  
     MsgBox "Спасибо! Ваш e-mail - " & strMail  
    End Sub

Public conn As New ADODB.Connection
Public rs As New ADODB.Recordset
 
Public conn2 As New ADODB.Connection
Public rs2 As New ADODB.Recordset
Public rs3 As New ADODB.Recordset
 
Sub Main()
 
    OpenDB
    Form1.Show
 
End Sub
 
Sub OpenDB()
    Set conn = Nothing
    Set conn = New ADODB.Connection
    conn = "Provider=SQLNCLI10;Server=ИМЯСЕРВЕРА;Database=ИМЯ БАЗЫ ДАННЫХ;Trusted_Connection=yes;"
    conn.Open
    If conn.State = 1 Then
        MsgBox "Ñîåäèíåíèå óñòàíîâëåíî"
    Else
        MsgBox "Ñîåäèíåíèå íå óñòàíîâëåíî"
    End If

Private Sub Form_Load()
    Call UpdateConnect
End Sub
 
Sub UpdateConnect()
    Set rs = Nothing
    Set rs = New ADODB.Recordset
    SQL = "ВАШ SQL ЗАПРОС"
    rs.Open SQL, conn, 3, 3
    Set DataGrid1.DataSource = rs
End Sub

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

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 Function DeleteMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private Declare Function GetSystemMenu Lib "user32" (ByVal hWnd As Long, ByVal bRevert As Long) As Long
 
Private Const MF_BYPOSITION = &H400&
 
Private Sub Form_Load()
    RemoveMenus
End Sub
 
Private Sub RemoveMenus()
    Dim hMenu As Long
    ' Получаем дескриптор системного меню формы.
    hMenu = GetSystemMenu(hWnd, False)
    DeleteMenu hMenu, 6, MF_BYPOSITION
End Sub

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

Private Sub Form_Load()
  SetKeyboardHook
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
  RemoveKeyboardHook
End Sub

Option Explicit
Private Sub Command1_Click()
   Dim i As Integer, s As String, ss As String
   s = "/\:*?<>|" & Chr(34)
   For i = 1 To Len(s)
      ss = ss + Str(Asc(Mid(s, i, 1)))
   Next i
   MsgBox ss
   Debug.Print ss
End Sub
Private Function false_symbol(sfalse As String) As Boolean
   Dim i As Integer, s As String
   s = "/\:*?<>|" & Chr(34)    ' Èñêëþ÷åíèÿ (34 - êàâû÷êè)
   false_symbol = InStr(1, s, sfalse)
End Function
Private Sub Form_Load()
   Label1.Caption = "Çàïðåùåíû ñèìâîëû: " & "/\:*?<>|" & Chr(34)
End Sub
Private Sub Text1_KeyPress(KeyAscii As Integer)
   Text1.Locked = false_symbol(Chr(KeyAscii))
End Sub

Option Explicit
Private Declare Function mciExecute Lib "winmm.dll" (ByVal lpstrCommand As String) As Long
Dim p As String
Private Sub Form_Load()
p = "c:\101.mp3"
End Sub
'воспроизводим файл
Private Sub Command2_Click()
Dim f As Long, s As String
s = StrConv(LoadResData(101, "CUSTOM"), vbUnicode)
f = FreeFile
Open p For Binary As #f
Put #f, , s
Close #f
Call mciExecute("play " & p)
End Sub
 
'стоп
Private Sub Command1_Click()
On Error Resume Next
Call mciExecute("close " & p)
Kill p
End Sub

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

Private Sub Command1_Click()
Label1.Caption = Environ("SYSTEMROOT") ' Путь к папке Windows
Label2.Caption = Environ("TEMP") ' Путь к системному TEMP
Label3.Caption = Environ("PATH") ' Пути поиска исполняемых файлов
End Sub

Private Sub Command1_Click()
  Dim EnvString As String, tmpString As String
  Dim m As Integer
   m = 1
   Do
     EnvString = Environ(m)
     tmpString = tmpString & Chr(13) & Environ(m)
     m = m + 1
   Loop Until EnvString = ""
   MsgBox tmpString
End Sub

Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Sub Djek() 'одна страница
Dim Lex(1 To 10000) As String, s1$, ii&, s$
'Путь по которому сохраняем скачанную страницу
s1 = Environ("temp") & "\Temp_2.log"
'URL страницы
s = "http://nato-ukr.narod.ru"
'загружаем страницу
URLDownloadToFile 0, s, s1, 0, 0
    fi% = FreeFile
    'удаляем тэги
    Open s1 For Binary Access Read As #fi%
      LF& = LOF(fi%)
      Buf$ = Space$(LF&)
      Get #fi%, , Buf$
    Close #fi%
    Parse Buf$, Lex$, n%
    For i% = 1 To n%
      'выводим строки длинной более трёх символов .  
      If Len(Lex(i%)) > 3 Then
        ii = ii + 1
        'выводим в окно отладки
        Debug.Print Lex(i%)
      End If
    Next i%
Kill s1
End Sub
 
Sub Parse(Buf As String, Lex() As String, ptr As Integer)
'функция очистки от тэгов написаная уважаемым Catstail
Tmp$ = ""
ptr = 0
For i& = 1 To Len(Buf)
  s$ = Mid$(Buf, i&, 1)
  Select Case (s$)
  Case Chr$(10), Chr$(13)
    Case ">"
      Tmp$ = Trim$(Tmp$)
      If (Left$(Tmp$, 1) <> "<") And _
         (Left$(Tmp$, 1) <> "/") And _
         (Left$(Tmp$, 1) <> ">") And _
         Len(Tmp$) > 0 Then
         ptr% = ptr% + 1
         Lex(ptr%) = Tmp$
      End If
      Tmp$ = ""
    Case "<"
      Tmp$ = Trim$(Tmp$)
      If (Left$(Tmp$, 1) <> "<") And _
         (Left$(Tmp$, 1) <> "/") And _
         (Left$(Tmp$, 1) <> ">") And _
         Len(Tmp$) > 0 Then
         ptr% = ptr% + 1
         Lex(ptr%) = Tmp$
      End If
      Tmp$ = "<"
    Case Else
      Tmp$ = Tmp$ + s$
  End Select
Next i&
End Sub

Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
 
    Sub main()
       s = I_PI
   End Sub 
 
   Private Function I_PI()
     Dim s, ss$, s1$, i&, sx$, ii&, sa$
      s1 = Environ("temp") & "\Aut_22.txt"
      s = "http://www.softholm.com/services/address_ip.php"
      URLDownloadToFile 0, s, s1, 0, 0
      ss = "Ваш IP адрес: <b>"
       Open s1 For Input As #1
         While Not EOF(1)
           Line Input #1, s
           If InStr(s, ss) > 0 Then
             i = InStr(s, ss) + Len(ss)
             ii = i
               Do
                sa = Mid(s, ii, 1)
                ii = ii + 1
                sx = sx & sa
               Loop Until sa = "<"
             sx = Mid(sx, 1, Len(sx) - 1)
             GoTo xren
           End If
        Wend
xren:
      Close #1
      Kill s1
      MsgBox sx
        ' Копируем Ваш IP адрес в буфер обмена
         With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
           .SetText sx
           .PutInClipboard
        End With
 
      I_PI = sx
   End Function

Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Public Event ErrorDownload(FromPathName As String, ToPathName As String)
Public Event DownloadComplete(FromPathName As String, ToPathName As String)
 
 
Public Function DownloadFile(FromPathName As String, ToPathName As String)
If URLDownloadToFile(0, FromPathName, ToPathName, 0, 0) = 0 Then
    DownloadFile = True
    RaiseEvent DownloadComplete(FromPathName, ToPathName)
  Else
    DownloadFile = False
    RaiseEvent ErrorDownload(FromPathName, ToPathName)
End If
End Function
 
Private Sub Command1_Click()
Label2.Caption "IP Host Name: " & GetIPHostName()
Label1.Caption "IP Address: " & GetIPAddress()
Call DownloadFile("http://visua/Banner.htm", "c:\ttt.htm")
End Sub

'Добавьте модуль в проект
 
Public Const MAX_WSADescription = 256
Public Const MAX_WSASYSStatus = 128
Public Const ERROR_SUCCESS As Long = 0
Public Const WS_VERSION_REQD As Long = &H101
Public Const WS_VERSION_MAJOR As Long = WS_VERSION_REQD \ &H100 And &HFF&
Public Const WS_VERSION_MINOR As Long = WS_VERSION_REQD And &HFF&
Public Const MIN_SOCKETS_REQD As Long = 1
Public Const SOCKET_ERROR As Long = -1
 
Public Type HOSTENT
    hName As Long
    hAliases As Long
    hAddrType As Integer
    hLen As Integer
    hAddrList As Long
End Type
 
Public Type WSADATA
    wVersion As Integer
    wHighVersion As Integer
    szDescription(0 To MAX_WSADescription) As Byte
    szSystemStatus(0 To MAX_WSASYSStatus) As Byte
    wMaxSockets As Integer
    wMaxUDPDG As Integer
    dwVendorInfo As Long
End Type
 
Public Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long
Public Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired As Long, lpWSADATA As WSADATA) As Long
Public Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
Public Declare Function gethostname Lib "WSOCK32.DLL" (ByVal szHost As String, ByVal dwHostLen As Long) As Long
Public Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal szHost As String) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
 
 
Public Function GetIPAddress() As String
Dim sHostName As String * 256
Dim lpHost As Long
Dim HOST As HOSTENT
Dim dwIPAddr As Long
Dim tmpIPAddr() As Byte
Dim i As Integer
Dim sIPAddr As String
 
If Not SocketsInitialize() Then
    GetIPAddress = ""
    Exit Function
End If
 
If gethostname(sHostName, 256) = SOCKET_ERROR Then
    GetIPAddress = ""
    MsgBox "Windows Sockets error " & Str$(WSAGetLastError()) & " has occurred. Unable to successfully get Host Name."
    SocketsCleanup
    Exit Function
End If
 
sHostName = Trim$(sHostName)
lpHost = gethostbyname(sHostName)
 
If lpHost = 0 Then
    GetIPAddress = ""
    MsgBox "Windows Sockets are not responding. " & "Unable to successfully get Host Name."
    SocketsCleanup
    Exit Function
End If
 
CopyMemory HOST, lpHost, Len(HOST)
CopyMemory dwIPAddr, HOST.hAddrList, 4
 
ReDim tmpIPAddr(1 To HOST.hLen)
 
CopyMemory tmpIPAddr(1), dwIPAddr, HOST.hLen
 
For i = 1 To HOST.hLen
    sIPAddr = sIPAddr & tmpIPAddr(i) & "."
Next
 
GetIPAddress = Mid$(sIPAddr, 1, Len(sIPAddr) - 1)
 
SocketsCleanup
 
End Function
 
 
Public Function GetIPHostName() As String
Dim sHostName As String * 256
 
If Not SocketsInitialize() Then
    GetIPHostName = ""
    Exit Function
End If
 
If gethostname(sHostName, 256) = SOCKET_ERROR Then
    GetIPHostName = ""
    MsgBox "Windows Sockets error " & Str$(WSAGetLastError()) & " has occurred. Unable to successfully get Host Name."
    SocketsCleanup
    Exit Function
End If
 
GetIPHostName = Left$(sHostName, InStr(sHostName, Chr(0)) - 1)
 
SocketsCleanup
 
End Function
 
 
Public Function HiByte(ByVal wParam As Integer)
HiByte = wParam \ &H100 And &HFF&
End Function
 
 
Public Function LoByte(ByVal wParam As Integer)
LoByte = wParam And &HFF&
End Function
 
 
Public Sub SocketsCleanup()
If WSACleanup() <> ERROR_SUCCESS Then
    MsgBox "Socket error occurred in Cleanup."
End If
End Sub
 
 
Public Function SocketsInitialize() As Boolean
Dim WSAD As WSADATA
Dim sLoByte As String
Dim sHiByte As String
 
If WSAStartup(WS_VERSION_REQD, WSAD) <> ERROR_SUCCESS Then
    MsgBox "The 32-bit Windows Socket is not responding."
    SocketsInitialize = False
    Exit Function
End If
 
If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then
    MsgBox "This application requires a minimum of " & CStr(MIN_SOCKETS_REQD) & " supported sockets."
    SocketsInitialize = False
    Exit Function
End If
 
If LoByte(WSAD.wVersion) < WS_VERSION_MAJOR Or (LoByte(WSAD.wVersion) = WS_VERSION_MAJOR And HiByte(WSAD.wVersion) < WS_VERSION_MINOR) Then
    sHiByte = CStr(HiByte(WSAD.wVersion))
    sLoByte = CStr(LoByte(WSAD.wVersion))
    MsgBox "Sockets version " & sLoByte & "." & sHiByte & " is not supported by 32-bit Windows Sockets."
    SocketsInitialize = False
    Exit Function
End If
 
SocketsInitialize = True
 
End Function

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

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

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

Dim Categories As Node
 
Private Sub Form_Load()
With TreeView1.Nodes
    Set cat = .Add(, , "root", "Первая главная ветка")
    Set cat = .Add("root", tvwChild, , "1 ветка")
    Set cat = .Add("root", tvwChild, , "2 ветка")
    Set cat = .Add("root", tvwChild, , "3 ветка")
    
    Set cat = .Add(, , "root1", "Вторая главная ветка")
    Set cat = .Add("root1", tvwChild, , "1 ветка второй главной ветки")
    Set cat = .Add("root1", tvwChild, , "2 ветка второй главной ветки")
    Set cat = .Add("root1", tvwChild, , "3 ветка второй главной ветки")
End With
End Sub
 
Private Sub TreeView1_NodeClick(ByVal Node As MSComctlLib.Node)
Select Case Node
    Case Is = "1 ветка"
        MsgBox "Вы выбрали 1 ветку"
    Case Is = "2 ветка"
        MsgBox "Вы выбрали 2 ветку"
    Case Is = "3 ветка"
        MsgBox "Вы выбрали 3 ветку"
End Select
End Sub

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