Установить Шрифт И Создать Ярлык На Базу (windows Only)

Тема в разделе "Oбщий функционал", создана пользователем savl, 25 янв 2013.

  1. savl

    savl Lotus team
    Lotus team

    Регистрация:
    28 окт 2011
    Сообщения:
    2.051
    Симпатии:
    146
    Требуется установить шрифт, которого нет на компьютере, но нет доступа к рабочей станции?
    Ситуация конечно редкая, но если у вас OpenSource-проект и свои шрифты, то почему нет?
    Поскольку я применяю копирование в Fonts напрямую, то есть подозрение, что точно надо иметь права админа на машине.
    Если кто-то знает решение под MacOs и *nix, то прошу добавить, а тему переименуем.
    <div class="sp-wrap"><div class="sp-head-wrap"><div class="sp-head folded clickable">Событие PostOpen Базы, пусть будет шрифт EanG000.ttf</div></div><div class="sp-body"><div class="sp-content">
    Код (LotusScript):
    Sub Postopen(Source As Notesuidatabase)
    On Error goto handler
    Const FuncName = {Sub "Postopen"}
    Dim errStr As string

    If FileExists( Environ$("SYSTEMROOT") & {\Fonts\EanG000.ttf}) Then GoTo endh

    Dim db As NotesDatabase
    Dim sView As NotesView
    Dim sDoc As NotesDocument
    Dim wshell As Variant
    Dim strDesktop As String
    Dim oMyShortCut As Variant

    nLine = Chr(10) & Chr(13)

    Set db = Source.Database
    Set sView = db.GetView({Settings}) ' вьюшка с документом, в котором хранится файл шрифта

    Set sDoc = sView.GetDocumentByKey({EANFONT},True) ' Поиск документа по ключу
    If sDoc Is Nothing Then Error 5005, "Не найдена настройка: EANFONT"

    If ExtractFile(sDoc, {ToFile}, Environ$("SYSTEMROOT") & {\Fonts\} ) Then ' выгрузка файла в папку Fonts

    Set wshell = CreateObject("WScript.Shell")     
    ' ****************************************************************************

    ' Imports The Registry Information For The New Fonts - Add A New Line For Each New Font

    ' Example : WshShell. RegWrite"HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts\%FONT REG KEY%", "%FONT REG KEY ENTRY%", "REG_SZ"

    ' ****************************************************************************

    Call wshell.RegWrite("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts\EanGnivc", "EanG000.ttf", "REG_SZ")

    MsgBox "Установка шрифта завершена. Требуется переоткрыть Lotus Notes."
    Dim ws As New NotesUIWorkspace
    ' Открытие формы CloseClientForm , в PostOpen формы прописано: @Command([FileExit])
    Call ws.Composedocument(db.Server, db.Filepath, {CloseClientForm})
    End If

    GoTo endh
    handler:
    errStr = DESIGN & FuncName & ": " & Err &", в стр " & Erl & nLine & Error$
    msgbox ErrStr,16
    Resume endh
    endh:
    End Sub
    <div class="sp-wrap"><div class="sp-head-wrap"><div class="sp-head folded clickable">Function ExtractFile</div></div><div class="sp-body"><div class="sp-content">
    Код (LotusScript):
    Function ExtractFile(param As NotesDocument, BodyName As String, TargetPath As string) As Boolean
    On Error GoTo handler
    Const FuncName = { Function "ExtractFile" }
    Dim ErrStr As String

    Dim rti As NotesRichTextItem

    If Not param.Hasitem("$File") Then GoTo endh

    Set rti = param.Getfirstitem(BodyName)
    'New NotesRichTextItem(param,BodyName)

    If rti Is Nothing Then GoTo endh

    ForAll x In rti.Embeddedobjects
    If Right(TargetPath,1) = {\} then
    Call x.ExtractFile( TargetPath & x.name)
    Else
    Call x.ExtractFile( TargetPath & {\} & x.name)
    End If
    End ForAll

    ExtractFile = True

    GoTo endh

    handler:
    ErrStr = FuncName & ": " & Err &", в стр " & Erl & nLine & Error$
    Error Err,ErrStr
    endh:
    End Function
    <div class="sp-wrap"><div class="sp-head-wrap"><div class="sp-head folded clickable">Function FileExists</div></div><div class="sp-body"><div class="sp-content">
    Код (LotusScript):
    Function FileExists (strPath As String) As Boolean
    On Error GoTo handler
    Const FuncName = {Function "FileExists" }
    Dim errStr As String

    fileExists = (Dir$ (strPath) <> "" )

    GoTo endh
    handler:
    errStr = FuncName & {стр. } & Erl & nLine & Error$ & nline & strPath        
    Error Err,ErrStr
    endh:
    End Function
    <div class="sp-wrap"><div class="sp-head-wrap"><div class="sp-head folded clickable">Создать ярлык на базу</div></div><div class="sp-body"><div class="sp-content">
    Код (LotusScript):
    Set wshell = CreateObject("WScript.Shell")     
    strDesktop = wshell.SpecialFolders("Desktop") ' где создать
    Set oMyShortCut= wshell.CreateShortcut(strDesktop+"\Учет работ.lnk") ' название ярлыка и само создание объекта
    oMyShortcut.IconLocation = db.Parent.Getenvironmentstring({NotesProgram}, true) & {\notes.exe} ' где лежит иконка к ярлыку
    oMyShortCut.TargetPath = db.Parent.Getenvironmentstring({NotesProgram}, True) & {\notes.exe} ' Где лежит файл по ярлыку
    oMyShortCut.Arguments = db.Server & {!!} & db.Filepath'{server!!dbName.nsf} ' аргументы для запуска
    oMyShortCut.Save 'сохраняем
    ' Если ярлык уже существует, то он перезапишется
     
  2. garrick

    garrick Lotus team
    Lotus team

    Регистрация:
    26 окт 2009
    Сообщения:
    770
    Симпатии:
    50
    Можно зарегистрировать в системе шрифт из произвольного каталога.

    Код (LotusScript):
    'Windows/32 API
    Const HWND_BROADCAST = &HFFFF&
    Const WM_FONTCHANGE = &H1D
    Declare Function AddFontResource Lib "gdi32" Alias "AddFontResourceA" (ByVal lpFileName As String) As Long
    Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
    Declare Function RemoveFontResource Lib "gdi32" Alias "RemoveFontResourceA" (ByVal lpFileName As String) As Long

    '"Подключаем" шрифт
    If AddFontResource(filename) > 0 Then
    Call SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0)
    End If

    '"Отключаем" шрифт
    Call RemoveFontResource(fontname)
     
  3. lmike

    lmike нет, пердело совершенство
    Команда форума Lotus team

    Регистрация:
    27 авг 2008
    Сообщения:
    6.073
    Симпатии:
    299
    для никсов не нужно спецю прав, просто в домашний (для тек. юзера) каталог http://help.ubuntu.ru/wiki/%D1%88%D1%80%D0...%84%D1%82%D1%8B
    т.к. маакос - это бздя (т.е. никса) то вопрос только в путях ~/Library/Fonts, ~ - это тоже хомяк (домашний каталог пользователя, по виндятски - %UserProfile%)
    а ваще господа - читайте/изучайте *никс, любой, начнете лучше понимать винду (в т.ч. убожественные части ;) )
     
Загрузка...
Похожие Темы - Установить Шрифт Создать
  1. paxac
    Ответов:
    6
    Просмотров:
    67
  2. paxac
    Ответов:
    0
    Просмотров:
    50
  3. Unfuckable
    Ответов:
    1
    Просмотров:
    66
  4. d7uk4r3v
    Ответов:
    16
    Просмотров:
    462
  5. NaVi_vl
    Ответов:
    15
    Просмотров:
    289

Поделиться этой страницей