Программирование на Visual Basic

16. Этот код очень часто используется при разработке бухгалтерских систем, где требуется не только написать сумму, но и вывести ее прописью. Инструкция центробанка требует еще и разделение цифр не точкой, а дефисом -.

Const SPACE As String = " " 'Определяет число пробелов между словами

'==============================================================
' Назначение:
'    Перевод числа в строковую константу
' Параметры
'    curMoney - сумма, которую надо перевести в строку
'    flagBank - указывает какую сумму надо вернуть
' Пример:
'    funRusMoney(678.56) = "Шестьсот семьдесят восемь рублей 56 копеек"
'
Public Function funRusMoney(curMoney As Currency, flagBank) As String
Dim myMoney As Currency 'Все деньги
Dim myRoubles As Long 'Только рубли
Dim myCopecks As Long 'Только копейки
Dim iGroup As Long 'Группировка по разрядам
Dim s As String 'Промежуточная переменная
    
    On Error GoTo 999
    'Проведем округление абслютного результата до 2х разрядов.
    'Иногда бывает в функцию передается результат: -678,56001,
    'а нам нужен 678,56
    myMoney = Format(Abs(curMoney), "0.00")
    
    'Проверка входящей суммы
    If myMoney  2147483647.99 Then
        MsgBox "Очень большое число: "  Format(curMoney, "Currency")  vbCrLf  _
               "Максимальное число: 2 147 483 647,99", vbExclamation, "Сумма прописью"
               funRusMoney = "Слишком большое число: "  curMoney
        Exit Function
    End If
    
    'Определяем рубли и копейки
    myRoubles = CLng(Fix(myMoney))
    myCopecks = (myMoney - Fix(myMoney)) * 100
    
    If myRoubles  0 Then 'Есть рубли
        'Миллиарды рублей
        s = funTextMoney(myRoubles, myCopecks, 1000000000, "М", iGroup)
        'Миллионы рублей
        s = s  funTextMoney(myRoubles, myCopecks, 1000000, "М", iGroup)
        'Тысячи рублей
        s = s  funTextMoney(myRoubles, myCopecks, 1000, "Ж", iGroup)
        'Cотни рублей
        s = s  funTextMoney(myRoubles, myCopecks, 1, "М", iGroup)
        'Дописываем рубли
        s = s  strRoubles(iGroup)
    Else 'Нет рублей
        s = "0 рублей"  SPACE
    End If
    'Добавляем копейки прописью
    If (flagBank = True) And (myCopecks = 0) Then
        'не добавляем копеек по инструкции Центробанка
    Else
        s = s  strCopecks(myCopecks) 'Дописываем копейки
    End If
    
    'Вывод текста c Заглавной буквы
    funRusMoney = UCase(Mid(s, 1, 1))  Mid(s, 2)
    Exit Function
999:
    MsgBox Err.Description, vbCritical, "Сумма прописью"
    funRusMoney = "Ошибка в прописи суммы: "  curMoney
    Err.Clear
End Function

'==============================================================
' Назначение:
'    Перевод для разных групп чисел в строковую константу
' Параметры
'    myRoubles - рубли
'    myCopecks - копейки
'    iSize - размер группы (1, 1000, ...)
'    sSex - пол группы (М - мужской, Ж - женский)
' Пример:
'    funTextMoney(678,25,1,"М") = _
'                "шестьсот семьдесят восемь рублей 25 копеек"
'
Public Function funTextMoney( _
    myRoubles As Long, _
    myCopecks As Long, _
    iSize As Long, _
    sSex As String, _
    iGroup As Long _
    ) As String

Dim iBlock As Long 'Блок данных
Dim sOut As String 'Выходная строка

    sOut = "" 'Инициализация переменной
    iGroup = myRoubles \ iSize 'Возвращем число 0-999
    If (iGroup  0) Then
        iBlock = iGroup \ 100 'Вернуть сотни
        sOut = sOut  strHundreds(iBlock) 'Вернуть текст
        myRoubles = myRoubles - iBlock * 100 * iSize 'Оставшаяся сумма
        
        iGroup = iGroup - iBlock * 100 'Возвращем число 0-99
        If iGroup  19 Then
            iBlock = iGroup \ 10 'Вернуть десятки
            sOut = sOut  strTens(iBlock) 'Вернуть текст
            myRoubles = myRoubles - iBlock * 10 * iSize 'Оставшаяся сумма
            iGroup = iGroup - iBlock * 10 'Возвращем число 0-9
        End If

        sOut = sOut  strOne(iGroup, sSex) 'Вернуть текст
        myRoubles = myRoubles - iGroup * iSize  'Оставшаяся сумма
        
        'Добавляем текст в конец строки
        Select Case iSize
            Case 1000000000: sOut = sOut  strBillions(iGroup)
            Case 1000000: sOut = sOut  strMillions(iGroup)
            Case 1000: sOut = sOut  strThousand(iGroup)
        End Select
    End If
    
    'Возвращаем текст
    funTextMoney = sOut
End Function

