PureBasic - форум

Информация о пользователе

Привет, Гость! Войдите или зарегистрируйтесь.

Вы здесь » PureBasic - форум » PureBasic для Windows » ColorText

ColorText

Страница: 1

Сообщений 1 страница 3 из 3

1

  • Автор: AZJIO
  • Активный участник
  • Зарегистрирован: 07.08.2020
  • Приглашений: 0
  • Сообщений: 1311
  • Уважение: [+20/-0]
  • Позитив: [+15/-0]
  • Провел на форуме:
    27 дней 3 часа
  • Последний визит:
    Вчера 18:15:53

ColorText

Позволяет получить вот такой текст

Скачать: yandex, upload.ee

https://www.upload.ee/image/18124607/ColorTextRu.png

Код:
; AZJIO 21.05.2025
;- TOP
EnableExplicit

Define UserIntLang, *Lang
If OpenLibrary(0, "kernel32.dll")
	*Lang = GetFunction(0, "GetUserDefaultUILanguage")
	If *Lang
    UserIntLang = CallFunctionFast(*Lang)
	EndIf
	CloseLibrary(0)
EndIf

#CountStrLang = 10
Global Dim Lng.s(#CountStrLang)
Lng(1) = "BBcode to clipboard"
Lng(2) = "Number of loops"
Lng(3) = "Spectrum Range"
Lng(4) = "Tone Shift"
Lng(5) = "Bold"
Lng(6) = "Italic"
Lng(7) = "Back"
Lng(8) = "Correction"
Lng(9) = "Happy Birthday!!!"
Lng(10) = "Done"

If UserIntLang = 1049 ; ru
	Lng(1) = "BBcode в буфер обмена"
	Lng(2) = "Количество циклов"
	Lng(3) = "Диапазон спектра"
	Lng(4) = "Сдвиг тона"
	Lng(5) = "Жирный"
	Lng(6) = "Курсив"
	Lng(7) = "Обратно"
	Lng(8) = "Коррекция"
	Lng(9) = "Поздравляю с днём рождения!!!"
	Lng(10) = "Готово"
EndIf

;- # Constants
#Window = 0

;- ● Enumeration
Enumeration
	#txt1
	#cbx
	#btn1
	#tbg1
	#tbg2
	#tbg3
	#EditorRTF
	#bold
	#italic
	#Reverse
	#correction
	#txtLoop
	#txtNumLoop
	#txtRange
	#txtNumRange
	#txtShift
	#txtNumShift
EndEnumeration

;- ● Global
Global tmp
Global loops0 = 1, Range0 = 360, Shift0
Global hTrackBar1, hTrackBar2, hTrackBar3
Global RTFtext$, text$, RTFColorTable$, Len1, Len2
Global Bold$, italic$, Font$, correction, Reverse
Global RTFHeaderPart1$ = "{\rtf1\ansi\ansicpg1252\deff0\deflang1033{\fonttbl{\f0\fnil\fcharset204 Arial;}}{\colortbl;"
Global RTFHeaderPart2$ = "}{\*\generator Riched20 10.0.16299}\viewkind4\uc1\pard\f0\fs"
Global Dim arr_rgb(2)
Global Dim arr_hsb(2)
arr_hsb(1) = 100
arr_hsb(2) = 100


Define CharFormat.CHARFORMAT


;- ● Declare
Declare hsb_to_rgb()
Declare ToBBcode()
Declare SizeHandler()
Declare Start()
Declare WindowCallback(WindowId, Message, wParam, lParam)
Declare SetTextRTF()

;-┌──GUI──┐
If OpenWindow(#Window, 0, 0, 560, 315, "ColorText",
              #PB_Window_SystemMenu | #PB_Window_ScreenCentered | #PB_Window_MaximizeGadget | #PB_Window_MinimizeGadget | #PB_Window_SizeGadget)
	WindowBounds(#Window, 560, 200, #PB_Ignore, #PB_Ignore)
; 	TextGadget(#txt1, 10, 12, 60, 20, "Образцы:")
; 	ComboBoxGadget(#cbx, 70, 10, 110, 25)
	ButtonGadget(#btn1, 200, 10, 240, 25,  Lng(1))
	hTrackBar1 = TrackBarGadget(#tbg1, 185, 40, 270, 30, 1, 10)
	hTrackBar2 = TrackBarGadget(#tbg2, 185, 70, 270, 30, 0, 360)
	SetGadgetState(#tbg2, Range0)
	hTrackBar3 = TrackBarGadget(#tbg3, 185, 100, 270, 30, 0, 360)
	EditorGadget(#EditorRTF , 10, 145, 540, 160)
	SendMessage_(GadgetID(#EditorRTF), #EM_SETTEXTMODE, #TM_RICHTEXT, 0)
	
	TextGadget(#txtLoop, 10, 45, 145, 30, Lng(2))
	TextGadget(#txtNumLoop, 155, 45, 30, 30, "1")
	TextGadget(#txtRange, 10, 75, 145, 30, Lng(3))
	TextGadget(#txtNumRange, 155, 75, 30, 30, "360")
	TextGadget(#txtShift, 10, 105, 145, 30, Lng(4))
	TextGadget(#txtNumShift, 155, 105, 30, 30, "0")
	
	
	CheckBoxGadget(#bold, 460, 45, 95, 20, Lng(5))
	CheckBoxGadget(#italic, 460, 65, 95, 20, Lng(6))
	CheckBoxGadget(#Reverse, 460, 85, 95, 20, Lng(7))
	CheckBoxGadget(#correction, 460, 105, 95, 20, Lng(8))
	
	SetGadgetState(#bold, #PB_Checkbox_Checked)
	SetGadgetState(#italic, #PB_Checkbox_Checked)
	SetGadgetState(#correction, #PB_Checkbox_Checked)
	
	
	text$ = Lng(9)
	Len1 = Len(text$)
	Len2 = Len(ReplaceString(text$, " ", ""))
	; 	text$ = "Happy Birthday!!!"
	SetTextRTF()

	SetWindowCallback(@WindowCallback())
	BindEvent(#PB_Event_SizeWindow, @SizeHandler())
	

;-┌──Loop──┐
	Repeat
    Select WaitWindowEvent()
;- ├ Gadget
    	Case #PB_Event_Gadget
        Select EventGadget()
        	Case #btn1
;             text$ = GetGadgetText(#EditorRTF)
            ToBBcode()
        	Case #Reverse
            Reverse = GetGadgetState(#Reverse) & #PB_Checkbox_Checked
            Start()
        	Case #correction
            correction = GetGadgetState(#correction) & #PB_Checkbox_Checked
            Start()
        	Case #bold
            If GetGadgetState(#bold) & #PB_Checkbox_Checked
            	Bold$ = "\b"
            Else
            	Bold$ = ""
            EndIf
            SetGadgetText(#EditorRTF, RTFHeaderPart1$ + RTFColorTable$ + RTFHeaderPart2$ + Font$ + Bold$ + italic$ + RTFtext$ + "}")

        	Case #italic
            If GetGadgetState(#italic) & #PB_Checkbox_Checked
            	italic$ = "\i"
            Else
            	italic$ = ""
            EndIf
            SetGadgetText(#EditorRTF, RTFHeaderPart1$ + RTFColorTable$ + RTFHeaderPart2$ + Font$ + Bold$ + italic$ + RTFtext$ + "}")
            
;             Debug 1
        	Case #EditorRTF
            Select EventType()
            	Case #PB_EventType_Change
                SendMessage_(GadgetID(#EditorRTF), #EM_GETSEL, @tmp, 0)
                text$ = GetGadgetText(#EditorRTF)
                Len1 = Len(text$)
                Len2 = Len(ReplaceString(text$, " ", ""))
                SetTextRTF()
                SendMessage_(GadgetID(#EditorRTF), #EM_SETSEL, tmp, tmp)
            EndSelect
        EndSelect
    	Case #PB_Event_CloseWindow
        CloseWindow(#Window)
        End
    EndSelect
	ForEver
;-└──Loop──┘
EndIf


Procedure WindowCallback(WindowId, Message, wParam, lParam)
	Protected Result = #PB_ProcessPureBasicEvents, nScrollCode, value

	Select Message
    Case #WM_HSCROLL
    	;             Это (LoWord и HiWord) должно быть в Protected процедуры а не под #WM_HSCROLL, если используется другие WM_Сообщения
    	nScrollCode = wParam & $FFFF ; LoWord
    	value = wParam >> 16   ; HiWord

    	Select nScrollCode
        Case #SB_THUMBTRACK, #SB_THUMBPOSITION;, #SB_PAGELEFT, #SB_PAGERIGHT, #SB_LINELEFT, #SB_LINERIGHT
        	Select lParam
            Case hTrackBar1
            	loops0 = value
            	Start()
            	SetGadgetText(#txtNumLoop, Str(value))
            Case hTrackBar2
            	Range0 = value
            	Start()
            	SetGadgetText(#txtNumRange, Str(value))
            Case hTrackBar3
            	Shift0 = value
            	Start()
            	SetGadgetText(#txtNumShift, Str(value))
        	EndSelect
    	EndSelect

	EndSelect
	ProcedureReturn Result
EndProcedure

Procedure ToBBcode()
	Protected *c.Character = @text$
	Protected Brightness = 100, *m, *p
	Protected delta, tmp$
	If Len2 < 2
    ProcedureReturn
	EndIf
	delta = Range0 * loops0 / (Len2 - 1)
	
	If Reverse
    arr_hsb(0) = 359 - Shift0
	Else
    arr_hsb(0) = Shift0
	EndIf
	correction = GetGadgetState(#correction) & #PB_Checkbox_Checked

	*m = AllocateMemory(Len1 * 48 + 2)
	If Not *m
    ProcedureReturn 0
	EndIf
	*p = *m

	While *c\c
    If correction
    	Select arr_hsb(0)
        Case 39 To 43
        	Brightness = 96
        Case 44 To 48
        	Brightness = 93
        Case 49 To 53
        	Brightness = 86
        Case 54 To 180
        	Brightness = 82
        Case 181 To 190
        	Brightness = 86
        Case 191 To 200
        	Brightness = 90
        Default
        	Brightness = 100
    	EndSelect
    EndIf
    arr_hsb(2) = Brightness
    hsb_to_rgb()
    Select *c\c
    	Case ' '
        CopyMemoryString(" ", @*p)
    	Default
        CopyMemoryString("[color=#", @*p)
        CopyMemoryString(LSet(Hex(arr_rgb(0)), 2, "0"), @*p)
        CopyMemoryString(LSet(Hex(arr_rgb(1)), 2, "0"), @*p)
        CopyMemoryString(LSet(Hex(arr_rgb(2)), 2, "0"), @*p)
        CopyMemoryString("]", @*p)
        CopyMemoryString(Chr(*c\c), @*p)
        CopyMemoryString("[/color]", @*p)
    EndSelect
    *c + 2
    If Reverse
    	arr_hsb(0) - delta
    	If arr_hsb(0) < 0
        arr_hsb(0) + 360
    	EndIf
    Else
    	arr_hsb(0) + delta
    EndIf
	Wend
	tmp$ = PeekS(*m)
; 	Debug MemorySize(*m) ; выделено
; 	Debug StringByteLength(tmp$) ; требуется
	FreeMemory(*m)
	
	If Asc(italic$)
    tmp$ = "[i]" + tmp$ + "[/i]"
	EndIf
	If Asc(Bold$)
    tmp$ = "[b]" + tmp$ + "[/b]"
	EndIf
	
	SetClipboardText(tmp$)
	MessageRequester("BBcode", Lng(10))
EndProcedure

Procedure Start()
	Protected i, Brightness = 100
	Protected delta
	If Len2 < 2
    ProcedureReturn
	EndIf
	If Reverse
    arr_hsb(0) = 359 - Shift0
	Else
    arr_hsb(0) = Shift0
	EndIf
	RTFColorTable$ = ""
	delta = Range0 * loops0 / (Len2 - 1)
	correction = GetGadgetState(#correction) & #PB_Checkbox_Checked
	
	For i = 1 To Len2
    If correction
    	Select arr_hsb(0)
        Case 39 To 43
        	Brightness = 96
        Case 44 To 48
        	Brightness = 93
        Case 49 To 53
        	Brightness = 86
        Case 54 To 180
        	Brightness = 82
        Case 181 To 190
        	Brightness = 86
        Case 191 To 200
        	Brightness = 90
        Default
        	Brightness = 100
    	EndSelect
    EndIf
    arr_hsb(2) = Brightness
    hsb_to_rgb()
    ;     наполняем таблицу цветами
;     Debug arr_hsb(0)
    RTFColorTable$ + "\red" + arr_rgb(0) + "\green" + arr_rgb(1) + "\blue" + arr_rgb(2) + ";"
    
    If Reverse
    	arr_hsb(0) - delta
    	If arr_hsb(0) < 0
        arr_hsb(0) + 360
    	EndIf
    Else
    	arr_hsb(0) + delta
    EndIf
	Next

	SetGadgetText(#EditorRTF, RTFHeaderPart1$ + RTFColorTable$ + RTFHeaderPart2$ + Font$ + Bold$ + italic$ + RTFtext$ + "}")
EndProcedure


Procedure SetTextRTF()
	Protected *c.Character = @text$
	Protected i, Brightness = 100, *m, *p
	Protected delta
	If Len2 < 2
    ProcedureReturn
	EndIf
	delta = 360 / (Len2 - 1)
	
	If Reverse
    arr_hsb(0) = 359
	Else
    arr_hsb(0) = 0
	EndIf

	*m = AllocateMemory(Len1 * 16 + 2)
	If Not *m
    ProcedureReturn
	EndIf
	*p = *m
	RTFColorTable$ = ""
	correction = GetGadgetState(#correction) & #PB_Checkbox_Checked

	While *c\c
    Select *c\c
    	Case ' '
        CopyMemoryString("\", @*p)
        CopyMemoryString(" ", @*p)
        *c + 2
        Continue
    	Case '\', '}', '{'
        i + 1
        CopyMemoryString("\cf", @*p)
        CopyMemoryString(Str(i), @*p)
        CopyMemoryString("\", @*p)
        CopyMemoryString(Chr(*c\c), @*p)
    	Default
        i + 1
        CopyMemoryString("\cf", @*p)
        CopyMemoryString(Str(i), @*p)
        CopyMemoryString(Chr(*c\c), @*p)
    EndSelect
    *c + 2
;     arr_hsb(0) + delta
    If correction
    	Select arr_hsb(0)
        Case 39 To 43
        	Brightness = 96
        Case 44 To 48
        	Brightness = 93
        Case 49 To 53
        	Brightness = 86
        Case 54 To 180
        	Brightness = 82
        Case 181 To 190
        	Brightness = 86
        Case 191 To 200
        	Brightness = 90
        Default
        	Brightness = 100
    	EndSelect
    EndIf
    arr_hsb(2) = Brightness
    hsb_to_rgb()
    ;     наполняем таблицу цветами
;     Debug arr_hsb(0)
    RTFColorTable$ + "\red" + arr_rgb(0) + "\green" + arr_rgb(1) + "\blue" + arr_rgb(2) + ";"
    If Reverse
    	arr_hsb(0) - delta
    	If arr_hsb(0) < 0
        arr_hsb(0) + 360
    	EndIf
    Else
    	arr_hsb(0) + delta
    EndIf
	Wend
	RTFtext$ = PeekS(*m) ; уже добавлены экранирование
; 	Debug MemorySize(*m) ; выделено
; 	Debug StringByteLength(RTFtext$) ; требуется
	FreeMemory(*m)

; If iniFontSize
; 	Font = iniFontSize * 2
; Else
; 	Font = 35
; EndIf
	Font$ = "35"
	Bold$ = "\b"
	italic$ = "\i"
	
	SetGadgetText(#EditorRTF, RTFHeaderPart1$ + RTFColorTable$ + RTFHeaderPart2$ + Font$ + Bold$ + italic$ + RTFtext$ + "}")

EndProcedure

Procedure SizeHandler()
	ResizeGadget(#EditorRTF, #PB_Ignore, #PB_Ignore, WindowWidth(0) - 20, WindowHeight(0) - 155)
EndProcedure

; Procedure hsb_to_rgb(arr_hsb)
Procedure hsb_to_rgb()
	Protected sector
	Protected.f ff, pp, qq, tt
	Protected.f Dim af_rgb(2) ; создаём массивы в которых числа будут в диапазоне 0-1
	Protected.f Dim af_hsb(2)
	; Protected Dim arr_rgb(2)

	af_hsb(2) = arr_hsb(2) / 100

	If arr_hsb(1) = 0 ; если серый, то одно значение всем
    arr_rgb(0) = Round(af_hsb(2) * 255, #PB_Round_Nearest)
    arr_rgb(1) = arr_rgb(0)
    arr_rgb(2) = arr_rgb(0)
    ; ProcedureReturn arr_rgb
	EndIf

	While arr_hsb(0) >= 360 ; если тон задан большим запредельным числом, то
    arr_hsb(0) - 360
	Wend

	af_hsb(1) = arr_hsb(1) / 100
	af_hsb(0) = arr_hsb(0) / 60
	; sector = Int(arr_hsb(0))
	sector = Round(af_hsb(0), #PB_Round_Down)

	ff = af_hsb(0) - sector
	pp = af_hsb(2) * (1 - af_hsb(1))
	qq = af_hsb(2) * (1 - af_hsb(1) * ff)
	tt = af_hsb(2) * (1 - af_hsb(1) * (1 - ff))

	Select sector
    Case 0
    	af_rgb(0) = af_hsb(2)
    	af_rgb(1) = tt
    	af_rgb(2) = pp
    Case 1
    	af_rgb(0) = qq
    	af_rgb(1) = af_hsb(2)
    	af_rgb(2) = pp
    Case 2
    	af_rgb(0) = pp
    	af_rgb(1) = af_hsb(2)
    	af_rgb(2) = tt
    Case 3
    	af_rgb(0) = pp
    	af_rgb(1) = qq
    	af_rgb(2) = af_hsb(2)
    Case 4
    	af_rgb(0) = tt
    	af_rgb(1) = pp
    	af_rgb(2) = af_hsb(2)
    Default
    	af_rgb(0) = af_hsb(2)
    	af_rgb(1) = pp
    	af_rgb(2) = qq
	EndSelect

	; RGB
	arr_rgb(0) = Round(af_rgb(0) * 255, #PB_Round_Nearest)
	arr_rgb(1) = Round(af_rgb(1) * 255, #PB_Round_Nearest)
	arr_rgb(2) = Round(af_rgb(2) * 255, #PB_Round_Nearest)

	; BGR
	; arr_rgb(2)=Round(af_rgb(0)*255, #PB_Round_Nearest)
	; arr_rgb(1)=Round(af_rgb(1)*255, #PB_Round_Nearest)
	; arr_rgb(0)=Round(af_rgb(2)*255, #PB_Round_Nearest)

	; ProcedureReturn arr_rgb
EndProcedure

Отредактировано AZJIO (22.05.2025 22:27:33)

0

2

  • Автор: egons
  • Активный участник
  • egons
  • Зарегистрирован: 26.07.2021
  • Приглашений: 0
  • Сообщений: 220
  • Уважение: [+1/-0]
  • Позитив: [+0/-2]
  • Возраст: 49 [1975-07-05]
  • Провел на форуме:
    1 день 5 часов
  • Последний визит:
    Вчера 19:13:27

Осталось добавить поняшей, и как раз пойдет на форум(:

0

3

  • Автор: AZJIO
  • Активный участник
  • Зарегистрирован: 07.08.2020
  • Приглашений: 0
  • Сообщений: 1311
  • Уважение: [+20/-0]
  • Позитив: [+15/-0]
  • Провел на форуме:
    27 дней 3 часа
  • Последний визит:
    Вчера 18:15:53

На оф.форуме посоветовали добавить выделенную память, исправил. И чуть ошибся, скомпилировал на 6.20, вернул 6.04, размер файла уменьшился в 3 раза.

0

Страница: 1

Вы здесь » PureBasic - форум » PureBasic для Windows » ColorText