\'Для использования - создать новый проект VB или VBA\n 
     \'                  - поместить в код формы ниже лежащий текст программы\n 
     \'                  - скопировать любой код и запустить программу (открыть форму)\n 
     \'В буфере обмена будет размеченный код, готовый для вставки в ваше сообщение на форуме\n 
     \'Предлагаю поучаствовать в дальнейшем развитии этого проекта\n 
    Option Explicit\n    \n    Private Declare Function OpenClipboard _\n                    Lib "user32" (ByVal hWnd As Long) As Long\n    Private Declare Function CloseClipboard _\n                    Lib "user32" () As Long\n    Private Declare Function GetClipboardData _\n                    Lib "user32" (ByVal wFormat As Long) As Long\n    Private Declare Function GlobalAlloc _\n                    Lib "kernel32" (ByVal wFlags&, _\n                                    ByVal dwBytes As Long) As Long\n    Private Declare Function GlobalLock _\n                    Lib "kernel32" (ByVal hMem As Long) As Long\n    Private Declare Function GlobalUnlock _\n                    Lib "kernel32" (ByVal hMem As Long) As Long\n    Private Declare Function lstrlen _\n                    Lib "kernel32" _\n                    Alias "lstrlenA" (ByVal lpString As Long) As Long\n    Private Declare Sub CopyMemory _\n                    Lib "kernel32" _\n                    Alias "RtlMoveMemory" (pDst As Any, _\n                                           pSrc As Long, _\n                                           ByVal ByteLen As Long)\n    \n    Private Declare Function lstrcpy _\n                    Lib "kernel32" (ByVal lpString1 As Any, _\n                                    ByVal lpString2 As Any) As Long\n    Private Declare Function EmptyClipboard _\n                    Lib "user32" () As Long\n    Private Declare Function SetClipboardData _\n                    Lib "user32" (ByVal wFormat As Long, _\n                                  ByVal hMem As Long) As Long\n    \n    Private Declare Function GetKeyboardLayoutName _\n                    Lib "user32" _\n                    Alias "GetKeyboardLayoutNameA" (ByVal pwszKLID As String) As Long\n    Private Declare Function LoadKeyboardLayout _\n                    Lib "user32" _\n                    Alias "LoadKeyboardLayoutA" (ByVal HKL As String, _\n                                                 ByVal Flags As Long) As Long\n    Private Const KL_NAMELENGTH =  9 \n    Private Const GHND = &H42\n    Private Const CF_TEXT =  1 \n\nPublic Sub Form_Load()\n     \'Процедура форматирования кода\n 
    \n    Dim aStr( 0  To  199 ) As String  \'массив искомых слов\n 
    Dim mStrIn As String  \'входящая строка\n 
    Dim mStrInLen As Long  \'длина входящей строки\n 
    Dim mStrOut As String  \'выходящая строка\n 
    Dim mStrSub As String  \'выделенная подстрока\n 
    Dim mChr As String  \'выделенный символ\n 
    Dim mNum As Long  \'текущая позиция\n 
    Dim mNumOld As Long  \'предыдущая позиция\n 
    Dim bOk As Boolean  \'признак обнаружения подстроки\n 
    Dim i As Byte  \'счётчик\n 
    Dim arr1 As Variant\n    Dim arr2 As Variant\n                \n     \'массив ключевых слов\n 
    arr1 = Array("#If", "#End", "#ElseIf", "#Else", "#Const", "Xor", "Write", _\n       "WithEvents", "With", "Width", "While", "Wend", "Variant", _\n       "Until", "Unknown", "Unlock", "Unload", "UBound", "TypeOf", _\n       "Type", "True", "To", "Then", "Text", "Tab", "Sub", "String$", _\n       "String", "StrComp", "Stop", "Step", "Static", "Spc", "Single", _\n       "Shared", "Sgn", "Set", "Select", "Seek", "Scale", "RSet", _\n       "RGB", "Return", "Resume", "Rem", "ReDim", "Read", "Randomize", _\n       "Random", "RaiseEvent", "Put", "Public", "PSet", "Property", _\n       "Private", "Print", "Preserve", "ParamArray", "Output", "Or", _\n       "Optional", "Option", "Open", "On", "Object", "Null", "Nothing", _\n       "Not", "Next", "New", "Name", "Module", "Mod", "MidB$", "MidB", _\n       "Mid$", "Mid", "Me", "LSet", "Loop", "Long", "Lock", "Local", _\n       "Load", "LINEINPUT", "Line", "Like", "Lib", "Let", "LenB", "Len", _\n       "Left", "LBound", "Is", "Integer", "Int", "InStrB", "InStr", _\n       "InputB$", "InputB", "Input$", "Input", "In", "Implements", _\n       "Imp", "If", "GoTo", "GoSub", "Go", "Global", "Get", "Function", _\n       "Friend", "FreeFile", "Format$", "Format", "For", "Fix", "False", _\n       "F", "Explicit", "Exit", "Event", "Error$", "Error", "Erase", _\n       "Eqv", "Enum", "EndIf", "End", "Empty", "ElseIf", "Else", "Each", _\n       "Double", "DoEvents", "Do", "Dir$", "Dir", "Dim", "DefVar", "DefStr", _\n       "DefSng", "DefObj", "DefLng", "DefInt", "DefDbl", "DefDec", "DefDate", _\n       "DefCur", "DefByte", "DefBool", "Declare", "Decimal", "Debug", "Date$", _\n       "Date", "Database", "Currency", "CVErr", "CVDate", "CVar", "CurDir$", _\n       "CurDir", "CStr", "CSng", "Const", "Compare", "Close", "CLng", "Circle", _\n       "CInt", "ChDir", "CDecl", "CDbl", "CDec", "CDate", "CCur", "CByte")\n     \'ограничение на размер массива, определяемого таким способом\n 
    arr2 = Array("CBool", "Case", "Call", "ByVal", "Byte", "ByRef", "Boolean", _\n       "Binary", "BF", "Base", "B", "Assert", "As", "Array", "Append", "Any", _\n       "And", "Alias", "AddressOf", "Access", "Abs")\n\n    For i =  0  To  178 \n        aStr(i) = arr1(i)\n    Next\n    For i =  0  To  20 \n        aStr( 179  + i) = arr2(i)\n    Next\n \n    mStrIn = ClipBoard_GetData & vbCr  \'получили строку из буфера\n 
    mNumOld =  0 \n    mStrOut = "[" & "FIXED" & "]"\n    mStrOut = mStrOut & "[" & "SIZE=2" & "]"\n    mStrInLen = Len(mStrIn)\n\n    For mNum =  1  To mStrInLen  \'перечисляем все символы входящей строки\n 
        mChr = Mid$(mStrIn, mNum,  1 )  \'выделяем символ\n 
        If mChr = " " Or mChr = vbCr Or mChr = vbLf Or mChr = "(" Or mChr = ")" _\n           Or mChr = "," Or mNum = Len(mStrIn) Then\n\n            If mChr = " " Then mChr = "&nb" & "sp;"\n             \'обнаружен разделитель слов\n 
            mStrSub = Mid$(mStrIn, mNumOld +  1 , mNum - mNumOld -  1 )  \'выделяем подстроку\n 
            bOk = False\n\n            For i =  0  To  199   \'поиск подстроки\n 
                If mStrSub = aStr(i) Then\n                    bOk = True\n                    Exit For\n                End If\n            Next\n            \n            If bOk = True Then  \'подстрока найдена\n 
                mStrOut = mStrOut & "[" & "color=blue" & "]" & mStrSub & _\n                                    "[" & "/color" & "]" & mChr\n            Else\n                mStrOut = mStrOut & mStrSub & mChr\n            End If\n            mNumOld = mNum\n        End If\n\n        If mChr = Chr$( 39 ) Then  \'обнаружен коментарий\n 
            mNum = InStr(mNum, mStrIn, vbCrLf)\n            If mNum =  0  Then mNum = Len(mStrIn)\n            mStrSub = Mid$(mStrIn, mNumOld +  1 , mNum - mNumOld -  1 )  \'выделяем подстроку\n 
            mStrOut = mStrOut & "[" & "color=green" & "]" & mStrSub & _\n                                "[" & "/color" & "]"\n            mNumOld = mNum -  1 \n        End If\n\n        If mChr = vbLf And Right$(mStrOut,  2 ) = vbCrLf Then\n            mStrOut = Left$(mStrOut, Len(mStrOut) -  2 )\n            mStrOut = mStrOut & "" & "13"\n        End If\n    Next\n\n    mStrOut = mStrOut & "" & "13"\n    mStrOut = mStrOut & "[" & "/SIZE" & "]"\n    mStrOut = mStrOut & "[" & "/FIXED" & "]"\n     \'ссылка на эту процедуру\n 
    mStrOut = mStrOut & "[" & "SIZE=1" & "]"\n    mStrOut = mStrOut & "[" & "url=http://"\n    mStrOut = mStrOut & "/topic/87621" & "]"\n    mStrOut = mStrOut & "Как отформатирован этот код?" & "[" & "/url" & "]"\n    mStrOut = mStrOut & "[" & "/SIZE" & "]"\n    ClipBoard_SetData (mStrOut)  \'вернули строку в буфер\n 
    MsgBox "Код скопирован в буфер"\nEnd Sub\n\n \'vba не имеет класса Сlipboard\n 
 \'ниже приведены функции найденные на\n 
 \'http://am.rusimport.ru/MsAccess/topic.aspx?ID=229\n 
 \'и модифицированные мной\n 
