Új hozzászólás Aktív témák

• #2750 vilag tag

  Új Válasz 2017-02-08 09:20:24 #2750

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  vilag

  tag

  Sziasztok!

  Kicsit rég jártam erre...

  /Szerencsére a program egy jó ideje viszonylag stabilan működik./

  Most egy régi-új fejlesztési ötletet szeretnék végre befejezni, ami már félig készen van.

  A lényeg az, hogy egy generált ügyiraton szeretnék vonalkódot megjeleníteni a korábban általam itt közzé tett algoritmussal.
  Ez eddig meg is van.
  A bibi ott van, hogy ehhez egy betűtípus telepítésére van szükség amit nyilván automatizálni szeretnék.
  Részben azért, mert nem fogok mindig itt dolgozni (ez már biztos!), részben azért, mert a gépek fizikálisan is messze vannak, részben pedig azért, mert nem akarom egyesével minden gépen végrehajtani a telepítést.
  A probléma az, hogy a betűtipus telepítése nem annyi, hogy a "Fonts" könyvtárba bemásolom azt.

  Kerestem a problémára megoldást és az alábbi kódot találtam:
  Declare Function WriteProfileString Lib "Kernel" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpString As String) As Integer
Declare Function CreateScalableFontResource% Lib "GDI" (ByVal fHidden%, ByVal lpszResourceFile$, ByVal lpszFontFile$, ByVal lpszCurrentPath$)
Declare Function AddFontResource Lib "GDI" (ByVal lpFilename As Any) As Integer
Declare Function SendMessage Lib "User" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Any) As Long



' This sub installs a TrueType font and makes it available to all Windows apps. It takes these arguments:
'
' FontName$ is the font's name (e.g. "Goudy Old Style")
'
' FontFileName$ is the font's filename (e.g. "GOUDOS.TTF")
'
' WinSysDir$ is the user's System folder (e.g. "C:\WINDOWS\SYSTEM" or "C:\WINDOWS\SYSTEM32")
'
' ** Before calling this sub, your code must copy the font file to the user's Fonts folder. **
'

Sub ttf_install(FontName$, FontFileName$, WinSysDir$)

Dim Ret%, Res&, FontPath$, FontRes$
Const WM_FONTCHANGE = &H1D
Const HWND_BROADCAST = &HFFFF

FontPath$ = WinSysDir$ + "\" + FontFileName$
FontRes$ = Left$(FontPath$, Len(FontPath$) - 3) + "FOT"

Ret% = CreateScalableFontResource(0, FontRes$, FontFileName$, WinSysDir$)
Ret% = AddFontResource(FontRes$)
Res& = SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0)
Ret% = WriteProfileString("fonts", FontName + " " & "(TrueType)", FontRes$)

End Sub

  Ezt kicsit módosítottam mert egyáltalán el sem indult, így a Sub sorból a zárójelben lévő részeket kivettem és az alatta lévő sorokkal egészítettem ki az alábbiak szerint:

  Declare Function WriteProfileString Lib "Kernel" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpString As String) As Integer
Declare Function CreateScalableFontResource% Lib "GDI" (ByVal fHidden%, ByVal lpszResourceFile$, ByVal lpszFontFile$, ByVal lpszCurrentPath$)
Declare Function AddFontResource Lib "GDI" (ByVal lpFilename As Any) As Integer
Declare Function SendMessage Lib "User" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Any) As Long

' This sub installs a TrueType font and makes it available to all Windows apps. It takes these arguments:
' FontName$ is the font's name (e.g. "Goudy Old Style")
' FontFileName$ is the font's filename (e.g. "GOUDOS.TTF")
' WinSysDir$ is the user's System folder (e.g. "C:\WINDOWS\SYSTEM" or "C:\WINDOWS\SYSTEM32")
' ** Before calling this sub, your code must copy the font file to the user's Fonts folder. **

Sub ttf_install() '(FontName$, FontFileName$, WinSysDir$)

FontName$ = "Vonalkód"
FontFileName$ = "code128.ttf"
WinSysDir$ = Environ("WINDIR") & "\Fonts"

Dim Ret%, Res&, FontPath$, FontRes$
Const WM_FONTCHANGE = &H1D
Const HWND_BROADCAST = &HFFFF

FontPath$ = WinSysDir$ + "\" + FontFileName$
FontRes$ = Left$(FontPath$, Len(FontPath$) - 3) + "FOT"

Ret% = CreateScalableFontResource(0, FontRes$, FontFileName$, WinSysDir$)
Ret% = AddFontResource(FontRes$)
Res& = SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0)
Ret% = WriteProfileString("fonts", FontName + " " & "(TrueType)", FontRes$)

End Sub

  Valamit azonban biztosan rosszul csinálok, mert nem tudom működésre bírni.

  A megjegyzésben írtak szerint a betűtípus másolása megtörténik a Windows\Fonts mappába.
  Nem tudom a megjegzésben mért a felhasználó Fonts mappát írja, mert olyan én nem találtam.
  Esetleg itt a hiba, létre kéne hoznom egyet?
  De sehol nem hivatkozik a felhasználói mappa Fonts könyvtárára...

  Az alábbi sornál azonban hibára futok:
  Ret% = CreateScalableFontResource(0, FontRes$, FontFileName$, WinSysDir$)

  A hiba:
  Run-time error '53':
  File not found.

  Van valakinek ötlete, hogyan tudnám ezt a dolgot működésre bírni?

Új hozzászólás Aktív témák