Вставка надписи в картинку. Работает, но ...

[v000v]

Всем, здрасти!

Проблема:

При ресайзе текста (Font+), текст отображается не плавными кривыми, а отдельными кубиками.
Если долго нажимать Font+ (до значения 242), все становится красиво.
После этого, уменьшение размера текста не влияет на его вид. Красота вечна?!

Кто-нибудь может сие пояснить?



Спасибо за любые коментарии к программе.

[Igor_123]

Поставь другой шрифт.
И текст вставляеться, но видно только кусочек одной буквы. При увиличении размера шрифта и этот кусочек пропадает

Удачи

[v000v]

Igor_123

Поставь другой шрифт.

Да, например Arial не страдает от подобного эффекта.

И текст вставляеться, но видно только кусочек одной буквы

Не совсем понял о чем речь... У меня все нормально работает. Перед нажатием на "Insert text", задаем предположительный размер надписи. В хэлпе написано...[/b]

[kirrun]

А просто шрифты разные бывают (точно названия не скажу). Вот от этого и эффект такой.

[Igor_123]

В хэлпе написано...

Обижаешь!!!
Не барское это дело хелп читать
Чесно говоря, я думал кнопка не задействована и для дальнейшего расширения функциональности сделанна.
А шрифт я поставил - Bookman Old Style.
При увеличении в 200, нормально показывает.

А я после запуска кликаю по рисунку, кликаю второй раз и ошибка.
После этого кликаю один раз и нажимаю "Вставить текст" ну и маленький прямоугольничек появляеться, в который нужно передать фокус для ввода текста. Ну и естественно получаеться результат:

И текст вставляеться, но видно только кусочек одной буквы

[Igor_123]

Да вот здесь хотел показать.
Ты пишешь так:

Код: Выделить всё

Private Sub Command1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim i As Integer
    If fflag = 0 Then GoTo lolo Else GoTo eoeo
lolo:
        ff = 10
        For i = 0 To Text1.UBound
            Text1(i).FontSize = ff
        Next i
        ff = ff + 2
         fflag = 1
          Exit Sub
eoeo:
            For i = 0 To Text1.UBound
                Text1(i).FontSize = ff
                 Command1.Caption = ff
            Next i
                ff = ff + 2
End Sub

я бы написал так:

Код: Выделить всё

Private Sub Command1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim i As Long
If fflag = 0 Then
    ff = 10
    For i = 0 To Text1.UBound
        Text1(i).FontSize = ff
    Next i
    ff = ff + 2
    fflag = 1
Else
    For i = 0 To Text1.UBound
        Text1(i).FontSize = ff
        Command1.Caption = ff
    Next i
    ff = ff + 2
End If
End Sub

Ты уходишь от GOTO и код становиться более читаемый. Блок If Else End If отделяет логические действия, и проще в понимании. Но я не настаиваю. Ты автор тебе и валенки носить
Удачи!

[kirrun]

Чесно говоря, я думал кнопка не задействована и для дальнейшего расширения функциональности сделанна.

Думать ВРЕДНО ©kirrun. Надо сомтреть сорс...

[Igor_123]

Да сорц больно запущеный! Тут и подумать не вредно

[Konst_One]

очень сумбурно, ничего не понял, но наверное нужно сделать, чтобы текстбокс появлялся более разумного размера или дать возможность его растягивать

[v000v]

Igor_123

Да вот здесь хотел показать.

Если метки имеют смысловую нагрузку, мой вариант читабельнее.

Мне так ка-а-атса! (А.Райкин)

[v000v]

Konst_One

нажми НELP, пожалуйста!

p.s. зачем я его туда добавлял?

[Igor_123]

Код: Выделить всё

Private Sub picResizer_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
' If Index <> 0 Then GoTo fofo Else GoTo dodo
'fofo:
'    'resize
'    If bDrag Then
'        cx_r = cx_r + X - dx_r: cy_r = cy_r + Y - dy_r
'        If cx_r < 0 Or cy_r < 0 Then Exit Sub
'
'        Text1(indText).Width = cx_r: Text1(indText).Height = cy_r
'SetResizeRecPos
'
'    End If
'Exit Sub
'dodo:
''move
'    If bDrag Then
'        cx_m = cx_m + X - dx_m: cy_m = cy_m + Y - dy_m
'        Text1(indText).Move cx_m, cy_m
'    End If
'SetResizeRecPos

If Index <> 0 Then 'resize
    If bDrag Then
        cx_r = cx_r + X - dx_r
        cy_r = cy_r + Y - dy_r
        'Если вышли за пределы, здесь больше делать нечего
        If cx_r < 0 Or cy_r < 0 Then Exit Sub
       
        Text1(indText).Width = cx_r
        Text1(indText).Height = cy_r
        SetResizeRecPos
    End If
Else 'move
    If bDrag Then
        cx_m = cx_m + X - dx_m
        cy_m = cy_m + Y - dy_m
        Text1(indText).Move cx_m, cy_m
    End If
    SetResizeRecPos
End If
End Sub

Вот переделанная процедура. От себя добавил только коментарий на русском. Твой вариант закоментирован.

Мне так ка-а-атса! (с)(А.Райкин)

Дело привычки.

p.s. зачем я его туда добавлял?

Как зачем? Что-бы отвечать на вопросы пользователей.

[Konst_One]

вот немного добавил с ресайзом без всякого клика

[kirrun]

Да сорц больно запущеный! Тут и подумать не вредно

но тем не менее, событие клик по кнопке там можно увидет => оно не для красоты.

[v000v]

Konst_One

вот немного добавил с ресайзом без всякого клика

Хорошо!
Но для Move_Text двойной клик прийдется оставить. Вообще старался следовать привычному шаблону. Плюс в том, что когда на картинке много надписей, "волшебные" превращения курсора утомляют.

p.s. Однако вопрос об отображении шрифта MS Sans Serif остается открытым.

Не в буквах ли "MS" тут дело?

[Konst_One]

это не TTF и не OpenType, наверное в этом и причина

[tyomitch]

p.s. Однако вопрос об отображении шрифта MS Sans Serif остается открытым.

Не в буквах ли "MS" тут дело?

А ты никогда не обращал внимания, что в диалогах выбора шрифтов рядом с некоторыми стоят значки "TT" и "O"? А рядом с MS Sans Serif ничего не стоит. Оттуда и "кубики".

[v000v]

tyomitch

Оттуда и "кубики".

...однако, если увеличить его до размера в 242, а потом сколько угодно уменьшать, "кубиков" нет, буквы остаются "обтекаемыми"

[tyomitch]

А ты замени строку "Command1.Caption = ff" на "Command1.Caption = ff & Text1(i).FontName", и сразу же поймёшь.

[v000v]

tyomitch

...понял.

И считаю, что это уже ну вааще ни в какие рамки....

Ладно, всем спасибо!
Удачи!