Прога для форматирования кода для этого форума

[marvan]

Предлагаю вашему вниманию программу, позволяющую форматировать VB код для этого форума. Зачем это нужно? - Код с таким форматированием читается гораздо легче. (ну не воспринимают мозги монотонно зелёный код генерируемый тегом Code) Так что пользуйтесь и участвуйте в дальнейшем развитии этого проекта.
'Для использования - создать новый проект VB или VBA
    ' - поместить в код формы ниже лежащий текст программы
    ' - скопировать любой код и запустить программу (открыть форму)
    'В буфере обмена будет размеченный код, готовый для вставки в ваше сообщение на форуме
    'Предлагаю поучаствовать в дальнейшем развитии этого проекта
    Option Explicit
    
    Private Declare Function OpenClipboard _
                    Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function CloseClipboard _
                    Lib "user32" () As Long
    Private Declare Function GetClipboardData _
                    Lib "user32" (ByVal wFormat As Long) As Long
    Private Declare Function GlobalAlloc _
                    Lib "kernel32" (ByVal wFlags&, _
                                    ByVal dwBytes As Long) 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 lstrlen _
                    Lib "kernel32" _
                    Alias "lstrlenA" (ByVal lpString As Long) As Long
    Private Declare Sub CopyMemory _
                    Lib "kernel32" _
                    Alias "RtlMoveMemory" (pDst As Any, _
                                           pSrc As Long, _
                                           ByVal ByteLen As Long)
    
    Private Declare Function lstrcpy _
                    Lib "kernel32" (ByVal lpString1 As Any, _
                                    ByVal lpString2 As Any) As Long
    Private Declare Function EmptyClipboard _
                    Lib "user32" () As Long
    Private Declare Function SetClipboardData _
                    Lib "user32" (ByVal wFormat As Long, _
                                  ByVal hMem As Long) As Long
    
    Private Declare Function GetKeyboardLayoutName _
                    Lib "user32" _
                    Alias "GetKeyboardLayoutNameA" (ByVal pwszKLID As String) As Long
    Private Declare Function LoadKeyboardLayout _
                    Lib "user32" _
                    Alias "LoadKeyboardLayoutA" (ByVal HKL As String, _
                                                 ByVal Flags As Long) As Long
    Private Const KL_NAMELENGTH = 9
    Private Const GHND = &H42
    Private Const CF_TEXT = 1