'==============================================================
' Назначение:
'       вернуть миллиарды прописью
' Пример:
'       strBillions(2) = "миллиард"
'
Function strBillions(iBlock As Long) As String
    Select Case iBlock
        Case 1:      strBillions = "миллиард"
        Case 2 To 4: strBillions = "милиарда"
        Case Else:   strBillions = "миллиардов"
    End Select
    strBillions = strBillions  SPACE
End Function

'==============================================================
' Назначение:
'       вернуть миллионы прописью
' Пример:
'       strMillions(2) = "миллиона"
'
Public Function strMillions(iBlock As Long) As String
    Select Case iBlock
        Case 1:      strMillions = "миллион"
        Case 2 To 4: strMillions = "миллиона"
        Case Else:   strMillions = "миллионов"
    End Select
    strMillions = strMillions  SPACE
End Function

'==============================================================
' Назначение:
'       вернуть тысячи прописью
' Пример:
'       strThousand(2) = "тысячи"
'
Public Function strThousand(iBlock As Long) As String
    Select Case iBlock
        Case 1:      strThousand = "тысяча"
        Case 2 To 4: strThousand = "тысячи"
        Case Else:   strThousand = "тысяч"
    End Select
    strThousand = strThousand  SPACE
End Function

'==============================================================
' Назначение:
'       вернуть сотни прописью
' Пример:
'       strHundreds(2)="двести"
'
Public Function strHundreds(iBlock As Long) As String
    Select Case iBlock
         Case 1:  strHundreds = "сто"
         Case 2:  strHundreds = "двести"
         Case 3:  strHundreds = "триста"
         Case 4:  strHundreds = "четыреста"
         Case 5:  strHundreds = "пятьсот"
         Case 6:  strHundreds = "шестьсот"
         Case 7:  strHundreds = "семьсот"
         Case 8:  strHundreds = "восемьсот"
         Case 9:  strHundreds = "девятьсот"
    End Select
    If iBlock  0 Then strHundreds = strHundreds  SPACE
End Function

'==============================================================
' Назначение:
'       вернуть десятки прописью
' Пример:
'       strTens(3) = "тридцать"
'
Public Function strTens(iBlock As Long) As String
    Select Case iBlock
         Case 2: strTens = "двадцать"
         Case 3: strTens = "тридцать "
         Case 4: strTens = "сорок"
         Case 5: strTens = "пятьдесят"
         Case 6: strTens = "шестьдесят"
         Case 7: strTens = "семьдесят"
         Case 8: strTens = "восемьдесят"
         Case 9: strTens = "девяносто"
    End Select
    If iBlock  0 Then strTens = strTens  SPACE
End Function

'==============================================================
' Назначение:
'       вернуть единицы прописью
' Пример:
'       strOne(2, "М")="два"
Public Function strOne(iBlock As Long, sSex As String) As String
    Select Case iBlock
        Case 1, 2
            Select Case iBlock  sSex 'Определяем пол
            Case "1М": strOne = "один" 'Мужской пол
            Case "2М": strOne = "два" 'Мужской пол
            Case "1Ж": strOne = "одна" 'Женский пол
            Case "2Ж": strOne = "две" 'Женский пол
            End Select
        Case 3:   strOne = "три"
        Case 4:   strOne = "четыре"
        Case 5:   strOne = "пять"
        Case 6:   strOne = "шесть"
        Case 7:   strOne = "семь"
        Case 8:   strOne = "восемь"
        Case 9:   strOne = "девять"
        Case 10:  strOne = "десять"
        Case 11:  strOne = "одиннадцать"
        Case 12:  strOne = "двенадцать"
        Case 13:  strOne = "тринадцать"
        Case 14:  strOne = "четырнадцать"
        Case 15:  strOne = "пятнадцать"
        Case 16:  strOne = "шестнадцать"
        Case 17:  strOne = "семнадцать"
        Case 18:  strOne = "восемнадцать"
        Case 19:  strOne = "девятнадцать"
    End Select
    If iBlock  0 Then strOne = strOne  SPACE
End Function

'==============================================================
' Назначение:
'       вернуть копейки прописью
' Пример:
'       strCopecks(56) = "56 копеек"
'
Public Function strCopecks(myCopecks As Long) As String
Dim r As Integer 'разряд копеек
    'Записываем копейки
    strCopecks = Format(myCopecks, "00")  SPACE
    
    'Определяем разряд копеек
    r = myCopecks
    If myCopecks  20 Then r = r - Fix(r / 10) * 10
    Select Case r 'Составляем текст
        Case 1:      strCopecks = strCopecks  "копейка"
        Case 2 To 4: strCopecks = strCopecks  "копейки"
        Case Else:   strCopecks = strCopecks  "копеек"
    End Select
End Function

'==============================================================
' Назначение:
'       вернуть название рублей прописью
' Пример:
'       strRoubles(2) = "рубля"
'
Public Function strRoubles(iBlock As Long) As String
    Select Case iBlock
        Case 1:      strRoubles = "рубль"
        Case 2 To 4: strRoubles = "рубля"
        Case Else:   strRoubles = "рублей"
    End Select
    strRoubles = strRoubles  SPACE
End Function