Private Function ClipBoard_GetData() As String\n    Dim hClipMemory As Long\n    Dim lpClipMemory As Long\n    Dim MyString As String\n    Dim lLength As Long\n    Dim RetVal As Long\n    \n    If OpenClipboard( 0 &) =  0  Then\n        MsgBox "Невозможно открыть буфер обмена, " & "Может быть он занят другим приложением"\n        Exit Function\n    End If\n\n     \' получить указатель на блок памяти, с текстом буфера обмена\n 
    hClipMemory = GetClipboardData(CF_TEXT)\n\n    If IsNull(hClipMemory) Then\n        MsgBox "Невозможно выделить память"\n        GoTo OutOfHere\n    End If\n         \n     \' фиксируем блок памяти, чтобы получить указатель на строку\n 
    lpClipMemory = GlobalLock(hClipMemory)\n    lLength = lstrlen(lpClipMemory)\n\n    If Not IsNull(lpClipMemory) Then\n        MyString = Space$(lLength)\n        CopyMemory ByVal MyString, ByVal lpClipMemory, lLength\n        RetVal = GlobalUnlock(hClipMemory)\n    Else\n        MsgBox "невозможно фиксировать блок памяти"\n    End If\n\nOutOfHere:\n    RetVal = CloseClipboard()\n    ClipBoard_GetData = MyString\nEnd Function\n\nPrivate Sub ClipBoard_SetData(MyString As String)\n    Dim hGlobalMemory As Long\n    Dim lpGlobalMemory As Long\n    Dim lLength As Long\n    Dim hClipMemory As Long\n    Dim x As Long\n     \'Выделяем блок памяти\n 
    lLength = Len(MyString)\n    hGlobalMemory = GlobalAlloc(GHND, lLength +  1 )\n     \'Фиксируем блок памяти, чтобы получить указатель\n 
    lpGlobalMemory = GlobalLock(hGlobalMemory)\n     \'Копируем строку в этот блок памяти\n 
    lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)\n\n     \'Снимаем фиксацию блока памяти\n 
    If GlobalUnlock(hGlobalMemory) <>  0  Then\n        MsgBox "Невозможно снять фиксацию блока память. Копирование прервано."\n        GoTo OutOfHere2\n    End If\n\n     \'Открываем буфер обмена для копирования\n 
    If OpenClipboard( 0 &) =  0  Then\n        MsgBox "Невозможно открыть буфер обмена. Копирование прервано."\n        Exit Sub\n    End If\n\n     \'Очистка буфера обмена\n 
    x = EmptyClipboard()\n\n     \'переключаемся на русскую раскладку чтобы не иметь\n 
     \'проблем с русским текстом в буфере\n 
     \'(некорректно понимается кодовая страница)\n 
    Dim sOldLang As String\n    sOldLang = switchLang("00000419")\n\n     \'Копируем данные в буфер обмена\n 
    hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)\nOutOfHere2:\n\n    If CloseClipboard() =  0  Then\n        MsgBox "Невозможно закрыть буфер обмена."\n    End If\n\n     \'возвращаем раскладку на место\n 
    If Len(sOldLang) >  0  Then sOldLang = switchLang(sOldLang)\nEnd Sub\n        \nPrivate Function getCurrLang() As String\n    Dim layoutname As String * KL_NAMELENGTH\n    Dim z As Long\n    z = GetKeyboardLayoutName(layoutname)\n\n    If z =  0  Then\n        getCurrLang = ""\n    Else\n        getCurrLang = StrZ(layoutname)\n    End If\nEnd Function\n\n \'Переключает на указанную sNewLang раскладку - возвращает старую раскладку\n 
Private Function switchLang(sNewLang As String) As String\n     \'"00000419" - русская\n 
     \'"00000409" - латинская\n 
    switchLang = getCurrLang\n    If StrComp(switchLang, sNewLang) <>  0  Then\n        LoadKeyboardLayout sNewLang,  1 \n    End If\nEnd Function\n\nPrivate Function StrZ(par As String) As String\n    Dim nSize As Long, i As Long\n    nSize = Len(par)\n    i = InStr( 1 , par, Chr$( 0 )) -  1 \n\n    If i > nSize Then i = nSize\n    If i <  0  Then i = nSize\n    StrZ = Mid$(par,  1 , i)\nEnd Function