Public Sub Form_Load()
    'Процедура форматирования кода
    
    Dim aStr(0 To 199) As String 'массив искомых слов
    Dim mStrIn As String 'входящая строка
    Dim mStrInLen As Long 'длина входящей строки
    Dim mStrOut As String 'выходящая строка
    Dim mStrSub As String 'выделенная подстрока
    Dim mChr As String 'выделенный символ
    Dim mNum As Long 'текущая позиция
    Dim mNumOld As Long 'предыдущая позиция
    Dim bOk As Boolean 'признак обнаружения подстроки
    Dim i As Byte 'счётчик
    Dim arr1 As Variant
    Dim arr2 As Variant
                
    'массив ключевых слов
    arr1 = Array("#If", "#End", "#ElseIf", "#Else", "#Const", "Xor", "Write", _
       "WithEvents", "With", "Width", "While", "Wend", "Variant", _
       "Until", "Unknown", "Unlock", "Unload", "UBound", "TypeOf", _
       "Type", "True", "To", "Then", "Text", "Tab", "Sub", "String$", _
       "String", "StrComp", "Stop", "Step", "Static", "Spc", "Single", _
       "Shared", "Sgn", "Set", "Select", "Seek", "Scale", "RSet", _
       "RGB", "Return", "Resume", "Rem", "ReDim", "Read", "Randomize", _
       "Random", "RaiseEvent", "Put", "Public", "PSet", "Property", _
       "Private", "Print", "Preserve", "ParamArray", "Output", "Or", _
       "Optional", "Option", "Open", "On", "Object", "Null", "Nothing", _
       "Not", "Next", "New", "Name", "Module", "Mod", "MidB$", "MidB", _
       "Mid$", "Mid", "Me", "LSet", "Loop", "Long", "Lock", "Local", _
       "Load", "LINEINPUT", "Line", "Like", "Lib", "Let", "LenB", "Len", _
       "Left", "LBound", "Is", "Integer", "Int", "InStrB", "InStr", _
       "InputB$", "InputB", "Input$", "Input", "In", "Implements", _
       "Imp", "If", "GoTo", "GoSub", "Go", "Global", "Get", "Function", _
       "Friend", "FreeFile", "Format$", "Format", "For", "Fix", "False", _
       "F", "Explicit", "Exit", "Event", "Error$", "Error", "Erase", _
       "Eqv", "Enum", "EndIf", "End", "Empty", "ElseIf", "Else", "Each", _
       "Double", "DoEvents", "Do", "Dir$", "Dir", "Dim", "DefVar", "DefStr", _
       "DefSng", "DefObj", "DefLng", "DefInt", "DefDbl", "DefDec", "DefDate", _
       "DefCur", "DefByte", "DefBool", "Declare", "Decimal", "Debug", "Date$", _
       "Date", "Database", "Currency", "CVErr", "CVDate", "CVar", "CurDir$", _
       "CurDir", "CStr", "CSng", "Const", "Compare", "Close", "CLng", "Circle", _
       "CInt", "ChDir", "CDecl", "CDbl", "CDec", "CDate", "CCur", "CByte")
    'ограничение на размер массива, определяемого таким способом
    arr2 = Array("CBool", "Case", "Call", "ByVal", "Byte", "ByRef", "Boolean", _
       "Binary", "BF", "Base", "B", "Assert", "As", "Array", "Append", "Any", _
       "And", "Alias", "AddressOf", "Access", "Abs")

    For i = 0 To 178
        aStr(i) = arr1(i)
    Next
    For i = 0 To 20
        aStr(179 + i) = arr2(i)
    Next
 
    mStrIn = ClipBoard_GetData & vbCr 'получили строку из буфера
    mNumOld = 0
    mStrInLen = Len(mStrIn)

    For mNum = 1 To mStrInLen 'перечисляем все символы входящей строки
        mChr = Mid$(mStrIn, mNum, 1) 'выделяем символ
        If mChr = " " Or mChr = vbCr Or mChr = vbLf Or mChr = "(" Or mChr = ")" _
           Or mChr = "," Or mNum = Len(mStrIn) Then

            If mChr = " " Then mChr = "&#" & "160;"
            'обнаружен разделитель слов
            mStrSub = Mid$(mStrIn, mNumOld + 1, mNum - mNumOld - 1) 'выделяем подстроку
            bOk = False

            For i = 0 To 199 'поиск подстроки
                If mStrSub = aStr(i) Then
                    bOk = True
                    Exit For
                End If
            Next
            
            If bOk = True Then 'подстрока найдена
                mStrOut = mStrOut & "[" & "color=blue" & "]" & mStrSub & _
                                    "[" & "/color" & "]" & mChr
            Else
                mStrOut = mStrOut & mStrSub & mChr
            End If
            mNumOld = mNum
        End If

        If mChr = Chr$(39) Then 'обнаружен коментарий
            mNum = InStr(mNum, mStrIn, vbCrLf)
            If mNum = 0 Then mNum = Len(mStrIn)
            mStrSub = Mid$(mStrIn, mNumOld + 1, mNum - mNumOld - 1) 'выделяем подстроку
            mStrOut = mStrOut & "[" & "color=green" & "]" & mStrSub & _
                                "[" & "/color" & "]"
            mNumOld = mNum - 1
        End If

        If mChr = vbLf And Right$(mStrOut, 2) = vbCrLf Then
            mStrOut = Left$(mStrOut, Len(mStrOut) - 2)
            mStrOut = mStrOut & vbCrLf
        End If
    Next

    mStrOut = mStrOut & vbCrLf
    'ссылка на эту процедуру
    mStrOut = mStrOut & "[" & "url=http://"
    mStrOut = mStrOut & "bbs.vbstreets.ru/viewtopic.php?t=9979" & "]"
    mStrOut = mStrOut & "Как отформатирован этот код?" & "[" & "/url" & "]"
    ClipBoard_SetData (mStrOut) 'вернули строку в буфер
    MsgBox "Код скопирован в буфер"
End Sub

