ronblue

Untitled

Apr 11th, 2021
55
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1.  
  2. 'Enum SyntaxTypes
  3. '    ColorComment = 0
  4. '    ColorString = 1
  5. '    ColorReserved = 2
  6. '    ColorFuncObj = 3                                                                                                                                                                      
  7. '    ColorDelimiter = 4
  8. '    ColorNormal = 5
  9. 'End Enum
  10.  
  11. Declare Function FileOpen() as CWSTR
  12. declare Function Read_File( byval cws as CWSTR ) as long
  13. declare Function ParseWord(ByVal Word As String) As long  ' SyntaxTypes 'declare Function ParseWord(ByVal Word As String) As SyntaxTypes
  14. Declare Sub ParseLine(ByVal s As String, rtb As hwnd, ByVal RTBPos As Long)
  15. declare Sub Highlight(rtb As hwnd, SyntaxType As long, StartPos As Long, Length As Long) 'declare Sub Highlight(rtb As hwnd, SyntaxType As SyntaxTypes, StartPos As Long, Length As Long)
  16. 'declare function rtfText( byval hEdit as HWND, byval wszText as CWSTR, byval wszFontName as CWSTR, byval nFontSize as long, byval nFontEffect as long = 0, byval nFontColor as COLORREF = 0, Byval StartPos as Long, Byval Length as Long ) as Long
  17. declare function Parse_Selected_Line ( hWindow as hwnd ) as long
  18. Declare Function ParsePart( Byval hRichEdit as hwnd, byval IndexStart as long, Byval IndexEnd as long) as long
  19.  
  20. Dim shared IsLoading as long  'keep track of loading new file turning ' ColorNormal off  
  21.  
  22. ' Global variable used to suppress parsing until the end of a series of
  23. ' changes. Or, in the Change event itself to prevent cascaded Change events.
  24. 'Dim shared mbInChange As Boolean
  25.  
  26. ' assumes one character long comment
  27. Const COMMENT = "'"
  28.  
  29. Const DELIMITER = " {}[]()"  'vbTab & " ,(){}[]-+*%/='~!&|\<>?:;."
  30.  
  31. ' Space surrounding each word is significant. It allows searching on whole
  32. ' words. Note that these constant declares are long and could reach the line
  33. ' length limit of 1023 characters. If so, simply split to 2 constants and
  34. ' combine into a third constant with the appropriate name, Only use uppercase
  35. Dim shared RESERVED As String: RESERVED = " DIM LONG BOOLEAN IN DECLARE FUNCTION "     'Const RESERVED As String = " BOOLEAN IN "
  36. Const FUNC_OBJ As String = " ENTRY "
  37. Const KEYWORD_PAD As String = " "                  
  38.  
  39. ' Keeping track of current and previous insertion point. Used to determine
  40. ' what portion of text has changed.
  41. Dim shared mlPrevSelStart As Long
  42. dim shared mlCurSelStart As Long
  43.  
  44. Dim shared LnPosition as Integer
  45.  
  46. ' ========================================================================================                  
  47. '
  48. ' ========================================================================================
  49. Function FileOpen() as CWSTR
  50.           DIM wszFile AS WSTRING * 260 = "*.odl"   'Make sure the extension really exists with in wszFilter
  51.           DIM wszInitialDir AS STRING * 260 = CURDIR  
  52.           DIM wszFilter AS WSTRING * 260 = "odl files (*.odl)|*.odl|" & "All Files (*.*)|*.*|"
  53.           DIM dwFlags AS DWORD = OFN_EXPLORER OR OFN_FILEMUSTEXIST OR OFN_HIDEREADONLY OR OFN_ALLOWMULTISELECT
  54.           DIM cws AS CWSTR = AfxOpenFileDialog(frmMain.hWindow, "", wszFile, wszInitialDir, wszFilter, "odl", @dwFlags, NULL)
  55.            'if FileOpen = null then Function = 0 : Exit Function   'OpenFileReading( cws )
  56.      Function = cws
  57. End function
  58.  
  59. ' ========================================================================================
  60. '  
  61. ' General purpose, load the text into the richbox control
  62. ' ========================================================================================
  63. Function Read_File( byval cws as CWSTR ) as long
  64.  
  65.    'test for file existence and extension type
  66.    dim FullFileName As CWSTR, sCase as CWSTR
  67.     'test for file existence
  68.        if AfxFileExists (cws) = false then exit function 'for now thats fine
  69.     'test for existence file extension, chop off before backslash to be sure we are in the destination folder
  70.        FullFileName = Mid(cws, InStrRev(cws, "\") + 1, Len(cws))
  71.    'returns the full input string if no dot was found
  72.       sCase = Mid(FullFileName, InStrRev(FullFileName, ".") + 1, Len(FullFileName))
  73.    'compare the input value with the output value, if they are the same there is no file extension.
  74.       if sCase = FullFileName then
  75.        sCase = ""
  76.   end if
  77.  
  78. '        ? RichEdit_GetFirstVisibleLine( frmMain.RichEdit1.hWindow ) & " GetFirstVisibleLine"
  79. '        ? RichEdit_GetLastVisibleLine ( frmMain.RichEdit1.hWindow ) & " GetLastVisibleLine"
  80.  
  81.   'select the file reader, based on the file extension sCase
  82.   dim s As CWSTR, Index as long = 1, x as string
  83. '    select case sCase
  84.    
  85. '    Case "odl", ""
  86.    'Create an instance of the CTextStream class
  87.       DIM pTxtStm AS CTextStream                   '  Open file as a text stream
  88.       DIM cbsFile AS CBSTR = cws
  89.         pTxtStm.Open(cbsFile, IOMode_ForReading)   '  Read the file sequentially
  90.            DO UNTIL pTxtStm.EOS
  91.            x = pTxtStm.ReadLine
  92.            s = s & x & chr( 13, 10 )  
  93.            Index = Index + 1
  94.            LOOP
  95.         pTxtStm.Close
  96.          
  97.           RichEdit_SetText( frmMain.RichEdit1.hWindow, "" )
  98.           RichEdit_SetText( frmMain.RichEdit1.hWindow, s )   'makes it look faster
  99.           afxDoEvents
  100.           IsLoading = 1 'turning ColorNormal OFF speeding up load time
  101.  
  102. ' used to make it look faster
  103. '        if index > 85 then
  104.        
  105. '           ParsePart( frmMain.RichEdit1.hWindow, 0, 85 )
  106. '           afxDoevents
  107. '           ParsePart( frmMain.RichEdit1.hWindow, 86, index )
  108. '        else
  109.           ParsePart( frmMain.RichEdit1.hWindow, 0, index )
  110. '        end if
  111.           IsLoading = 0 'turning ColorNormal OFF speeding up load time
  112.  
  113. exit function
  114.  
  115. '   case "txt"    
  116.      
  117. '       dim x as string 'CWSTR
  118. '       dim f as long: f = freefile
  119. '         Open cws For Input As #f
  120. '            do until eof(f)
  121. '            line input #f, x
  122. '            s = s & x & chr( 13, 10 ) ' vbCrLf
  123. '            Index = Index + 1            
  124. '            loop
  125. '         Close #f
  126.    
  127. '   end select
  128.  
  129. '    mbInChange = True
  130. '    frmMain.RichEdit1.text = s    
  131. '    frmMain.RichEdit1.Refresh
  132. '    rtb_SelChange()
  133. '    mbInChange = False
  134. '    HighlightRefresh
  135. ''    PropertyChanged "Text"
  136. '    Function = 1
  137.  dim xi as long
  138. dim i as Integer
  139.       Dim hWindow as HWND  
  140.       Dim CursorPos As Long
  141.       Dim CurrLine As Long
  142.       Dim ChrsToStart As Long
  143. '       dim oldEventMask as long
  144. '       dim s as String  'CWSTR
  145.  
  146.    if index > 85 then
  147.        i = 85
  148.    else
  149. 'grote bestanden in stappen laden telkens 85? regels
  150.  
  151.        i = index
  152.    end if
  153.    
  154.    
  155.  
  156.  
  157. '============================================================      
  158.        hWindow = frmMain.RichEdit1.hWindow
  159.            RichEdit_SetText( hWindow, s )             'this is for your eyes only, reduce flickering
  160.    IsLoading = 1 'turning ColorNormal OFF speeding up load time
  161. AfxDoEvents
  162.  
  163.   'Prevent the control from raising any events.
  164.       dim oldEventMask as long
  165.        oldEventMask = SendMessage( hWindow, EM_SETEVENTMASK, 0, 0 )
  166.               SendMessage( hWindow, EM_HIDESELECTION,1,0 )
  167. '   'prevent textbox from repainting
  168.        SendMessage(hWindow, WM_SETREDRAW, 0, 0)
  169.    
  170.    
  171.          
  172.  
  173.  
  174.  
  175.    for xi = 0 to i
  176.   'number of chrs up to the current line
  177.       ChrsToStart = SendMessage( hWindow, EM_LINEINDEX, xi, null )
  178.   'Copies a line of text from a rich edit control.
  179.       s = RichEdit_GetLine( hWindow, xi )
  180.       s = Left(s,len(s) - 1 )  'CHR(0) ?
  181.   'Parse the line and adapt the colors from a rich edit control.  
  182.       ParseLine( s & " " , hWindow, ChrsToStart )  'rtfText function moves the caret and gives flickering  
  183.  
  184.   ' ? xi
  185.    next
  186.       SendMessage( hwindow, EM_SETSEL, 0, 0 )
  187. '        LnPosition = 0
  188. '       For i = 1 to index
  189. '        strLine = AfxStrParse(s, i, chr( 13, 10 )) ' vbCrLf )
  190. '        ParseLine(strLine, hwindow, LnPosition)
  191. '        LnPosition = LnPosition + Len(strLine) + 1
  192. '       Next i
  193.      
  194. '   'allow texbox to repaint
  195.       SendMessage(hWindow, WM_SETREDRAW, 1, 0)
  196. '   'Allow the control to raise event messages.
  197.       SendMessage( hWindow, EM_SETEVENTMASK, 0, oldEventMask )
  198.       SendMessage( hWindow, EM_HIDESELECTION,0,0 )
  199. '   'Signal the Control to be redrawn.
  200.       InvalidateRect hWindow, 0, True
  201.       UpdateWindow hWindow
  202.  
  203.   IsLoading = 0 'turning ColorNormal ON speeding up load time
  204.    
  205.   Function = 0
  206. end function
  207.  
  208. '
  209. '
  210. '
  211. Function ParsePart( Byval hRichEdit as hwnd, byval IndexStart as long, Byval IndexEnd as long) as long
  212.  
  213. dim oldEventMask as long    
  214. Dim xi as long
  215. dim s as CWSTR
  216.  
  217. Dim ChrsToStart As Long      
  218.        'Prevent the control from raising any events.
  219.        oldEventMask = SendMessage( hRichEdit, EM_SETEVENTMASK, 0, 0 )
  220.    
  221.        SendMessage( hRichEdit, EM_HIDESELECTION,1,0 )
  222.        'prevent control from repainting
  223.        SendMessage( hRichEdit, WM_SETREDRAW, 0, 0)
  224.      
  225.        'IndexStart
  226.    for xi = IndexStart to IndexEnd
  227.        'number of chrs up to the current line
  228.        ChrsToStart = SendMessage( hRichEdit, EM_LINEINDEX, xi, null )
  229.        'Copies a line of text from a rich edit control.
  230.        s = RichEdit_GetLine( hRichEdit, xi )
  231.        s = Left(s,len(s) - 1 )  'CHR(0) ?
  232.        'Parse the line and adapt the colors from a rich edit control.  
  233.        ParseLine( s & " " , hRichEdit, ChrsToStart )  'rtfText function moves the caret and gives flickering  
  234.    next
  235.       SendMessage( hRichEdit, EM_SETSEL, 0, 0 )
  236. '        LnPosition = 0
  237. '       For i = 1 to index
  238. '        strLine = AfxStrParse(s, i, chr( 13, 10 )) ' vbCrLf )
  239. '        ParseLine(strLine, hwindow, LnPosition)
  240. '        LnPosition = LnPosition + Len(strLine) + 1
  241. '       Next i
  242.      
  243. '   'allow control to repaint
  244.       SendMessage( hRichEdit, WM_SETREDRAW, 1, 0)
  245. '   'Allow the control to raise event messages.
  246.       SendMessage( hRichEdit, EM_SETEVENTMASK, 0, oldEventMask )
  247.       SendMessage( hRichEdit, EM_HIDESELECTION,0,0 )
  248. '   'Signal the Control to be redrawn.
  249.       InvalidateRect hRichEdit, 0, True
  250.       UpdateWindow hRichEdit    
  251.   Function = 0    
  252. end function
  253.  
  254. ' ========================================================================================
  255. '
  256. ' General purpose,  
  257. ' ========================================================================================
  258. function Parse_Selected_Line ( Byval hEdit as hwnd ) as long
  259. '   ? "Parse_Selected_Line"
  260. '   ? "anti flickering code turned of for testing keystrokes"
  261. '   ? ""
  262.    
  263.   'EM_GETMODIFY message
  264.       Dim CursorPos As Long
  265.       Dim CurrLine As Long
  266.       Dim ChrsToStart As Long
  267.       dim oldEventMask as long
  268.       dim s as String  'CWSTR
  269.      
  270.   'Prevent the control from raising any events.
  271. '       oldEventMask = SendMessage( hEdit, EM_SETEVENTMASK, 0, 0 )
  272.   'prevent textbox from repainting
  273.       SendMessage( hEdit, WM_SETREDRAW, 0, 0 )
  274.       SendMessage( hEdit, EM_HIDESELECTION,1,0 )
  275.      
  276.   'get the cursor position in the textbox
  277.       SendMessage( hEdit, EM_GETSEL, NULL, cast(LPARAM, @CursorPos) )
  278.   'get the current line index
  279.       CurrLine = SendMessage( hEdit, EM_LINEFROMCHAR, CursorPos, -1 )
  280.   'number of chrs up to the current line
  281.       ChrsToStart = SendMessage( hEdit, EM_LINEINDEX, CurrLine, null )
  282.   'Copies a line of text from a rich edit control.
  283.       s = RichEdit_GetLine( hEdit, CurrLine )
  284.       s = Left(s,len(s) - 1 )  'CHR(0) ?
  285.   'Parse the line and adapt the colors from a rich edit control.  
  286.       ParseLine( s & " " , hEdit, ChrsToStart )  'rtfText function moves the caret and gives flickering      
  287.   'set the cursor to the orginal location and clear the selection length  
  288.       SendMessage( hEdit, EM_SETSEL, CursorPos, CursorPos )        
  289.        
  290.   'Allow the control to raise event messages.
  291. '       SendMessage( hEdit, EM_SETEVENTMASK, 0, oldEventMask )
  292.   'allow texbox to repaint
  293.       SendMessage( hEdit, WM_SETREDRAW, true, null )
  294.       SendMessage( hEdit, EM_HIDESELECTION,0,0 )
  295.   'Signal the Control to be redrawn.
  296.       InvalidateRect hEdit, Null, True
  297.      ' UpdateWindow hEdit
  298.        
  299.   Function = 0
  300. end function
  301.    ' Ret = rtfText(  hEdit , wszText , wszFontName , nFontSize , nFontEffect , nFontColor , StartPos , Length )
  302.  
  303. ' ========================================================================================
  304. ' Lines are treated independently. Parseline is the main parsing code. Scan
  305. ' line from left to right, emitting text to be colored.
  306. ''Private Sub ParseLine(ByVal s As String, rtb As hwnd, ByVal RTBPos As Integer)  ' ByRef sender As wfxRichEdit, ByRef e As EventArgs
  307. ' ========================================================================================
  308. Sub ParseLine(ByVal s As String, rtb As hwnd , ByVal RTBPos As Long)
  309.    
  310.  
  311.    
  312.    Dim bInString As Boolean    ' are we in a quoted string?
  313.    bInString = False
  314.    
  315.    Dim bInWord As Boolean      ' are we in a word? (not a string, comment,
  316.                                ' or delimiter)
  317.    bInWord = False
  318.    
  319.    Dim sCurString As String        ' the current set of characters
  320.    Dim lCurStringStart As Long     '   - where it starts
  321.    Dim sCurChar As String          ' the current character
  322.    
  323.    Dim i As Long
  324.    
  325.    For i = 1 To Len(s)
  326.        sCurChar = Mid(s, i, 1)
  327.        If sCurChar = COMMENT Then   ' '
  328.            ' if comment character occurs within a quoted string, it doesn't count
  329.            If Not bInString Then
  330.                ' this is a comment. we are done with the line
  331.                If bInWord Then
  332.                    ' before we encounterd the comment we were processing a word
  333.                    Highlight rtb, ParseWord(sCurString), lCurStringStart + RTBPos - 1, i - lCurStringStart
  334.                    sCurString = ""
  335.                    bInWord = False
  336.                End If
  337.                Highlight rtb, 0, i + RTBPos - 1, Len(s) - i + 1           'ColorComment
  338.                exit sub ' rest of line is comment
  339.            End If
  340.        End If
  341.        
  342.        If sCurChar = """" Then
  343.            ' if not already in a string, then this quote begins a string
  344.            ' otherwise, we are in a string, and this quote ends it
  345.            If bInString Then
  346.                sCurString = sCurString & sCurChar
  347.                Highlight rtb, 1, lCurStringStart + RTBPos - 1, i - lCurStringStart + 1  'ColorString
  348.                sCurString = ""
  349.                bInString = False
  350.            Else
  351.                If bInWord Then
  352.                    ' before we encounterd the string we were processing a word
  353.                    Highlight rtb, ParseWord(sCurString), lCurStringStart + RTBPos - 1, i - lCurStringStart
  354.                    sCurString = ""
  355.                    bInWord = False
  356.                End If
  357.                
  358.                bInString = True
  359.                sCurString = sCurChar
  360.                lCurStringStart = i
  361.            End If
  362.            Continue For ' get next character
  363.        End If
  364.      
  365.        If InStr(1, DELIMITER, sCurChar) > 0 Then
  366.            If bInWord Then
  367.                ' before we encounterd the delimiter we were processing a word
  368.                Highlight rtb, ParseWord(sCurString), lCurStringStart + RTBPos - 1, i - lCurStringStart
  369.                sCurString = ""
  370.                bInWord = False
  371.            End If
  372.              
  373.            Highlight rtb, 4, i + RTBPos - 1, 1   'ColorDelimiter = 4
  374.            Continue For
  375.        End If
  376.              
  377.        If (Not bInWord) And (Not bInString) Then
  378.            bInWord = True
  379.            sCurString = sCurChar
  380.            lCurStringStart = i
  381.              
  382.            Continue For
  383.        End If
  384.            
  385.        ' add current character to the "word" we are in the middle of
  386.        sCurString = sCurString & sCurChar
  387.    Next
  388.    
  389.    If bInString Then
  390.        ' before we encounterd the end of the line we were processing a string
  391.        Highlight rtb, 1, lCurStringStart + RTBPos - 1, i - lCurStringStart           'ColorString = 1
  392.    ElseIf bInWord Then
  393.        ' before we encounterd the end of the line we were processing a word
  394.        Highlight rtb, ParseWord(sCurString), lCurStringStart + RTBPos - 1, i - lCurStringStart
  395.    End If
  396.  
  397. End Sub
  398.  
  399. ' ========================================================================================
  400. ' Function ParseWord
  401. ' Determine color for this word by checking for its existence in the keyword lists.
  402. ' The word being checked it padded with spaces to prevent matches with substrings of keywords.
  403. ' first = InStr( [ start, ] str, [ Any ] substring )
  404. ' ========================================================================================
  405. Private Function ParseWord( ByVal Word As String ) As long 'SyntaxTypes
  406.                   Word = UCase ( Word )
  407.      If InStr( 1, RESERVED, KEYWORD_PAD & Word & KEYWORD_PAD ) > 0 Then                     ' If InStr(1, RESERVED, KEYWORD_PAD & Word & KEYWORD_PAD, vbTextCompare)
  408.        ParseWord = 2         'ColorReserved = 2
  409.    ElseIf InStr( 1, FUNC_OBJ, KEYWORD_PAD & Word & KEYWORD_PAD ) > 0 Then                   ' ElseIf InStr(1, FUNC_OBJ, KEYWORD_PAD & Word & KEYWORD_PAD, vbTextCompare) > 0 Then
  410.        ParseWord = 3  'ColorFuncObj
  411.    Else
  412.        ParseWord = 5 'ColorNormal
  413.    End If
  414. End Function
  415.  
  416. ' ========================================================================================
  417. ' Color this range in the RichTextBox. Note that you could also apply bold,
  418. ' italic, etc. to the selection at the same time.
  419. ' ========================================================================================
  420. Private Sub Highlight(hEdit As hwnd, SyntaxType As long, StartPos As Long, Length As Long)
  421.    
  422.    dim cf AS CHARFORMAT2
  423.        cf.cbsize            = sizeof(cf)
  424.        cf.dwMask            = CFM_COLOR
  425.    
  426.    select case SyntaxType
  427.          case 0             ' ColorComment
  428.              cf.crTextColor = colors.Green
  429.          Case 1             ' ColorString
  430.              cf.crTextColor = colors.DarkGoldenRod
  431.          case 2             ' ColorReserved
  432.              cf.crTextColor = colors.Blue
  433.          case 3             ' ColorFuncObj
  434.              cf.crTextColor = colors.Red
  435.          case 4             ' ColorDelimiter
  436.              cf.crTextColor = colors.YellowGreen
  437.          case 5             ' ColorNormal
  438.             if IsLoading = 1 then exit sub 'loading a new file no need to set black
  439.              cf.crTextColor = colors.Black
  440.    end select
  441.    
  442.        Length = Length + StartPos
  443.        SendMessage( hEdit, EM_SETSEL, StartPos, Length )  'this moves the caret and makes flicker  
  444.        SendMessage( hEdit, EM_SETCHARFORMAT, SCF_SELECTION, cast(LPARAM, @cf) )
  445.  
  446.  
  447. 'redraw only singel line or some charters ?   EM_SETRECT  EM_GETRECT
  448. 'http://www.devx.com/vb2themax/Tip/18612
  449. ' getting garet position left down etc
  450. end sub
  451.  
  452. ' ========================================================================================
  453. ' Load_Text DEZE WERKT GOED
  454. ' General purpose, load the text into the richbox control
  455. ' ========================================================================================
  456. 'Function Read_File1( byval cws as CWSTR ) as long
  457.  
  458. '   'test for file existence and extension type
  459. '   dim FullFileName As CWSTR, sCase as CWSTR
  460. '    'test for file existence
  461. '       if AfxFileExists (cws) = false then exit function 'for now thats fine
  462. '    'test for existence file extension, chop off before backslash to be sure we are in the destination folder
  463. '       FullFileName = Mid(cws, InStrRev(cws, "\") + 1, Len(cws))
  464. '    'returns the full input string if no dot was found
  465. '       sCase = Mid(FullFileName, InStrRev(FullFileName, ".") + 1, Len(FullFileName))
  466. '    'compare the input value with the output value, if they are the same there is no file extension.
  467. '       if sCase = FullFileName then
  468. '        sCase = ""
  469. '   end if
  470.  
  471. ''        ? RichEdit_GetFirstVisibleLine( frmMain.RichEdit1.hWindow ) & " GetFirstVisibleLine"
  472. ''        ? RichEdit_GetLastVisibleLine ( frmMain.RichEdit1.hWindow ) & " GetLastVisibleLine"
  473.  
  474. '   'select the file reader, based on the file extension sCase
  475. '   dim s As CWSTR, Index as long = 1, x as string
  476. '    select case sCase
  477.    
  478. '    Case "odl", ""
  479. '    'Create an instance of the CTextStream class
  480. '       DIM pTxtStm AS CTextStream                   '  Open file as a text stream
  481. '       DIM cbsFile AS CBSTR = cws
  482. '         pTxtStm.Open(cbsFile, IOMode_ForReading)   '  Read the file sequentially
  483. '            DO UNTIL pTxtStm.EOS
  484. '            x = pTxtStm.ReadLine
  485. '            s = s & x & chr( 13, 10 )  
  486. '            Index = Index + 1
  487. '            LOOP
  488. '         pTxtStm.Close
  489.      
  490. '   case "txt"    
  491.      
  492. '       dim x as string 'CWSTR
  493. '       dim f as long: f = freefile
  494. '         Open cws For Input As #f
  495. '            do until eof(f)
  496. '            line input #f, x
  497. '            s = s & x & chr( 13, 10 ) ' vbCrLf
  498. '            Index = Index + 1            
  499. '            loop
  500. '         Close #f
  501.    
  502. '   end select
  503.  
  504. ''    mbInChange = True
  505. ''    frmMain.RichEdit1.text = s    
  506. ''    frmMain.RichEdit1.Refresh
  507. ''    rtb_SelChange()
  508. ''    mbInChange = False
  509. ''    HighlightRefresh
  510. '''    PropertyChanged "Text"
  511. ''    Function = 1
  512. ''exit function
  513.  
  514. '       Dim hWindow as HWND  
  515. '        hWindow = frmMain.RichEdit1.hWindow
  516. '   'Prevent the control from raising any events.
  517. '       dim oldEventMask as long
  518. '        oldEventMask = SendMessage( hWindow, EM_SETEVENTMASK, 0, 0 )
  519. '   'prevent textbox from repainting
  520. '        SendMessage(hWindow, WM_SETREDRAW, 0, 0)
  521.    
  522. '   'split the string s and feed it to the parser
  523. '       dim i as Integer, strLine as string    
  524. '        RichEdit_SetText( hWindow, s )
  525. '        LnPosition = 0
  526. '       For i = 1 to index
  527. '        strLine = AfxStrParse(s, i, chr( 13, 10 )) ' vbCrLf )
  528. '        ParseLine(strLine, hwindow, LnPosition)
  529. '        LnPosition = LnPosition + Len(strLine) + 1
  530. '       Next i
  531.      
  532. '   'allow texbox to repaint
  533. '       SendMessage(hWindow, WM_SETREDRAW, 1, 0)
  534. '   'Allow the control to raise event messages.
  535. '       SendMessage( hWindow, EM_SETEVENTMASK, 0, oldEventMask )
  536. '   'Signal the Control to be redrawn.
  537. '       InvalidateRect hWindow, 0, True
  538. '       UpdateWindow hWindow
  539.  
  540.    
  541. '   Function = 0
  542. 'end function
  543.  
  544. ' ========================================================================================
  545. ' Load_Text
  546. ' General purpose, load the text into the richbox control
  547. ' ========================================================================================
  548. 'Function Read_File2( byval cws as CWSTR ) as long
  549.  
  550. '   'test for file existence and extension type
  551. '   dim FullFileName As CWSTR, sCase as CWSTR
  552. '    'test for file existence
  553. '       if AfxFileExists (cws) = false then exit function 'for now thats fine
  554. '    'test for existence file extension, chop off before backslash to be sure we are in the destination folder
  555. '       FullFileName = Mid(cws, InStrRev(cws, "\") + 1, Len(cws))
  556. '    'returns the full input string if no dot was found
  557. '       sCase = Mid(FullFileName, InStrRev(FullFileName, ".") + 1, Len(FullFileName))
  558. '    'compare the input value with the output value, if they are the same there is no file extension.
  559. '       if sCase = FullFileName then
  560. '        sCase = ""
  561. '   end if
  562.  
  563. '   'select the file reader, based on the file extension sCase
  564. '   dim s As CWSTR, Index as long = 1, x as string
  565. '    select case sCase
  566.    
  567. '    Case "odl", ""
  568. '    'Create an instance of the CTextStream class
  569. '       DIM pTxtStm AS CTextStream                   '  Open file as a text stream
  570. '       DIM cbsFile AS CBSTR = cws
  571. '         pTxtStm.Open(cbsFile, IOMode_ForReading)   '  Read the file sequentially
  572. '            DO UNTIL pTxtStm.EOS
  573. '            x = pTxtStm.ReadLine
  574. '            s = s & x & chr( 13, 10 ) 'vbCrLf  
  575. '            Index = Index + 1
  576. '            LOOP
  577. '         pTxtStm.Close
  578.      
  579. '   case "txt"    
  580.      
  581. '       dim x as string 'CWSTR
  582. '       dim f as long: f = freefile
  583. '         Open cws For Input As #f
  584. '            do until eof(f)
  585. '            line input #f, x
  586. '            s = s & x & chr( 13, 10 ) 'vbCrLf
  587. '            Index = Index + 1            
  588. '            loop
  589. '         Close #f
  590.    
  591. '   end select
  592.  
  593. ''    mbInChange = True
  594. ''    frmMain.RichEdit1.text = s    
  595. ''    frmMain.RichEdit1.Refresh
  596. ''    rtb_SelChange()
  597. ''    mbInChange = False
  598. ''    HighlightRefresh
  599. '''    PropertyChanged "Text"
  600. ''    Function = 1
  601. ''exit function
  602.  
  603. '       Dim hWindow as HWND  
  604. '        hWindow = frmMain.RichEdit1.hWindow
  605. '   'Prevent the control from raising any events.
  606. '       dim oldEventMask as long
  607. '        oldEventMask = SendMessage( hWindow, EM_SETEVENTMASK, 0, 0 )
  608. '   'prevent textbox from repainting
  609. '        SendMessage(hWindow, WM_SETREDRAW, 0, 0)
  610.    
  611. '   'split the string s and feed it to the parser
  612. '       dim i as Integer, strLine as string    
  613. '        RichEdit_SetText( hWindow, s )
  614. '        LnPosition = 0
  615. '       For i = 1 to index
  616. '        strLine = AfxStrParse(s, i, chr( 13, 10 )) 'vbCrLf )
  617. '        ParseLine(strLine, hwindow, LnPosition)
  618. '        LnPosition = LnPosition + Len(strLine) + 1
  619. '       Next i
  620.      
  621. '   'allow texbox to repaint
  622. '       SendMessage(hWindow, WM_SETREDRAW, 1, 0)
  623. '   'Allow the control to raise event messages.
  624. '       SendMessage( hWindow, EM_SETEVENTMASK, 0, oldEventMask )
  625. '   'Signal the Control to be redrawn.
  626. '       InvalidateRect hWindow, 0, True
  627. '       UpdateWindow hWindow
  628.  
  629.    
  630. '   Function = 0
  631. 'end function
  632.  
  633. 'Function Parse_Selected_Line2 ( hwindow as hwnd) as long
  634. '   ? ""
  635. '   ? ""  
  636. '   ' Copies a line of text from a rich edit control.
  637. '' ========================================================================================
  638. ''PRIVATE FUNCTION RichEdit_GetLine (BYVAL hRichEdit AS HWND, BYVAL which AS DWORD) AS CWSTR
  639. ' 'retrieves either the line number of the current line (the line containing the caret) or, if there is a selection, the line number of the line containing the beginning of the selection.
  640.    
  641. ' 'If this parameter is -1, EM_LINEFROMCHAR retrieves either the line number of the current line (the line containing the caret)  
  642. '      Dim as long i = RichEdit_LineFromChar ( hwindow, -1 )  
  643. '      dim as long p = RichEdit_LineIndex ( hWindow, i)
  644.          
  645. '       'Copies a line of text from a rich edit control.
  646. '      dim as string s = RichEdit_GetLine ( hWindow, i )
  647. '       s = Left(s,len(s) - 1 )
  648. '       'Parse the line and adapt the colors from a rich edit control.  
  649. '       ParseLine( s & " " , hWindow, p )    'rtfText function moves the caret
  650. '       ' SendMessage(hWindow, EM_SETSEL, p, p)  
  651.  
  652.  
  653. '    Function = 0
  654. 'end function
  655.  
  656. 'PRIVATE FUNCTION RichEdit_LineFromChar (BYVAL hRichEdit AS HWND, BYVAL index AS DWORD) AS LONG
  657. '   FUNCTION = SendMessageW(hRichEdit, EM_LINEFROMCHAR, index, 0)
  658. 'END FUNCTION
  659.  
  660. ' ========================================================================================
  661. ' Color this range in the RichTextBox. Note that you could also apply bold,
  662. ' italic, etc. to the selection at the same time.
  663. ' ========================================================================================
  664. 'Private Sub Highlight(hwindow As hwnd, SyntaxType As SyntaxTypes, StartPos As Long, Length As Long)
  665. '      Select Case SyntaxType
  666. '            Case SyntaxTypes.ColorComment
  667. '                  rtfText( hwindow, "", "arial", 9, Null, colors.Green, StartPos, Length )
  668. '            Case SyntaxTypes.ColorString
  669. '                  rtfText( hwindow, "", "arial", 9, Null, colors.DarkGoldenRod, StartPos, Length )
  670. '            Case SyntaxTypes.ColorReserved
  671. '                  rtfText( hwindow, "", "arial", 9, Null, colors.Blue , StartPos, Length )
  672. '            Case SyntaxTypes.ColorFuncObj
  673. '                  rtfText( hwindow, "", "arial", 9, Null, colors.Red , StartPos, Length )
  674. '            Case SyntaxTypes.ColorDelimiter
  675. '                  rtfText( hwindow, "", "arial", 9, Null, colors.YellowGreen, StartPos, Length )
  676. '            Case SyntaxTypes.ColorNormal
  677. '                  rtfText( hwindow, "", "arial", 9, Null, 0, StartPos, Length ) 'colors.DarkMagenta, StartPos, Length )
  678. '            case  Else
  679. '    End Select
  680. 'End Sub
  681.  
  682. '' ========================================================================================
  683. '' rtfText 'this tacking very long
  684. '' General purpose routine to set the font, size, effect, color for text to be entered.
  685. '' ========================================================================================
  686. 'function rtfText( byval hEdit as HWND, _
  687. '                  byval wszText as CWSTR, _
  688. '                  byval wszFontName as CWSTR, _
  689. '                  byval nFontSize as long, _
  690. '                  byval nFontEffect as long = 0, _
  691. '                  byval nFontColor as COLORREF = 0, _
  692. '                  Byval StartPos as Long, _
  693. '                  Byval Length as Long _
  694. '                  ) as Long
  695.  
  696. '   'exit function
  697.              
  698. '     Length = Length + StartPos
  699.  
  700. '  ' dim hDC AS HDC
  701. '   dim lRet AS LONG
  702. '   dim cf AS CHARFORMAT2
  703. '   'DIM tlf AS LOGFONTW
  704.    
  705. '   'dim stex as SETTEXTEX
  706. '   'stex.flags = ST_SELECTION or ST_UNICODE
  707.  
  708. '  ' hDC = GetDC(NULL)
  709. '  ' EnumFontFamiliesExW( hDC, byval wszFontName, cast(FONTENUMPROCW, @RichEdit_EnumFontFamProcW), cast(LPARAM, @tlf), Null )
  710. '  ' ReleaseDC NULL, hDC
  711.  
  712. '   cf.cbsize          = sizeof(cf)
  713. '   cf.dwMask          = CFM_COLOR 'or CFM_SIZE 'CFM_FACE  or CFM_UNDERLINE OR CFM_STRIKEOUT or CFM_COLOR OR CFM_CHARSET 'CFM_FACE or CFM_SIZE or CFM_BOLD OR CFM_ITALIC OR CFM_UNDERLINE OR CFM_STRIKEOUT or CFM_COLOR OR CFM_CHARSET
  714. '   'cf.szFaceName      = tlf.lfFaceName
  715. '   'cf.bCharSet        = tlf.lfCharSet
  716. '   'cf.bPitchAndFamily = tlf.lfPitchAndFamily
  717. '   'cf.yHeight         = nFontSize * 20
  718. '   'cf.dwEffects       = nFontEffect
  719. '   cf.crTextColor     = nFontColor
  720. ''cf.yOffset
  721.  
  722.  
  723. '' dim P as CharRange
  724. ''         P.cpmin = StartPos
  725. ''         P.cpmax = Length
  726. ''         SendMessage(hEdit, EM_EXSetSel, 0, @P)
  727.  
  728. ''EM_REPLACESEL
  729. '   SendMessage( hEdit, EM_SETSEL, StartPos, Length )  ' SendMessage( hEdit, EM_SETSEL, Cast(WPARAM, StartPos), Cast(LPARAM, Length ) )  'this moves the caret and makes flicker
  730. '    SendMessage( hEdit, EM_SETCHARFORMAT, SCF_SELECTION, cast(LPARAM, @cf) )
  731.  
  732. '''' ' ========================================================================================
  733. ''''' Sets character formatting in a rich edit control.
  734. ''''' ========================================================================================
  735. ''''PRIVATE FUNCTION RichEdit_SetCharFormat (BYVAL hRichEdit AS HWND, BYVAL chfmt AS DWORD, BYVAL pchfmt AS DWORD) AS LONG
  736. ''''   FUNCTION = SendMessageW(hRichEdit, EM_SETCHARFORMAT, chfmt, pchfmt)
  737. ''''END FUNCTION
  738.  
  739.  
  740. '    'SendMessage( hEdit, EM_SETSEL, Cast(WPARAM, StartPos), Cast(LPARAM, Length ) )  'this moves the caret and makes flicker
  741. '   'SendMessage( hEdit, EM_SETCHARFORMAT, SCF_SELECTION or SCF_WORD, cast(LPARAM, @cf) )
  742. ''   SendMessage( hEdit, EM_SETCHARFORMAT, SCF_SELECTION, cast(LPARAM, @cf) )
  743.  
  744. '   'print "StartPos  " & StartPos
  745. '   'Print "length    " & length
  746.  
  747. '  ' RichEdit_SetTextExW( hEdit, @stex, wszText )or SCF_WORD
  748.  
  749. '   'SendMessage( hEdit, EM_SETCHARFORMAT, (WPARAM)SCF_SELECTION|SCF_WORD, (LPARAM)&cf)
  750.  
  751. '   function = 0
  752. 'end function
  753.  
  754.  
  755.  
  756.  
RAW Paste Data

Adblocker detected! Please consider disabling it...

We've detected AdBlock Plus or some other adblocking software preventing Pastebin.com from fully loading.

We don't have any obnoxious sound, or popup ads, we actively block these annoying types of ads!

Please add Pastebin.com to your ad blocker whitelist or disable your adblocking software.

×