PureBasic Forums - English

Posted: **Fri Jan 13, 2017 8:24 pm**

I have the following that copies the embedded font to C:\Windows\Fonts and uses the AddFontResource to initialize it, it also creates the necessary registry key, but when you reboot, the font is no longer selectable in any application and does not show up in the Fonts in Control Panel. Anyone know how to fix it. Also, it has to be ran as administrator.

Code: Select all

Enumeration
  #KEY_WOW64_64KEY=$100 ;//Resident
  #KEY_WOW64_32KEY=$200 ;//Resident
EndEnumeration

Procedure RegMode(Ex,Wow64) ;+++
  ;/// Set Registry access mode<br>
  ;/// <b>Ex</b> Use Extended Registry Functions
  ;/// #False (Default) use old Registry functions
  ;/// #True : Use 'New' Registry Functions (Some key cannot be viewed as simple user)<br>
  ;/// <b>Wow64</b> Access an Alternate Registry View
  ;/// By default, a 32-bit application running on WOW64 accesses the 32-bit registry view and a 64-bit application accesses the 64-bit registry view.
  ;/// The following flags enable 32-bit applications to access redirected keys in the 64-bit registry view and 64-bit applications to access redirected keys in the 32-bit registry view.
  ;/// These flags have no effect on shared registry keys.
  ;/// <b>#KEY_WOW64_64KEY</b> Access a 64-bit key from either a 32-bit or 64-bit application. (RegEx(#True) required)
  ;/// <b>#KEY_WOW64_32KEY</b> Access a 32-bit key from either a 32-bit or 64-bit application.
  ;/// <br><A href="http://msdn.microsoft.com/en-us/library/aa384253(v=VS.85).aspx">Registry Keys Affected by WOW64</A>
 
  Shared RegWow64.l,RegEx.l
  
  RegEx=Ex
  RegWow64=Wow64
  
EndProcedure