'vba не имеет класса Сlipboard
'ниже приведены функции найденные на
'http://am.rusimport.ru/MsAccess/topic.aspx?ID=229
'и модифицированные мной
Private Function ClipBoard_GetData() As String
    Dim hClipMemory As Long
    Dim lpClipMemory As Long
    Dim MyString As String
    Dim lLength As Long
    Dim RetVal As Long
    
    If OpenClipboard(0&) = 0 Then
        MsgBox "Невозможно открыть буфер обмена, " & "Может быть он занят другим приложением"
        Exit Function
    End If

    ' получить указатель на блок памяти, с текстом буфера обмена
    hClipMemory = GetClipboardData(CF_TEXT)

    If IsNull(hClipMemory) Then
        MsgBox "Невозможно выделить память"
        GoTo OutOfHere
    End If
         
    ' фиксируем блок памяти, чтобы получить указатель на строку
    lpClipMemory = GlobalLock(hClipMemory)
    lLength = lstrlen(lpClipMemory)

    If Not IsNull(lpClipMemory) Then
        MyString = Space$(lLength)
        CopyMemory ByVal MyString, ByVal lpClipMemory, lLength
        RetVal = GlobalUnlock(hClipMemory)
    Else
        MsgBox "невозможно фиксировать блок памяти"
    End If

OutOfHere:
    RetVal = CloseClipboard()
    ClipBoard_GetData = MyString
End Function

Private Sub ClipBoard_SetData(MyString As String)
    Dim hGlobalMemory As Long
    Dim lpGlobalMemory As Long
    Dim lLength As Long
    Dim hClipMemory As Long
    Dim x As Long
    'Выделяем блок памяти
    lLength = Len(MyString)
    hGlobalMemory = GlobalAlloc(GHND, lLength + 1)
    'Фиксируем блок памяти, чтобы получить указатель
    lpGlobalMemory = GlobalLock(hGlobalMemory)
    'Копируем строку в этот блок памяти
    lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)

    'Снимаем фиксацию блока памяти
    If GlobalUnlock(hGlobalMemory) <> 0 Then
        MsgBox "Невозможно снять фиксацию блока память. Копирование прервано."
        GoTo OutOfHere2
    End If

    'Открываем буфер обмена для копирования
    If OpenClipboard(0&) = 0 Then
        MsgBox "Невозможно открыть буфер обмена. Копирование прервано."
        Exit Sub
    End If

    'Очистка буфера обмена
    x = EmptyClipboard()

    'переключаемся на русскую раскладку чтобы не иметь
    'проблем с русским текстом в буфере
    '(некорректно понимается кодовая страница)
    Dim sOldLang As String
    sOldLang = switchLang("00000419")

    'Копируем данные в буфер обмена
    hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
OutOfHere2:

    If CloseClipboard() = 0 Then
        MsgBox "Невозможно закрыть буфер обмена."
    End If

    'возвращаем раскладку на место
    If Len(sOldLang) > 0 Then sOldLang = switchLang(sOldLang)
End Sub
        
Private Function getCurrLang() As String
    Dim layoutname As String * KL_NAMELENGTH
    Dim z As Long
    z = GetKeyboardLayoutName(layoutname)

    If z = 0 Then
        getCurrLang = ""
    Else
        getCurrLang = StrZ(layoutname)
    End If
End Function

'Переключает на указанную sNewLang раскладку - возвращает старую раскладку
Private Function switchLang(sNewLang As String) As String
    '"00000419" - русская
    '"00000409" - латинская
    switchLang = getCurrLang
    If StrComp(switchLang, sNewLang) <> 0 Then
        LoadKeyboardLayout sNewLang, 1
    End If
End Function

Private Function StrZ(par As String) As String
    Dim nSize As Long, i As Long
    nSize = Len(par)
    i = InStr(1, par, Chr$(0)) - 1

    If i > nSize Then i = nSize
    If i < 0 Then i = nSize
    StrZ = Mid$(par, 1, i)
End Function

[GSerg]

Уууу, ещё один

http://old.vbstreets.ru/topic.asp?TOPIC_ID=6732

[alibek]

Ага.
Я тоже как-то делал такую штуку и как всегда не закончил. Только у меня была раздельная подсветка комментариев, ключевых слов, событий, числовых констант, строк, идентификаторов. Вот только пользы от такой раскраски мало, все-равно код обычно копируют в VB, а не исполняют мысленно.