Вопрос # 228 Уважаемые программисты. Написал программу для учета товара на складе, в базе данных Access. И вопрос таково характера при выписке товара со склада на Накладной нужна сумма прописью. Помогите с написанием кода для суммы прописью. Заранее благодарен. [Ответить]

Отвечает

Дмитрий

Здравствуйте 'Проверочная функция Sub Example() Source& = 2000011 Call SummaString(Summa$, Source&, 1, "рубль", "рубля", "рублей") Debug.Print Summa$ ' два миллиона одиннадцать рублей ' Source& = 22 Call SummaString(Summa$, Source&, 2, "копейка", "копейки", "копеек") Debug.Print Summa$ ' двадцать две копейки ' Source& = 1231 Call SummaString(Summa$, Source&, 3, "колесо", "колеса", "колес") Debug.Print Summa$ ' одна тысяча двести тридцать одно колесо ' Call SummaString(Summa$, Source&, 1, "", "", "") Debug.Print Summa$ ' одна тысяча двести тридцать один Debug.Print Summa$ + " руб." ' одна тысяча двести тридцать один руб. End Sub 'Функция для получения суммы прописью Sub SummaString(Summa$, Source As Long, Rod%, w1$, w2to4$, w5to10$) ' ' "Сумма прописью": ' преобразование числа из цифрого вида в символьное ' ================================================== ' Исходные данные: ' Source - число от 0 до 2147483647 (2^31-1) ' Eсли нужно оперировать с числами > 2 147 483 647 ' замените описание переменных Source и TempValue на "AS DOUBLE" ' ' далее нужно задать информацию о единице изменения ' Rod% = 1 - мужской, = 2 - женский, = 3 - средний ' название единицы изменения: ' w1$ - именительный падеж единственное число (= 1) ' w2to4$ - родительный падеж единственное число (= 2-4) ' w5to10$ - родительный падеж множественное число ( = 5-10) ' ' Rod% должен быть задано обязательно, название единицы может быть ' не задано = "" ' ———————————————- ' Результат: Summa$ - запись прописью ' '================================ Dim TempValue As Long ' If Source& = 0 Then Summa$ = RTrim$("ноль " + w5to10$): Exit Sub End If ' TempValue = Source: Summa$ = "" ' единицы Call SummaStringThree(Summa$, TempValue, Rod%, w1$, w2to4$, w5to10$) If TempValue = 0 Then Exit Sub ' тысячи Call SummaStringThree(Summa$, TempValue, 2, "тысяча", "тысячи", "тысяч") If TempValue = 0 Then Exit Sub ' миллионы Call SummaStringThree(Summa$, TempValue, 1, "миллион", "миллиона", "миллионов") If TempValue = 0 Then Exit Sub ' миллиардов Call SummaStringThree(Summa$, TempValue, 1, "миллиард", "миллиарда", "миллиардов") If TempValue = 0 Then Exit Sub ' ' Eсли нужно оперировать с числами > 2 147 483 647 ' измените тип переменных (см. выше) и добавьте эту строку для триллионов: ' CALL SummaStringThree(Summa$, TempValue#, 1, "трилллион", "триллиона", "триллионов") ' IF TempValue# = 0 THEN EXIT SUB ' ' Что идет после триллионов, я плохо представляю... ' End Sub Sub SummaStringThree(Summa$, TempValue As Long, Rod%, w1$, w2to4$, w5to10$) ' ' Формирования строки для трехзначного числа: ' (последний трех знаков TempValue ' Eсли нужно оперировать с числами > 2 147 483 647 ' замените в описании на TempValue AS DOUBLE '==================================== Dim Rest%, Rest1%, EndWord$, s1$, s10$, s100$ ' Rest% = TempValue& Mod 1000 TempValue& = TempValue& \ 1000 If Rest% = 0 Then ' последние три знака нулевые If Summa$ = "" Then Summa$ = w5to10$ + " " Exit Sub End If ' ' начинаем подсчет с Rest EndWord$ = w5to10$ ' сотни Select Case Rest% \ 100 Case 0: s100$ = "" Case 1: s100$ = "сто " Case 2: s100$ = "двести " Case 3: s100$ = "триста " Case 4: s100$ = "четыреста " Case 5: s100$ = "пятьсот " Case 6: s100$ = "шестьсот " Case 7: s100$ = "семьсот " Case 8: s100$ = "восемьсот " Case 9: s100$ = "девятьсот " End Select ' ' десятки Rest% = Rest% Mod 100: Rest1% = Rest% \ 10 s1$ = "" Select Case Rest1% Case 0: s10$ = "" Case 1 ' особый случай Select Case Rest% Case 10: s10$ = "десять " Case 11: s10$ = "одиннадцать " Case 12: s10$ = "двенадцать " Case 13: s10$ = "тринадцать " Case 14: s10$ = "четырнадцать " Case 15: s10$ = "пятнадцать " Case 16: s10$ = "шестнадцать " Case 17: s10$ = "семнадцать " Case 18: s10$ = "восемнадцать " Case 19: s10$ = "девятнадцать " End Select Case 2: s10$ = "двадцать " Case 3: s10$ = "тридцать " Case 4: s10$ = "сорок " Case 5: s10$ = "пятьдесят " Case 6: s10$ = "шестьдесят " Case 7: s10$ = "семьдесят " Case 8: s10$ = "восемьдесят " Case 9: s10$ = "девяносто " End Select ' If Rest1% <> 1 Then ' единицы Select Case Rest% Mod 10 Case 1 Select Case Rod% Case 1: s1$ = "один " Case 2: s1$ = "одна " Case 3: s1$ = "одно " End Select EndWord$ = w1$ Case 2 If Rod% = 2 Then s1$ = "две " Else s1$ = "два " EndWord$ = w2to4$ Case 3: s1$ = "три ": EndWord$ = w2to4$ Case 4: s1$ = "четыре ": EndWord$ = w2to4$ Case 5: s1$ = "пять " Case 6: s1$ = "шесть " Case 7: s1$ = "семь " Case 8: s1$ = "восемь " Case 9: s1$ = "девять " End Select End If ' ' сборка строки Summa$ = RTrim$(RTrim$(s100$ + s10$ + s1$ + EndWord$) + " " + Summa$) End Sub 'Не моё. Взял с сайта Микрософта.

Оценка за ответ эксперту Дмитрий: 5 баллов

Отвечает	Oleg
	Здравствуйте! отвечаю на ваш вопрос: посылаю лист эксель берите функцию СУММА ПРОПИСЬЮ() и все что дальше следует и ипользуйте в соей программе. Вирусов нет - обещаю! Удачи!

Скачать приложенный к ответу файл >>>

Оценка за ответ эксперту Oleg: 5 баллов

Отвечает	Алексей Шишкин
	Зайди на сайт: Программирование VB, VBA Access http://***reklalma***/***reklama***/***reklama*** там полно всего в т.ч. и модулей «сумма прописью» если не ошибаюсь штук 5 или больше. Один из примеров пристегнул к сообщению.

Скачать приложенный к ответу файл >>>

Оценка за ответ эксперту Алексей Шишкин: 5 баллов

Отвечает

Ярослав Шевнин

В интернете нашёл такой код стандартного модуля. Причём его можно использовать как в VB, так и в VBA. Сумму прописью возвращает функция SayNum в параметрах передаётся сумма и валюта (второй параметр необязательный. ************************************************************************ ' опции Option Base 1 Option Explicit ' объявления массивов Dim pn(7) As String * 3 Dim rub(10) As String Dim kop(10) As String Dim edm(10) As String Dim edw(10) As String Dim d(10) As String Dim des(10) As String Dim sot(10) As String Dim ed(4) As String Dim rp(4) As String Dim mn(4) As String ' ------------------------------- ' ВСПОМОГАТЕЛЬНЫЕ ФУНКЦИИ ' ------------------------------- ' инициализация массивов Private Sub InitMas(Valuta) Select Case Valuta Case "$" rub(1) = "долларов" rub(2) = "доллар" rub(3) = "доллара" rub(4) = "доллара" rub(5) = "доллара" rub(6) = "долларов" rub(7) = "долларов" rub(8) = "долларов" rub(9) = "долларов" rub(10) = "долларов" kop(1) = "центов" kop(2) = "цент" kop(3) = "цента" kop(4) = "цента" kop(5) = "цента" kop(6) = "центов" kop(7) = "центов" kop(8) = "центов" kop(9) = "центов" kop(10) = "центов" Case Else rub(1) = "рублей" rub(2) = "рубль" rub(3) = "рубля" rub(4) = "рубля" rub(5) = "рубля" rub(6) = "рублей" rub(7) = "рублей" rub(8) = "рублей" rub(9) = "рублей" rub(10) = "рублей" kop(1) = "копеек" kop(2) = "копейка" kop(3) = "копейки" kop(4) = "копейки" kop(5) = "копейки" kop(6) = "копеек" kop(7) = "копеек" kop(8) = "копеек" kop(9) = "копеек" kop(10) = "копеек" End Select edm(1) = "ноль" edm(2) = "один" edm(3) = "два" edm(4) = "три" edm(5) = "четыре" edm(6) = "пять" edm(7) = "шесть" edm(8) = "семь" edm(9) = "восемь" edm(10) = "девять" edw(1) = "ноль" edw(2) = "одна" edw(3) = "две" edw(4) = "три" edw(5) = "четыре" edw(6) = "пять" edw(7) = "шесть" edw(8) = "семь" edw(9) = "восемь" edw(10) = "девять" d(1) = "десять" d(2) = "одиннадцать" d(3) = "двенадцать" d(4) = "тринадцать" d(5) = "четырнадцать" d(6) = "пятнадцать" d(7) = "шестнадцать" d(8) = "семнадцать" d(9) = "восемнадцать" d(10) = "девятнадцать" des(1) = "ноль" des(2) = "десять" des(3) = "двадцать" des(4) = "тридцать" des(5) = "сорок" des(6) = "пятьдесят" des(7) = "шестьдесят" des(8) = "семьдесят" des(9) = "восемьдесят" des(10) = "девяносто" sot(1) = "ноль" sot(2) = "сто" sot(3) = "двести" sot(4) = "триста" sot(5) = "четыреста" sot(6) = "пятьсот" sot(7) = "шестьсот" sot(8) = "семьсот" sot(9) = "восемьсот" sot(10) = "девятьсот" ed(1) = "" ed(2) = "тысяча" ed(3) = "миллион" ed(4) = "миллиард" rp(1) = "" rp(2) = "тысячи" rp(3) = "миллиона" rp(4) = "миллиарда" mn(1) = "" mn(2) = "тысяч" mn(3) = "миллионов" mn(4) = "миллардов" End Sub ' отсекает от строки все пробелы Private Function AllTrim(s As String) As String AllTrim = LTrim(RTrim(s)) End Function ' Возвращает остаток от деления Divisor/Divider Private Function Ostatok(Divisor, Divider As Integer) As Integer Ostatok = Divisor - Int(Divisor / Divider) * Divider End Function ' Возвращает в качестве результата ' - второй параметр, если первый_параметр-условие истинно ' - третий параметр, если первый_параметр-условие ложно Private Function iif(Condition As Boolean, TrueResult, FalseResult) If Condition Then iif = TrueResult Else iif = FalseResult End If End Function ' разбор триады Private Function sto(cif As Integer, i As Integer) As String Dim p As String If cif = 0 Then sto = iif(i = 0, " ", "") ElseIf cif < 10 Then If i = 1 Then sto = edw(cif + 1) Else sto = edm(cif + 1) + iif(i = 0, " ", "") End If ElseIf (cif >= 10) And (cif < 20) Then sto = d(cif - 10 + 1) + iif(i = 0, " ", "") ElseIf (cif >= 20) And (cif < 100) Then p = des(Int(cif / 10) + 1) p = p + " " + sto(Ostatok(cif, 10), i) sto = p ElseIf (cif >= 100) And (cif < 1000) Then p = sot(Int(cif / 100) + 1) p = p + " " + sto(Ostatok(cif, 100), i) sto = p End If End Function ' возвращает число прописью Private Function ToStr(num) As String Dim n As Integer, r As Integer, p As Integer, i As Integer Dim dd As String, de As String, tmp As String dd = AllTrim(Str(num)) n = Len(dd) r = Int(n / 3) For i = 0 To r p = iif(i = r, Ostatok(n, 3), 3) pn(i + 1) = Mid(dd, iif(n + 1 - 3 * (i + 1) <= 0, 1, n + 1 - 3 * (i + 1)), p) Next i dd = "" For i = r To 0 Step -1 n = Val(pn(i + 1)) dd = dd + " " + sto(n, i) tmp = AllTrim(pn(i + 1)) de = Right(tmp, 1) If (n > 0) And ((Ostatok(n, 100) < 10) Or (Ostatok(n, 100) >= 20)) Then Select Case de Case "1" dd = dd + " " + ed(i + 1) Case "2", "3", "4" dd = dd + " " + rp(i + 1) Case Else dd = dd + " " + mn(i + 1) End Select Else If n > 0 Then dd = dd + " " + mn(i + 1) End If End If Next i dd = AllTrim(dd) dd = iif(Len(dd) > 0, dd, "ноль") ToStr = dd End Function ' добавть строку валюты Private Function AddValuta(i As Integer, RubKop As Boolean) As String If i < 10 Then AddValuta = " " + iif(RubKop, rub(i + 1), kop(i + 1)) ElseIf i >= 10 And i < 20 Then AddValuta = " " + iif(RubKop, rub(1), kop(1)) Else i = Ostatok(i, 10) AddValuta = " " + iif(RubKop, rub(i + 1), kop(i + 1)) End If End Function '------------------------------------- ' ОСНОВНАЯ ПРОЦЕДУРКА '------------------------------------- Function SayNum(num, Optional Valuta) 'ATTRIBUTE SayNum.VB_DESCRIPTION = _ "Выводит прописью сумму, передаваемую в качестве параметра. _ Необязательный второй параметр - тип валюты: "R" - рубли, "$" - доллары США. _ \n\n \n\n!0\nЏ\n" Dim s As String, rs As String, ks As String Dim rn, kn, pos As Integer If IsNumeric(num) Then ' небольшие подготовительные действия If IsMissing(Valuta) Then Valuta = "R" End If InitMas (Valuta) ' отделим рубли от копеек s = AllTrim(Str(num)) pos = InStr(1, s, ".") If pos = 0 Then rs = s ks = "00" Else rs = Mid(s, 1, pos - 1) ks = Mid(s, pos + 1, 20) ks = iif(Len(ks) < 2, ks + "0", ks) End If rn = Val(rs) kn = Val(ks) ' собственно перевод s = ToStr(rn) + AddValuta(Ostatok(rn, 100), True) + " " + _ ks + AddValuta(Int(kn), False) Else s = "ноль" End If SayNum = UCase(Mid(s, 1, 1)) + Mid(s, 2, Len(s) - 1) End Function '------------------------------------- Function SubString(Str22 As String, MaxLong As Integer, NumSubStr As Integer) Dim LongFirstString As Integer Dim LongWord As Integer, i As Integer Dim StrOut As String Dim Word As String StrOut = "" LongFirstString = 0 For i = 1 To NumSubStr StrOut = "" LongFirstString = 0 While Len(Str22) <> 0 And LongFirstString < MaxLong ' MsgBox "string = " & Str22 LongWord = InStr(1, Str22, " ") If LongWord > 0 Then LongFirstString = LongFirstString + LongWord Word = Mid(Str22, 1, LongWord) Str22 = Mid(Str22, LongWord + 1, Len(Str22) - LongWord) StrOut = StrOut + Word Else LongFirstString = MaxLong + 1 StrOut = StrOut + Str22 Str22 = "" End If Wend Next SubString = StrOut End Function ***********************************************************************************************

Оценка за ответ эксперту Ярослав Шевнин: 5 баллов

Отвечает

Константин Пищулин

Добрый день, Option Compare Database Dim Names(36) As String ' Eieoeaeecaoey ?eneeoaeuiuo Sub InitConv() Names(1) = " iaei" Names(2) = " aaa" Names(3) = " o?e" Names(4) = " ?aou?a" Names(5) = " iyou" Names(6) = " oanou" Names(7) = " naiu" Names(8) = " ainaiu" Names(9) = " aaayou" Names(10) = " aanyou" Names(11) = " iaeiiaaoaou" Names(12) = " aaaiaaoaou" Names(13) = " o?eiaaoaou" Names(14) = " ?aou?iaaoaou" Names(15) = " iyoiaaoaou" Names(16) = " oanoiaaoaou" Names(17) = " naiiaaoaou" Names(18) = " ainaiiaaoaou" Names(19) = " aaayoiaaoaou" Names(20) = " aaaaoaou" Names(21) = " o?eaoaou" Names(22) = " ni?ie" Names(23) = " iyouaanyo" Names(24) = " oanouaanyo" Names(25) = " naiuaanyo" Names(26) = " ainaiuaanyo" Names(27) = " aaayiinoi" Names(28) = " noi" Names(29) = " aaanoe" Names(30) = " o?enoa" Names(31) = " ?aou?anoa" Names(32) = " iyounio" Names(33) = " oanounio" Names(34) = " naiunio" Names(35) = " ainaiunio" Names(36) = " aaayounio" End Sub ' I?aia?aciaaiea ?enea Number a no?ieo ' Ia?aiao?u: Numb - enoiaiia ?enei ' iaiaycao: IsDec - ENOEIA aey a?iaiie ?anoe Public Function Num2Str(ByVal Numb As Double, _ Optional ByVal IsDec As Boolean = False) As String Dim Number As Long, Num3 As String, tn As Long InitConv If IsDec Then Number = Val(Decimals(Numb)) Else If (Numb - Int(Numb)) > 0.999 Then Number = Int(Numb) + 1 Else Number = Int(Numb) End If End If Num2Str = "" For i = 1 To 4 tn = Number Num3 = Conv3Digit(Number) Select Case i Case 2 If ExtrDigit(tn, 2) <> 1 Then Select Case ExtrDigit(tn, 1) Case 1 Num3 = Left(Num3, Len(Num3) - 2) + "ia" Case 2 Num3 = Left(Num3, Len(Num3) - 1) + "a" End Select End If Num3 = Num3 + " ouny?" + Ending(tn, 2) Case 3 Num3 = Num3 + " ieeeeii" + Ending(tn, 3) Case 4 Num3 = Num3 + " ieeeea?a" + Ending(tn, 3) End Select Num2Str = Num3 + Num2Str If Number = 0 Then Exit For Next i End Function ' Ecaea?aiea 3-oeo?iaie ?anoe, nio?aiaiea inoaoea Function Extract(ByRef Number As Long) Extract = Number Number = Int(Number / 1000) Extract = Extract - Number * 1000 End Function ' I?aia?aciaaiea 3-cia?iiai ?enea a no?ieo Public Function Conv3Digit(ByRef Number As Long) As String Dim num As Integer num = Extract(Number) If num < 100 Then Conv3Digit = Conv2Digit(num) Else Conv3Digit = Names(27 + ExtrDigit(num, 3)) + Conv2Digit(num) End If End Function ' I?aia?aciaaiea 2-cia?iiai ?enea a no?ieo Public Function Conv2Digit(ByVal Number As Integer) As String Conv2Digit = "" Number = Val(Right(str(Number), 2)) Select Case Number Case 0 Exit Function Case Is > 19 Conv2Digit = Names(18 + ExtrDigit(Number, 2)) If ExtrDigit(Number, 1) > 0 Then Conv2Digit = Conv2Digit + Names(ExtrDigit(Number, 1)) End If Case Is > 9 Conv2Digit = Names(10 + ExtrDigit(Number, 1)) Case Else Conv2Digit = Names(ExtrDigit(Number, 1)) End Select End Function ' Ecaea?aiea iaiie oeo?u n iiceoee Order n eiioa Public Function ExtrDigit(ByVal Number As Long, _ ByVal Order As Integer) As Integer Dim cn As String ExtrDigit = 0 cn = Format(Number) If Len(cn) < Order Then Exit Function ExtrDigit = Val(Mid(cn, Len(cn) - Order + 1, 1)) End Function ' Auaia iacaaiey aae?ou ' Ia?aiao?u: Number - noiia aae?ou ' iaiaycao: IsRub - ENOEIA aey ?oaeae Public Function EndUnit(ByVal Number As Double, _ Optional ByVal IsDec As Boolean = False) As String If IsDec Then EndUnit = " eiia" + Ending(Val(Decimals(Number)), 1) + " " Else If Number > 0 Then EndUnit = " ?oae" + Ending(Number) + " " Else EndUnit = "Iieu ?oaeae " End If End If End Function ' Ooieoey ieii?aiee ' Ia?aiao?u: Number - ?enei ' E - 0 aey neia oeia '?oaeu' ' 1 aey neia oeia 'eiiaeea' ' 2 aey neia oeia 'ouny?a' ' 3 aey neia oeia 'ieeeeii' Public Function Ending(ByVal Number As Long, _ Optional ByVal E As Integer = 0) As String If ExtrDigit(Number, 2) = 1 Then Select Case E Case 0 Ending = "ae" Case 1 Ending = "ae" Case 2 Ending = "" Case 3 Ending = "ia" End Select Else Select Case ExtrDigit(Number, 1) Case Is > 4, 0 Select Case E Case 0 Ending = "ae" Case 1 Ending = "ae" Case 2 Ending = "" Case 3 Ending = "ia" End Select Case Is > 1 Select Case E Case 0 Ending = "y" Case 1 Ending = "eee" Case 2 Ending = "e" Case 3 Ending = "a" End Select Case Else Select Case E Case 0 Ending = "u" Case 1 Ending = "eea" Case 2 Ending = "a" Case 3 Ending = "" End Select End Select End If End Function ' Anoaaea eeae?o?ueo ioeae a 2-cia?iia ?enei Public Function Decimals(ByVal Number As Double) As String Decimals = Right(Format(Number, "0.00"), 2) End Function ' Caiaia ?acaaeeoaey a?iaiie ?anoe Public Function NumView(ByVal Number As Double, _ ByVal Delim As String) As String NumView = str(Int(Number)) + Delim + Decimals(Number) End Function ' Eaieoaeecaoey ia?aie aoeau no?iee Public Function Capit(ByVal S As String) As String Capit = UCase(Left(Trim(S), 1)) + Mid(Trim(S), 2) End Function ' Auaa?a iacaaiey ianyoa Public Function RMonth(mn As Integer) Select Case mn Case 1 RMonth = " yiaa?y " Case 2 RMonth = " oaa?aey " Case 3 RMonth = " ia?oa " Case 4 RMonth = " ai?aey " Case 5 RMonth = " iay " Case 6 RMonth = " e?iy " Case 7 RMonth = " e?ey " Case 8 RMonth = " aaaonoa " Case 9 RMonth = " naioya?y " Case 10 RMonth = " ieoya?y " Case 11 RMonth = " iiya?y " Case 12 RMonth = " aaeaa?y " End Select End Function ' Auaa?a aaou a aeaa AA IIII AAAA Public Function RDate(dt As Date) As String RDate = TStr(Day(dt)) + RMonth(Month(dt)) + TStr(Year(dt)) End Function ' Ia?aaia ?enea a no?ieiaue aea aac i?iaaeia Public Function TStr(Number As Integer) As String TStr = Trim(str(Number)) End Function ' Ia?aou aaoo yecaiiey?ia Public Sub PrintDoc() Sheets("Ieaoa?ea").PrintOut Copies:=2 End Sub ' Nio?aiaiea ieaoa?ee Excel Public Sub SavePlat() Dim i As Integer, r As Object, p As Object, fr As String Dim o As Object TestOpen ReestrXLS Set r = Workbooks(ReestrReestrXLS).Sheets(1) Set p = Workbooks(Plategka).Sheets("Aaiiua") For i = 2 To r.[A1].CurrentRegion.Rows.Count If r.Cells(i, 1) = p.Cells(1, 2) Then Exit For Next i For j = 1 To 7 r.Cells(i, j) = p.Cells(j, 2) Next j r.Cells(i, 8) = p.Cells(9, 1) r.Cells(i, 9) = p.Cells(9, 2) r.Cells(i, 10) = p.Cells(3, 3) Set o = SearchObj(ThisWorkbook.Sheets("Aaiiua"), "RestList") fr = Trim(str(r.[A1].CurrentRegion.Rows.Count)) fr = "[" + Reestr + "]?aano?!$A$2:$A$" + fr o.ControlFormat.ListFillRange = fr End Sub ' Ainnoaiiaeaiea ieaoa?ee Excel Public Sub RestPlat() Dim rw As Integer, r As Object, p As Object TestOpen ReestrXLS Set r = Workbooks(ReestrXLS).Sheets(1) Set p = Workbooks(Plategka).Sheets("Aaiiua") rw = p.Cells(9, 4) + 1 For j = 1 To 7 p.Cells(j, 2) = r.Cells(rw, j) Next j p.Cells(9, 1) = r.Cells(rw, 8) p.Cells(9, 2) = r.Cells(rw, 9) p.Cells(3, 3) = r.Cells(rw, 10) End Sub ' I?iaa?ea e ioe?uoea oaaeeou Excel Public Sub TestOpen(ByVal NameBook As String) Dim WrkPath As String, Found As Boolean, w As Object Dim WrkBook As Object Set WrkBook = ThisWorkbook Found = False For Each w In Workbooks If UCase(w.Name) = UCase(NameBook) Then Found = True Exit For End If Next w If Not Found Then WrkPath = ThisWorkbook.Path Application.Workbooks.Open WrkPath + "\" + NameBook WrkBook.Activate End If End Sub ' Iiene iauaeoa ia eenoa Excel Public Function SearchObj(ByRef oSheet As Object, _ Name As String) As Object Dim c As Object For Each c In oSheet.Shapes If c.Name = Name Then Set SearchObj = c: Exit Function Next c Set SearchObj = Null End Function ' Ia?aienu iiaiai iiia?a ieaoa?ee Excel Public Sub NewNumber() TestOpen ReestrXLS [B1] = WorksheetFunction.max(Workbooks(ReestrXLS).Sheets(1).[A:A]) + 1 End Sub ' Ia?aienu oaeouae aaou Excel Public Sub NowDate() [B7] = Date End Sub

Оценка за ответ эксперту Константин Пищулин: 5 баллов

Отвечает

Red Wolf

Вот используй модуль. Но только сам дополни условие грамотности. Для освоения космоса. ;-) Private Function NumberToStr(lValue As Long) As String Dim s As String, i As Long, sValue As String, sValueTmp As String sValueTmp = CStr(lValue) Do While Len(sValueTmp) > 0 sValue = IIf((Len(sValueTmp) Mod 3) = 0, Mid(sValueTmp, 1, 3), Mid(sValueTmp, 1, Len(sValueTmp) Mod 3)) Do While Len(sValue) > 0 If 10 > sValue Then 'Здесь можно писать зависимые условия от Тысячи, Миллионы, Миллиарды ...... 'Одна тысяча 'Две тысячи 'Три тысячи 'Четыре тысячи 'пять тысяч 'шесть тысяч 'семь тысяч 'восемь тысяч 'девять тысяч 'десять тысяч ' ... s = s & Choose(Mid(sValue, 1, 1), "один ", "два ", "три ", "четыре ", "пять ", "шесть ", "семь ", "восемь ", "девять ") ElseIf 20 > sValue Then If sValue = 10 Then s = s & "десять " Else s = s & Choose(Mid(sValue, 1, 1), "одиннадцать ", "двенадцать ", "тринадцать ", "четырнадцать ", "пятнадцать ", "шестнадцать ", "семнадцать ", "восемнадцать ", "девятнадцать ") sValue = Mid(sValue, 2) End If ElseIf 100 > sValue Then s = s & Choose(Mid(sValue, 1, 1), "десять ", "двадцать ", "тридцать ", "сорок ", "пятьдесят ", "шестьдесят ", "семьдесят ", "восемьдесят ", "девяносто ") Else s = s & Choose(Mid(sValue, 1, 1), "сто ", "двести ", "триста ", "четыреста ", "пятьсот ", "шестьсот ", "семьсот ", "восемьсот ", "девятьсот ") End If sValue = Mid(sValue, 2) Loop 'Здесь можно изменить с условиями грамотности прописи. If Len(sValueTmp) > 3 Then s = s & "тысяча " ElseIf Len(sValueTmp) > 6 Then s = s & "миллион " ElseIf Len(sValueTmp) > 9 Then s = s & "миллиард " 'Дальше допиши сами для развития навыка программирования End If sValueTmp = Mid(sValueTmp, 1 + IIf((Len(sValueTmp) Mod 3) = 0, 3, Len(sValueTmp) Mod 3)) Loop NumberToStr = Trim(s) End Function

Оценка за ответ эксперту Red Wolf: 5 баллов

Вопрос # 229 Здравствуйте! Подскажите пожалуйста, как вывести иконку файла в PictureBox зная путь к файлу? Заранее спасибо! [Ответить]

Отвечает	Denisk@
	Для того, чтобы вывести иконку из файла в PictureBox, необходимо для начала извлечь иконку из файла. В этом может помочь API функция ExtractIconEx, а для последующей прорисовки в PictureBox - DrawIconEx. Подробный пример прилагаеться к ответу.

Скачать приложенный к ответу файл >>>

Оценка за ответ эксперту Denisk@: 5 баллов

Отвечает	*Casper*
	PictureBox.Pictrure = LoadPicture("путь к файлу")

Оценка за ответ эксперту *Casper*: 3 баллов

Отвечает

Игорь

Создать новый проект и вставить один объект PictureBox (с именем «Picture1») и одну CommandButton (с именем «Command1»). Вставить в код формы нижележащий код… Option Explicit Private Declare Function ExtractIconEx Lib "shell32.dll" Alias "ExtractIconExA" (ByVal lpszFile As String, ByVal nIconIndex As Long, phiconLarge As Long, phiconSmall As Long, ByVal nIcons As Long) As Long Private Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal hIcon As Long) As Long Rem: FileName = Имя файла содержащего икони, _ может быть любой файл, содержащий иконки, например, *.exe, *.dll, *.ico, *.cpl и т.п. Private Const FileName As String = "shell32.dll" Private Sub SETICON(ByVal sFileName As String, ByVal nIconIndex As Integer, ByVal objPictureBox As PictureBox) Rem: Процедура вывода выбраной иконки в объект PictureBox... Rem: Переменные: sFileName = Имя файла с иконками (см. выше) Rem: Переменные: nIconIndex = Индекс иконки в *.exe, *.dll, *.cpl (счет начинается с нуля!) _ если используется файл типа *.ico, то индекс должен быть равным нулю... objPictureBox.AutoRedraw = True objPictureBox.Cls Dim mIcon As Long ExtractIconEx sFileName, nIconIndex, mIcon, ByVal &H0, &H1 DrawIcon objPictureBox.hdc, 0, 0, mIcon End Sub Private Sub Command1_Click() Static nIconIndex As Integer Rem: Для примера будем суммировать индекс иконки, _ чтобы отобразить в примере все иконки из файла "shell32.dll"... nIconIndex = nIconIndex + 1 Rem: Вызываем процедуру вставки иконки в объект PictureBox... SETICON FileName, nIconIndex, Picture1 End Sub Private Sub Form_Load() Rem: Вызываем процедуру вставки иконки № 0 в объект PictureBox... SETICON FileName, 0, Picture1 End Sub Пример прикреплен...

