Visual Basic, .NET, ASP, VBScript
Новости | Примеры | Библиотека кодов | НеЧаВо | VBA | Справочник по VB | Справочник по WinAPI | ActiveX контролы | Статьи по VB | Мастерская разработчика | Форум VBNet | Яndex bar! | Голосование | Полезные программы | Магазин VBNet | Рассылка | Конкурсы | Юмор | Чат | Реклама на VBNet | Автора! | Ссылки | Бета-тестирование | Послать пример на сайт
 

   
   
     

Форум - Общий форум

Страница: 1 |

 

  Вопрос: Шрифт в программе Добавлено: 20.12.09 00:34  

Автор вопроса:  Андрей
Использую в программе спец. шрифт, который не устанавливается на комп. Шрифт хранится в ресурсе и выдергивается и используется такими функциями:


Public Declare Function AddFontResourceEx Lib "gdi32" Alias "AddFontResourceExA" (ByVal pFilename As String, ByVal fl As Long, ByRef pdv) As Long
Public Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (ByVal pFilename As String) As Long
Public Declare Function SelectObject& Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long)
Public Declare Function DeleteObject& Lib "gdi32" (ByVal hObject As Long)


Public Function PictureFontOpen(ByVal Picture As PictureBox, ByVal Fon As PictureBox, ByVal Scroll As HScrollBar)
If AddFontResourceEx("C:\Windows\temp\Шрифт.ttf", FR_PRIVATE, 0) > 0 Then
Call SelectObject(Picture.hDC, CreateFontIndirect("C:\Windows\temp\Шрифт.ttf"))
Call DeleteObject(CreateFontIndirect("C:\Windows\temp\Шрифт.ttf"))
Else
SaveRes 101, "C:\Windows\temp\Шрифт.ttf", "FILE"
Call SelectObject(Picture.hDC, CreateFontIndirect("C:\Windows\temp\Шрифт.ttf"))
Call DeleteObject(CreateFontIndirect("C:\Windows\temp\Шрифт.ttf"))
Kill "C:\Windows\temp\Шрифт.ttf"
End If
End Function
Public Function SaveRes(ByRef Id As Long, ByRef File As String, Optional cRes As String = "FILE") As Boolean
Dim b() As Byte
Close
b = VB.LoadResData(Id, "Custom")
Open File For Binary As #1
Put #1, , b
Close
Erase b
End Function


На каждом третьем компе (примерно) шрифт не устанавливается ни с первого, ни со второго запуска программы. Вопрос: че за фигня?

Ответить

  Ответы Всего ответов: 13  

Номер ответа: 1
Автор ответа:
 Winand



Вопросов: 87
Ответов: 2795
  Web-сайт: winandfx.narod.ru
 Профиль | | #1 		Добавлено: 20.12.09 01:13
Какие-то страсти. Зачем вообще в ресурсы совать? просто в папку с программой запихнуть...
Я как-то так делаю
  1. Private Sub setFonts()
  2.     AddFontResource AppPath & "data\font.ttf"
  3.     tsearch.FontName = "LC Chalk"
  4.     taddr.FontName = "LC Chalk"
  5.     pnl_title.FontName = "LC Chalk"
  6.     pnl_addr.FontName = "LC Chalk"
  7. End Sub

Ответить

Номер ответа: 2
Автор ответа:
 Андрей



Вопросов: 8
Ответов: 42
  Профиль | | #2 Добавлено: 20.12.09 08:50
Для небольшой программки иметь папку – роскошь:)

Ответить

Номер ответа: 3
Автор ответа:
 Winand



Вопросов: 87
Ответов: 2795
  Web-сайт: winandfx.narod.ru
 Профиль | | #3 		Добавлено: 20.12.09 14:03
Андрей, хехе даже я не такой фанатик портабельности=) Но вообще хороший подход. Объясни хоть, что не работает на каждом третьем компе? не распаковывается или не выбирается шрифт? плюс я не пойму этот код:
  1. If AddFontResourceEx("C:\Windows\temp\Шрифт.ttf", FR_PRIVATE, 0) > 0 Then
  2. Call SelectObject(Picture.hDC, CreateFontIndirect("C:\Windows\temp\Шрифт.ttf"))
  3. Call DeleteObject(CreateFontIndirect("C:\Windows\temp\Шрифт.ttf"))
  4. Else
  5. SaveRes 101, "C:\Windows\temp\Шрифт.ttf", "FILE"
  6. Call SelectObject(Picture.hDC, CreateFontIndirect("C:\Windows\temp\Шрифт.ttf"))
  7. Call DeleteObject(CreateFontIndirect("C:\Windows\temp\Шрифт.ttf"))
  8. Kill "C:\Windows\temp\Шрифт.ttf"
  9. End If