'==============================================================
' Назначение:
'       вернуть сумму по инструкции центробанка
'
Public Function strConvBank(curMoney As Currency) As String
Dim myCopecks As Long
'    strConvBank = Format(curMoney, "0") 'Формат рублей
    myCopecks = (curMoney - Fix(curMoney)) * 100
    strConvBank = CStr(curMoney - myCopecks / 100)
    If myCopecks = 0 Then
        strConvBank = strConvBank  "=" 'Без копеек
    Else
        strConvBank = strConvBank  "-"  Format(myCopecks, "00") 'С копейками
    End If
End Function

Для быстрого запуска приложения из Access можно воспользоваться командой shell. Она позволяет запускать любые программы: notepad.exe, explorer.exe и т.п.

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
    (ByVal hwnd As Long, _
     ByVal lpOperation As String, _
     ByVal lpFile As String, _
     ByVal lpParameters As String, _
     ByVal lpDirectory As String, _
     ByVal nShowCmd As Long) _
As Long

Private Sub butOpenFolder_Click()
        Shell "explorer.exe ""C:\""", vbNormalFocus
End Sub

Private Sub butSelectFile_Click()
    ' Включите библитеку libDialogFiles
    Me.strFilePath = fOfficeGetFile("Выберите файл", "C:", "*.txt")
End Sub

Private Sub strFilePath_DblClick(Cancel As Integer)
On Error GoTo 999
'    If Me.Var = 1 Then
        Dim StartDoc As Long
        Dim SW_SHOWNORMAL As Long
        If Not IsNull(Me.strFilePath) Then
            StartDoc = ShellExecute(Me.hwnd, "", Me.strFilePath, _
                "", "", SW_SHOWNORMAL)
        End If
'    End If
    
    Exit Sub

999:
   MsgBox "Error: "  Err  " "  Error
   Exit Sub

End Sub

19. Таблицу в подчиненной форме невозможно раскрасить простым способом, для этого надо знать некоторые хитрости. Посмотрите этот пример.

Private Sub Form_Open(Cancel As Integer)
On Error Resume Next
    'Назначаем цвет для всей таблицы
    Me.DatasheetBackColor = RGB(180, 210, 180)
    
    'Назначим в поле 'Дата' такое форматирование, чтобы
    'выделить дату = 20 сентября 2000 года
    With Me.Дата
        .FormatConditions.Delete 'Удаляем все условия
        'Назначение форматирования
        .FormatConditions.Add acFieldValue, acEqual, "#09/20/2000#"
        'Изменение цвета ячейки
        With .FormatConditions(0)
           .BackColor = 13434828 'Цвет фона
           .FontBold = True 'Толщина букв
           .ForeColor = RGB(255, 0, 0) 'Цвет символов - красный
        End With
    End With
    'Назначим в поле 'Книга' такое форматирование, при котором
    'будут отображаться строки с полем Сумма  30 рублей
    With Me.Книга
        .FormatConditions.Delete 'Удаляем все условия
        .FormatConditions.Add acExpression, , "[Сумма]30" 'выражение
        .FormatConditions(0).BackColor = 12632256 'Серый цвет фона
    End With
    
    'Назначим в поле 'Сумма' такое форматирование, при котором
    'при входе в поле будет меняться цвет символов
    With Me.Сумма
        .FormatConditions.Delete 'Удаляем все условия
        .FormatConditions.Add acFieldHasFocus 'Назначаем фокус
        .FormatConditions(0).ForeColor = RGB(0, 0, 255) 'Синий цвет
        .FormatConditions.Add acFieldValue, acBetween, "200", "500"
        .FormatConditions(1).ForeColor = 255
    End With
    Err.Clear
End Sub

При разработке интерфейса Вам может потребоваться погасить или отобразить меню. Этот пример показывает, как можно это сделать.

Private Sub butProgram1_Click()
    Me.MenuBar = "Мое меню"
    If Me.butProgram1.Caption = "Отобразить меню" Then
        DoCmd.ShowToolbar Me.MenuBar, acToolbarYes
        Me.butProgram1.Caption = "Погасить меню"
    Else
        DoCmd.ShowToolbar Me.MenuBar, acToolbarNo
        Me.butProgram1.Caption = "Отобразить меню"
    End If
End Sub

Этот пример покажет Вам как управлять бинарными файлами из Access, метод нужен для обращения к файлам отличным от Access

'==============================================================
' Создаем бинарный файл
Private Sub butWrite_Click()
Dim intFile As Integer
Dim myRec As AppRecord
    
    
'    Open Me.strPath For Binary Access Write As #intFile
'    Open Me.strPath For Random As #intFile Len = Len(myRec)
    intFile = FreeFile()
    Open Me.strPath For Binary As #intFile
    With myRec ' Создание записи
        .ID = 125
        .Name1 = "Мой телефон"
        .Phone1 = 92345678
        .Date1 = Date
    End With
    Put #intFile, 1, myRec ' Сохранение в файле
    ' Закрываем файл
    Close #intFile
    ' Отображение кнопки
    Form_Load
    ' Сообщение
    MsgBox "Бинарный файл "  Me.strPath  " создан!", vbExclamation, "www.leadersoft.ru"
End Sub