Скачать приложенный к ответу файл >>>

Оценка за ответ эксперту Игорь: 5 баллов

Вопрос # 230 Как сделать отступы в RichTextBox? Заранее спасибо! [Ответить]

Отвечает	IguMEN
	Предлагаю тупо подложить Label с соответствующим цветом фона, после чего менять координаты углов richtextbox.

Оценка за ответ эксперту IguMEN: 3 баллов

Вопрос # 234 Работая в Visual Basic (у меня Visual Basic 6.0 Service Pack 5) у меня постоянно сбиваются настройки меню и панелей в интерфейсе редактора (пропадают необходимые элементы меню, кнопки, иногда изображения на кнопках не соответствуют макросам и необходимым действиям). Для исправления ошибок мне приходится сбрасывать настройки панелей, но и это не всегда помогает. Например, сейчас у меня стало пропадать меню «Удалить» в меню «Правка» и меню «Удалить», которое должно появляться при отжатии правой кнопки меню от формы в броузере объектов и я не могу удалить не нужную мне форму, модуль и т.п. Также часто пропадает меню «Вставить пользовательский контрол» и я не могу добавить его в проект. Таких глюков с меню очень много. Переустановка пакета Visual Basic ничего полезного не приносит. Может кто-то встречался с подобными проблемами и знает, как их исправить, прошу сообщить. [Ответить]

Отвечает	IguMEN
	Работал в VB6 с шестым сервиспаком и в базовой версии, но такого чуда не наблюдал. Попробуй эксклюзивный аддон с сайта drweb.ru. Иногда помогает.

Оценка за ответ эксперту IguMEN: 3 баллов