Procedure RegConvertRegKeyToTopKeyAndKeyName(Key.s) ; internl function
  
  Shared topKey,KeyName.s
  
  temp.s=StringField(Key,1,"\")
  temp=UCase(temp)
  Select temp
    Case "HKEY_CLASSES_ROOT"
      topKey=#HKEY_CLASSES_ROOT
    Case "HKEY_CURRENT_USER"
      topKey=#HKEY_CURRENT_USER
    Case "HKEY_LOCAL_MACHINE"
      topKey=#HKEY_LOCAL_MACHINE
    Case "HKEY_USERS"
      topKey=#HKEY_USERS 
    Case "HKEY_CURRENT_CONFIG"
      topKey=#HKEY_CURRENT_CONFIG 
  EndSelect
  
  PositionSlash=FindString(Key,"\",1)
  KeyName.s=Right(Key,(Len(Key)-PositionSlash))
  
EndProcedure

Procedure RegSetValue(Key.s, ValueName.s, Value.s, Type, ComputerName.s) ;+++
  ;/// Sets a Value
  ;/// Type can be #REG_SZ / #REG_DWORD / #REG_BINARY / #REG_EXPAND_SZ
  ;/// For #REG_BINARY type use Hexa value as String
  ;/// Returns 1 if successful or 0 if it fails
  
  Shared RegWow64.l,RegEx,topKey,KeyName.s
  RegConvertRegKeyToTopKeyAndKeyName(Key)
  
  If ComputerName = "."
    If RegEx
      GetHandle = RegOpenKeyEx_(topKey,KeyName,0,#KEY_ALL_ACCESS|RegWow64,@hKey) 
    Else
      GetHandle = RegOpenKey_(topKey,KeyName,@hKey) 
    EndIf
  Else 
    lReturnCode = RegConnectRegistry_(ComputerName,topKey,@lhRemoteRegistry) 
    If RegEx
      GetHandle = RegOpenKeyEx_(lhRemoteRegistry,KeyName,0,#KEY_ALL_ACCESS|RegWow64,@hKey) 
    Else
      GetHandle = RegOpenKey_(lhRemoteRegistry,KeyName,@hKey) 
    EndIf
  EndIf 
  
  If GetHandle = #ERROR_SUCCESS 
    lpcbData = 1024 
    lpData.s = Space(lpcbData) 
    
    Select Type 
        
      Case #REG_EXPAND_SZ 
        CompilerIf #PB_Compiler_Unicode 
          GetHandle = RegSetValueEx_(hKey, ValueName, 0, #REG_EXPAND_SZ, @Value, Len(Value)*2 + 1) 
        CompilerElse
          GetHandle = RegSetValueEx_(hKey, ValueName, 0, #REG_EXPAND_SZ, @Value, Len(Value) + 1) 
        CompilerEndIf
        
      Case #REG_SZ
        CompilerIf #PB_Compiler_Unicode 
          GetHandle = RegSetValueEx_(hKey, ValueName, 0, #REG_SZ, @Value, Len(Value)*2 + 1) 
        CompilerElse
          GetHandle = RegSetValueEx_(hKey, ValueName, 0, #REG_SZ, @Value, Len(Value) + 1) 
        CompilerEndIf
        
      Case #REG_DWORD 
        lValue = Val(Value) 
        GetHandle = RegSetValueEx_(hKey, ValueName, 0, #REG_DWORD, @lValue, 4) 
        
      Case #REG_BINARY
        LenBuffer=Len(Value)/2
        *RegBuffer=AllocateMemory(LenBuffer)
        For n=0 To LenBuffer-1
          OctetHexa.s=Mid(Value,(n*2)+1,2)
          Octet=Val("$"+OctetHexa)
          PokeB(*RegBuffer+n,Octet)
        Next
        GetHandle= RegSetValueEx_(hKey,ValueName,0,#REG_BINARY,*RegBuffer,LenBuffer) 
        FreeMemory(*RegBuffer)
        
    EndSelect 
    
    RegCloseKey_(hKey) 
    ergebnis = 1 
    ProcedureReturn ergebnis 
  Else 
    RegCloseKey_(hKey) 
    ergebnis = 0 
    ProcedureReturn ergebnis 
  EndIf 
EndProcedure

Procedure CreateFont()
 CreateDirectory("Font")
 CreateFile(1,"Font\fre3of9x.ttf")
  WriteData(1,?fontstart,?fontend-?fontstart)
 CloseFile(1)
EndProcedure

CreateFont()
Delay(3000)
RegSetValue("HKEY_LOCAL_MACHINE\Software\Microsoft\Windows NT\CurrentVersion\Fonts","Free 3 of 9 Extended Regular (TrueType)","fre3of9x.ttf",#REG_SZ,".")
CopyFile("Font\fre3of9x.ttf","C:\Windows\Fonts\fre3of9x.ttf")
Delay(3000)
DeleteDirectory("Font","*.*")
Delay(2000)
AddFontResource_("fre3of9x.ttf")
SendMessage_(#HWND_BROADCAST, #WM_FONTCHANGE, 0, 0)

DataSection
fontstart:
IncludeBinary "fre3of9x.ttf"
fontend:
EndDataSection

Posted: **Sat Jan 14, 2017 12:24 am**

Maybe you could use RegisterFontFile - it does not install your font but your app can always use it.

Posted: **Sat Jan 14, 2017 5:59 am**

I wish I could, but I need to push out the font company-wide for use with Excel and Word. Basically they want those that need it to be able to program their handheld wedge scanners. Don't ask...not looking forward to it.

Posted: **Sat Jan 14, 2017 8:44 am**

Hi

Code: Select all

Global GetHandle ,hKey ,lType ,lpcbData ,lpData.s ,lReturnCode ,lhRemoteRegistry ,lpDataDWORD

Procedure SetValue(topKey, sKeyName.s, sValueName.s, vValue.s, lType, ComputerName.s)
  If ComputerName = "" 
    GetHandle = RegOpenKeyEx_(topKey, sKeyName, 0, #KEY_ALL_ACCESS, @hKey) 
  Else 
    lReturnCode = RegConnectRegistry_(ComputerName, topKey, @lhRemoteRegistry) 
    GetHandle = RegOpenKeyEx_(lhRemoteRegistry, sKeyName, 0, #KEY_ALL_ACCESS, @hKey) 
  EndIf 

  If GetHandle = #ERROR_SUCCESS 
    lpcbData = 255 
    lpData = Space(255) 
        GetHandle = RegSetValueEx_(hkey, sValueName, 0, #REG_SZ, @vValue, StringByteLength(vValue) + SizeOf(Character))
    RegCloseKey_(hkey) 
    Error = 1 
    ProcedureReturn Error 
  Else 
    MessageRequester("Error", "An Error occured, Return value = " + Str(lRetVal), 0) 
    RegCloseKey_(hKey) 
    Error  = 0 
    ProcedureReturn Error 
  EndIf 
EndProcedure

If OpenLibrary(0,"shell32.dll")
  *MAlloc = GetFunction(0, "IsUserAnAdmin")
  If CallCFunctionFast(*MAlloc) = 0
    MessageRequester("Error","Run As Admin",#MB_ICONERROR)
    End
  EndIf
  CloseLibrary(0)
EndIf

Fontname$ = "Encrypted.ttf"
Fontval$ = GetFilePart(Fontname$,#PB_FileSystem_NoExtension)+" (TrueType)"
windir$ = Space(#MAX_PATH)
GetWindowsDirectory_(@windir$,#MAX_PATH)
fontto$ = windir$+"\Fonts\"+Fontname$
fontfrom$ = "C:\Temp\"+Fontname$
CopyFile_(@fontfrom$,@fontto$,0)
SetValue(#HKEY_LOCAL_MACHINE,"SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts",Fontval$,Fontname$,#REG_SZ,"")
SendMessage_(#HWND_BROADCAST, #WM_FONTCHANGE, 0, 0)

Posted: **Sat Jan 14, 2017 12:01 pm**

Hi,

look also here:
http://www.purebasic.fr/english/viewtop ... Ex#p350441

Posted: **Sat Jan 14, 2017 2:57 pm**

Found this hiding in my files and might be of use...

Code: Select all

EnableExplicit

Procedure CatchFont(*Memory, lMemSize)
  Protected lParam1 = 1
  ProcedureReturn AddFontMemResourceEx_(*Memory, lMemSize, 0, @lParam1)
EndProcedure
Procedure FreeCatchFont(lMemFont)
  ProcedureReturn RemoveFontMemResourceEx_(lMemFont)
EndProcedure

Procedure Main()
  Protected lMemFont = CatchFont(?StartD,  ?EndD -?StartD)
  Protected lGuiFont = LoadFont(#PB_Any, "BAUHS93", 16) ; <<< Customize
  If lMemFont And lGuiFont
    If OpenWindow(0, #PB_Ignore, #PB_Ignore, 440, 80,"CatchFont Demo", #PB_Window_SystemMenu)
      SetGadgetFont(#PB_Default, FontID(lGuiFont))
      TextGadget(0,10,10,400,20,"CatchFont Demo")
      Repeat : Until WaitWindowEvent() = #PB_Event_CloseWindow
      CloseWindow(0)
    Else
      MessageRequester("CatchFont Demo Error", "Couldn't open main window.", #MB_OK | #MB_ICONERROR)
    EndIf
  Else
    MessageRequester("CatchFont Demo Error", "Couldn't load font from memory.", #MB_OK | #MB_ICONERROR)
  EndIf
  FreeCatchFont(lMemFont)
  FreeFont(lGuiFont)
EndProcedure

Main() : End

DataSection
  StartD:
  IncludeBinary "BAUHS93.TTF" ; <<< Customize
  EndD:
EndDataSection

Posted: **Sat Jan 14, 2017 3:49 pm**

but when you reboot, the font is no longer selectable in any application

Beside it will not work with Vector Drawing library
OldSkoolGamer need to install the font permanently

Posted: **Sat Jan 14, 2017 6:40 pm**

@RASHAD

Thanks a ton as usual. I assume my issue was not using the correct font name in the registry key, and maybe using the AddFontResource? Anyways, It's working great now!! Thanks again, you are the best :

EDIT:

It turns out it was the "SendMessage_(#HWND_BROADCAST, #WM_FONTCHANGE, 0, 0)" that was causing my issue, removed that and was able to push it out, used Rashad's anyways.

PureBasic Forums - English

Installing font in Windows

Installing font in Windows

Re: Installing font in Windows

Re: Installing font in Windows

Re: Installing font in Windows

Re: Installing font in Windows

Re: Installing font in Windows

Re: Installing font in Windows

Re: Installing font in Windows