Если смогли добавить шрифт, то выбираем его (хотя выбрать его проще было бы с помощью .FontName). Если не смогли добавить, то распаковываем, выбираем и сразу удаляем файл.
Так вот. Если шрифт сразу удалять, то каким фигом это вообще работать должно? не понимаю.

Ответить

Номер ответа: 4
Автор ответа:
 VβÐUηìt



Вопросов: 246
Ответов: 3333
  Web-сайт: смекаешь.рф
 Профиль | | #4 		Добавлено: 20.12.09 14:19
Для небольшой программки иметь папку – роскошь

Ппц. Сунул в SFX архив и все. Хоть 500 файлов получишь.

Ответить

Номер ответа: 5
Автор ответа:
 Андрей



Вопросов: 8
Ответов: 42
  Профиль | | #5 Добавлено: 20.12.09 16:39
Если смогли добавить шрифт, то выбираем его (хотя выбрать его проще было бы с помощью .FontName). Если не смогли добавить, то распаковываем, выбираем и сразу удаляем файл.
Так вот. Если шрифт сразу удалять, то каким фигом это вообще работать должно? не понимаю.


Функция CreateFontIndirect создает логический шрифт на одну сессию (на время работы моей программы). Позже я его, конечно, выбираю, а сам файл уже не нужен.

Объясни хоть, что не работает на каждом третьем компе? не распаковывается или не выбирается шрифт?


На Висте нормально работает, на XP - криво. Распаковываеться (куда он денеться), а вот или лог. шрифт не создает, или.. сам не знаю:(

Ответить

Номер ответа: 6
Автор ответа:
 Winand



Вопросов: 87
Ответов: 2795
  Web-сайт: winandfx.narod.ru
 Профиль | | #6 		Добавлено: 20.12.09 21:29
Андрей
  1. Call SelectObject(Picture.hDC, CreateFontIndirect("C:\Windows\temp\Шрифт.ttf"))
  2. Call DeleteObject(CreateFontIndirect("C:\Windows\temp\Шрифт.ttf"))

Но это же неосмысленный кот) В первой строке мы получаем хендл созданного шрифта и выбираем его (ну допустим он при закрытии сам удалится, не сохраняем хендл. Хотя я бы сохранил)
А во второй строке создается шрифт, и тут же удаляется. зочем? Попробуй убрать обе строки DeleteObject.. мб поможет

Ответить

Номер ответа: 7
Автор ответа:
 Андрей



Вопросов: 8
Ответов: 42
  Профиль | | #7 Добавлено: 21.12.09 01:03
Winand

А во второй строке создается шрифт, и тут же удаляется. зачем? Попробуй убрать обе строки DeleteObject.. мб поможет


DeleteObject только удаляет хендл из памяти и освобождает связанные с ним pесуpсы системы, но объекту
Picture мы указали на шрифт, и ни куда он не денется.
Тем более, что код рабочий:) почти:)

Вроде дошло. Код работает на тех компах, где не выполняеться строка:

Kill "C:\Windows\temp\NoLeSymbols.ttf"


Уже не помню, зачем ее втиснул: или боялся, что шрифт стырят:) или о юзарах заботу проявил:) ???

Спасибо всем!

Ответить

Номер ответа: 8
Автор ответа:
 Winand



Вопросов: 87
Ответов: 2795
  Web-сайт: winandfx.narod.ru
 Профиль | | #8 		Добавлено: 21.12.09 02:04
Андрей, даже если это не связано с проблемой:
  1. Call SelectObject(Picture.hDC, CreateFontIndirect("C:\Windows\temp\Шрифт.ttf"))
  2. Call DeleteObject(CreateFontIndirect("C:\Windows\temp\Шрифт.ttf"))

в первой строке загружаешь шрифт, получаешь его хендл. Который остается до выхода из программы.
Во второй строке снова загружаешь шрифт, получаешь новый хендл и сразу удаляешь его. Но первый-то хендл тут не удаляется.

Ответить

Номер ответа: 9
Автор ответа:
 Андрей



Вопросов: 8
Ответов: 42
  Профиль | | #9 Добавлено: 21.12.09 03:46
