Использую в программе спец. шрифт, который не устанавливается на комп. Шрифт хранится в ресурсе и выдергивается и используется такими функциями:
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
На каждом третьем компе (примерно) шрифт не устанавливается ни с первого, ни со второго запуска программы. Вопрос: че за фигня?
Андрей, хехе даже я не такой фанатик портабельности Но вообще хороший подход. Объясни хоть, что не работает на каждом третьем компе? не распаковывается или не выбирается шрифт? плюс я не пойму этот код:
If AddFontResourceEx("C:\Windows\temp\Шрифт.ttf", FR_PRIVATE, 0) > 0 Then
Если смогли добавить шрифт, то выбираем его (хотя выбрать его проще было бы с помощью .FontName). Если не смогли добавить, то распаковываем, выбираем и сразу удаляем файл.
Так вот. Если шрифт сразу удалять, то каким фигом это вообще работать должно? не понимаю.
Если смогли добавить шрифт, то выбираем его (хотя выбрать его проще было бы с помощью .FontName). Если не смогли добавить, то распаковываем, выбираем и сразу удаляем файл.
Так вот. Если шрифт сразу удалять, то каким фигом это вообще работать должно? не понимаю.
Функция CreateFontIndirect создает логический шрифт на одну сессию (на время работы моей программы). Позже я его, конечно, выбираю, а сам файл уже не нужен.
Объясни хоть, что не работает на каждом третьем компе? не распаковывается или не выбирается шрифт?
На Висте нормально работает, на XP - криво. Распаковываеться (куда он денеться), а вот или лог. шрифт не создает, или.. сам не знаю
Но это же неосмысленный кот) В первой строке мы получаем хендл созданного шрифта и выбираем его (ну допустим он при закрытии сам удалится, не сохраняем хендл. Хотя я бы сохранил)
А во второй строке создается шрифт, и тут же удаляется. зочем? Попробуй убрать обе строки DeleteObject.. мб поможет
А во второй строке создается шрифт, и тут же удаляется. зачем? Попробуй убрать обе строки DeleteObject.. мб поможет
DeleteObject только удаляет хендл из памяти и освобождает связанные с ним pесуpсы системы, но объекту
Picture мы указали на шрифт, и ни куда он не денется.
Тем более, что код рабочий почти
Вроде дошло. Код работает на тех компах, где не выполняеться строка:
Kill "C:\Windows\temp\NoLeSymbols.ttf"
Уже не помню, зачем ее втиснул: или боялся, что шрифт стырят или о юзарах заботу проявил ???
в первой строке загружаешь шрифт, получаешь его хендл. Который остается до выхода из программы.
Во второй строке снова загружаешь шрифт, получаешь новый хендл и сразу удаляешь его. Но первый-то хендл тут не удаляется.
Верно, Winand, во второй строке создаем новый хендл, чтоб высвободить свой, и очистить память.
Вроде, написано по этим функциям, что важно:
1. обязательно очистить память,
2. не удалять (DeleteObject) объект, полученный по SelectObject.
Решил проверить - удалил вторую строку => шрифт не загрузился => не загрузился и после восстановления 2-ой строки => перезагрузка компа => восстановление 2-ой строки => запуск программы => шрифт загрузился => вывод: 2-я строка нужна!
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, за терпение. Вроде, теперь и до меня дошло
Привет.Я обрашаюсь к вам с прозбой о помощи.У меня проблема такая .Надо показат свой фонт друзям не устанавливая этот фонт в их комп.Примерно такой простой код.Сам
Фонт в ресурсе.Спасибо за ранее