TopPicLogo TopPicText

Преобразование к русским кавычкам (из "..." в « ...»)

(c) Максименко Юрий: http://db-maker.narod.ru

Function russianQuoting(ByVal strForQuote As String) As String
'(c) Максименко Юрий http://db-maker.narod.ru
'На клавиатуре нет русских кавычек, аксессовский хелп ничего умнее копирования из таблицы Символов не предлагает.
'Это исключает возможность авитозаполнения в комбобоксах, усложняет ввод названий.
'Нижеприведённая простая функция решает эту проблему. То есть Вы можете вводить названия с обычными кавычками,
'а в отчётах Вы можете использовать поле =russianQuoting([ПолеНазвания])
'-------------------------------------------------------------------- 
    strForQuote = Trim(strForQuote)
    'Заменим кавычку-начало слова
    If (Left(strForQuote, 1)) = Chr(34) Then strForQuote = Chr(171) & Mid(strForQuote, 2)

    'заменим кавычку-конец слова
    If (Right(strForQuote, 1)) = Chr(34) Then strForQuote = Mid(strForQuote, 1, Len(strForQuote) - 1) & Chr(187)
    
    'заменим кавычку с пробелом перед ней
    strForQuote = strReplace(strForQuote, " " & Chr(34), " " & Chr(171))

    'заменим кавычку с пробелом после неё
    strForQuote = strReplace(strForQuote, Chr(34) & " ", Chr(187) & " ")

    russianQuoting = strForQuote

End Function


Function strReplace(ByVal strSubject As String, ByVal forSearsh As String, ByVal forReplace As String) As String
'Дублирует  Replace(): эта функция работает как-то странно и в запросах бастует
'Возвращает строку, в которой в исходной строке strSubject подстрока forSearsh заменена на подстроку forReplace
'--------------------------------------------------------------------
    Dim p, l As Integer
    p = InStr(strSubject, forSearsh)
    l = Len(forSearsh)
    Do Until p = 0
        strSubject = Left(strSubject, p - 1) & forReplace & Mid(strSubject, p + l)
        p = InStr(strSubject, forSearsh)
    Loop
    strReplace = strSubject

End Function
Назад ToTop
L.E. 05.06.2016
Рейтинг@Mail.ru