Верно, Winand, во второй строке создаем новый хендл, чтоб высвободить свой, и очистить память.
Вроде, написано по этим функциям, что важно:
1. обязательно очистить память,
2. не удалять (DeleteObject) объект, полученный по SelectObject.

Решил проверить - удалил вторую строку => шрифт не загрузился => не загрузился и после восстановления 2-ой строки => перезагрузка компа => восстановление 2-ой строки => запуск программы => шрифт загрузился => вывод: 2-я строка нужна! :)

Ответить

Номер ответа: 10
Автор ответа:
 Winand



Вопросов: 87
Ответов: 2795
  Web-сайт: winandfx.narod.ru
 Профиль | | #10 		Добавлено: 21.12.09 19:22
Нууу я не знаю. Пример с MSDN
  1. hFontNew = CreateFontIndirect(&lf);
  2. hFontOld = (HFONT) SelectObject(hdc, hFontNew);
  3. DrawText(hdc, TEXT("This is a ClearType font w/ 1000 font smoothing."), -1, &rc, DT_CALCRECT | DT_LEFT | DT_TOP);
  4. DrawText(hdc, TEXT("This is a ClearType font w/ 1000 font smoothing."), -1, &rc, DT_LEFT | DT_TOP);
  5. SelectObject(hdc, hFontOld);
  6. DeleteObject(hFontNew);

запоминаем старый шрифт, выбираем новый. Когда новый стал не нужен, выбираем старый, новый удаляем.

Ответить

Номер ответа: 11
Автор ответа:
 Андрей



Вопросов: 8
Ответов: 42
  Профиль | | #11 Добавлено: 21.12.09 21:34
Да уж, натупил я конкретно :(

Переписал код. В форме:
Dim FontNew As Long
FontNew = CeateFontIndirect "C:\Windows\temp\Шрифт.ttf";): Call SelectObject(Picture1.hDC, FontNew)
Picture1.Font = "Шрифт"
Picture1.Print "Текст"
Call DeleteObject(FontNew)


В модуле:
Public Declare Function AddFontResourceEx Lib "gdi32" Alias "AddFontResourceExA" (ByVal pFilename As String, ByVal fl As Long, ByRef pdv) As Long
Public Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (ByVal pFilename As String) As Long
Public Declare Function SelectObject& Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long)
Public Declare Function DeleteObject& Lib "gdi32" (ByVal hObject As Long)

Public Function PictureFontOpen()
If AddFontResourceEx("C:\Windows\temp\Шрифт.ttf", FR_PRIVATE, 0) = 0 Then
SaveRes 101, "C:\Windows\temp\Шрифт.ttf", "FILE"
'ожидание загрузки
a:
If AddFontResourceEx("C:\Windows\temp\Шрифт.ttf", FR_PRIVATE, 0) = 0 Then GoTo a
End If
End Function

Public Function SaveRes(ByRef Id As Long, ByRef File As String, Optional cRes As String = "FILE";) As Boolean
Dim b() As Byte
Close
b = VB.LoadResData(Id, "Custom";)
Open File For Binary As #1
Put #1, , b
Close
Erase b
End Function


Спасибо, Winand, за терпение. Вроде, теперь и до меня дошло :)

Ответить

Номер ответа: 12
Автор ответа:
 Winand



Вопросов: 87
Ответов: 2795
  Web-сайт: winandfx.narod.ru
 Профиль | | #12 		Добавлено: 22.12.09 00:08
=) Еще пара мыслей
Это вроде бы аналогичные друг другу выражения
  1. Call SelectObject(Picture1.hDC, FontNew)
  2. Picture1.Font = "Шрифт"

А это наверное надо в Form_Unload запихать
  1. Call DeleteObject(FontNew)

Ответить

Номер ответа: 13
Автор ответа:
 Эдик



Вопросов: 19
Ответов: 23
  Профиль | | #13 Добавлено: 15.01.10 07:50
Привет.Я обрашаюсь к вам с прозбой о помощи.У меня проблема такая .Надо показат свой фонт друзям не устанавливая этот фонт в их комп.Примерно такой простой код.Сам
Фонт в ресурсе.Спасибо за ранее

Private Sub Command1_Click()
  
Text1.Font = LoadResData(101, "CUSTOM";)
Label1.Font = LoadResData(101, "CUSTOM";)
Label1.Caption = Text1.FontName
Label2.Caption = Label1.FontName
Text1.SetFocus

End Sub

Ответить

Страница: 1 |

Поиск по форуму



© Copyright 2002-2011 VBNet.RU | Пишите нам