Code: Alles auswählen
;+-------------------------------------------------------------------------+
;| PureBasic-QuellCode "GetSystemFontI" mit allen ModulBody´s |
;| erstellt durch Programm "PB_Mod2Body", Vers. 8A08a am 02.11.2008, 17:54 |
;+-------------------------------------------------------------------------+
;Modul GetSystemFont Version 1.07 vom 19.02.2008
;
;Funktion: läd System-Font: 1=Titel 2=Symbol 3=Menü 4=Dialog 5=Palette 6=Quick/Status
; Es werden die System-FontDaten bestimmt, die via "SystemSteuerung/An=
; zeige/Darstellung/Eigenschaften/erweitert" auf´m Desktop eingestellt
; werden.
;
;Aufruf: FontID = GetSystemFont(SysFontNr.l)
; wobei: SysFontNr = der Index des gewünschten System-Font´s:
; 1 = Titelleiste des aktiven / deaktiven Fensters
; (auch für Taskleiste und Fenster-Text)
; 2 = Symbol (Desktop-Icon´s)
; 3 = Fenster-Menü, markierte Elemente
; 4 = Dialogfeld (MessageRequester)
; 5 = Paletten-Titel
; 6 = QuickInfo, auch StatusZeile
; Sofern eine gültige SysFontNr (1..6) angegeben wurde, so wird
; dieser Font geladen und dessen Handle als FunktionsWert geliefert.
; Auch die folgenden Global´s sind belegt:
Global SystemFont_Name$ ;Schriftart-Name
Global SystemFont_Size ;Schriftart-Größe
Global SystemFont_Style ;Schriftart-Attribute
;
;
;Aufruf: FontName$ = SystemFontName(SysFontNr.l) - liefert SystemFont-Bezeichnung
; wobei: SysFontNr = der Index des gewünschten System-Font´s, siehe oben
;========== Begin Modul "C:\ALSTERSOFT\PB4.20\MODULE\REGISTRY.PBI" ==========
CompilerIf Defined(Debug_Registry, #PB_Constant)=0
#Debug_Registry = 0
CompilerEndIf
;#PB_Lit2Msg start
Global RegLasterror.l
Global RegLastMessage.s
CompilerIf Defined(FormatMessage, #PB_Procedure) = #False
Procedure.s FormatMessage(ErrorNumber.l)
Protected *Buffer, len, result.s
len = FormatMessage_(#FORMAT_MESSAGE_ALLOCATE_BUFFER|#FORMAT_MESSAGE_FROM_SYSTEM,0,ErrorNumber,0,@*Buffer,0,0)
If len
result = PeekS(*Buffer, len - 2)
LocalFree_(*Buffer)
MessageRequester("Registry-Fehler", result)
ProcedureReturn result
Else
ProcedureReturn "Errorcode: " + Hex(ErrorNumber)
EndIf
EndProcedure
CompilerEndIf
Procedure Reg_SetValue(topKey, sKeyName.s, sValueName.s, vValue.s, lType = #REG_SZ, ComputerName.s = "")
Protected HKEY.l, lhRemoteRegistry.l
Protected r1.l, result.l
Protected lpData.s{256}
Protected lpcbData.l, lValue.l
Protected KeyInfo
RegLasterror = 0
If Left(sKeyName, 1) = "\" : sKeyName = Right(sKeyName, Len(sKeyName) - 1) : EndIf
If Right(sKeyName,1) = "\" : sKeyName = Left(sKeyName, Len(sKeyName) - 1) : EndIf
If ComputerName = ""
r1 = RegCreateKeyEx_(topKey, sKeyName.s, 0, 0, #REG_OPTION_NON_VOLATILE, #KEY_ALL_ACCESS, 0, @HKEY, @KeyInfo)
Else
r1 = RegConnectRegistry_(ComputerName, topKey, @lhRemoteRegistry)
If r1 <> #ERROR_SUCCESS
RegLasterror = r1
RegLastMessage = FormatMessage(RegLasterror)
ProcedureReturn #False
EndIf
r1 = RegOpenKeyEx_(lhRemoteRegistry, sKeyName, 0, #KEY_ALL_ACCESS, @HKEY)
EndIf
If #Debug_Registry : Debug "RegSave: open="+Str(r1)+" (ok="+Str(#ERROR_SUCCESS)+")" : EndIf
If r1 = #ERROR_SUCCESS
lpcbData = 255
If #Debug_Registry : Debug "RegSave: write <"+vValue+">" : EndIf
Select lType
Case #REG_SZ
r1 = RegSetValueEx_(HKEY, sValueName, 0, #REG_SZ, @vValue, Len(vValue) + 1)
Case #REG_DWORD
lValue = Val(vValue)
r1 = RegSetValueEx_(HKEY, sValueName, 0, #REG_DWORD, @lValue, 4)
EndSelect
If r1 = #ERROR_SUCCESS
result = #True
Else
RegLasterror = r1
RegLastMessage = FormatMessage(RegLasterror)
result = #False
EndIf
Else
RegLasterror = r1
RegLastMessage = FormatMessage(RegLasterror)
result = #False
EndIf
RegCloseKey_(HKEY)
If lhRemoteRegistry : RegCloseKey_(lhRemoteRegistry) : EndIf
ProcedureReturn result
EndProcedure
Procedure.s Reg_GetValue(topKey, sKeyName.s, sValueName.s, ComputerName.s = "")
Protected HKEY.l, lhRemoteRegistry.l
Protected r1.l, result.l
Protected lpData.s{256}, GetValue.s
Protected lType.l, lpcbData.l, lpDataDWORD.l
RegLasterror = 0
GetValue.s = ""
If Left(sKeyName, 1) = "\" : sKeyName = Right(sKeyName, Len(sKeyName) - 1) : EndIf
If Right(sKeyName,1) = "\" : sKeyName = Left(sKeyName, Len(sKeyName) - 1) : EndIf
If ComputerName = ""
r1 = RegOpenKeyEx_(topKey, sKeyName, 0, #KEY_ALL_ACCESS, @HKEY)
Else
r1 = RegConnectRegistry_(ComputerName, topKey, @lhRemoteRegistry)
If r1 <> #ERROR_SUCCESS
RegLasterror = r1
RegLastMessage = FormatMessage(RegLasterror)
ProcedureReturn ""
EndIf
r1 = RegOpenKeyEx_(lhRemoteRegistry, sKeyName, 0, #KEY_ALL_ACCESS, @HKEY)
EndIf
If r1 = #ERROR_SUCCESS
lpcbData = 255
r1 = RegQueryValueEx_(HKEY, sValueName, 0, @lType, @lpData, @lpcbData)
If r1 = #ERROR_SUCCESS
lType= #REG_SZ
Select lType
Case #REG_SZ
r1 = RegQueryValueEx_(HKEY, sValueName, 0, @lType, @lpData, @lpcbData)
If r1 = #ERROR_SUCCESS
GetValue = Left(lpData, lpcbData - 1)
Else : GetValue = ""
EndIf
Case #REG_DWORD
r1 = RegQueryValueEx_(HKEY, sValueName, 0, @lType, @lpDataDWORD, @lpcbData)
If r1 = #ERROR_SUCCESS
GetValue = Str(lpDataDWORD)
Else : GetValue = ""
EndIf
EndSelect
If r1 = #ERROR_SUCCESS
result = #True
EndIf
EndIf
EndIf
RegCloseKey_(HKEY)
If lhRemoteRegistry : RegCloseKey_(lhRemoteRegistry) : EndIf
ProcedureReturn GetValue
EndProcedure
;========== Ende Modul "C:\ALSTERSOFT\PB4.20\MODULE\REGISTRY.PBI" ==========
;========== Begin Modul "C:\ALSTERSOFT\PB4.20\MODULE\WORT.PBI" ==========
Global Wort_Ende$
Global Wort_Klammer$
Procedure.s Wort(*WO_Param)
Protected WO_Param$, Wort$
WO_Param$ = LTrim(PeekS(*WO_Param))
If Wort_Ende$ = ""
If Wort_Klammer$ = ""
Wort_Klammer$ = Chr(34)+Chr(39)+Chr(180)+Chr(255)
EndIf
If FindString(Wort_Klammer$,Left(WO_Param$,1),1) And WO_Param$>""
Wort_Ende$ = Left(WO_Param$,1)
WO_Param$ = Right(WO_Param$,Len(WO_Param$)-1)
Else
Wort_Ende$ = " "
EndIf
EndIf
While Left(WO_Param$,1)<>Wort_Ende$ And WO_Param$>""
Wort$ +Left(WO_Param$,1)
WO_Param$ = Mid(WO_Param$,2,99999)
Wend
Wort_Ende$ = "" : Wort_Klammer$ = ""
PokeS(*WO_Param,LTrim(Right(WO_Param$,Len(WO_Param$)-1)))
ProcedureReturn Wort$
EndProcedure
;========== Ende Modul "C:\ALSTERSOFT\PB4.20\MODULE\WORT.PBI" ==========
Global PB4_FontNr
;#jaPBeExt exit
Procedure GetSystemFont(FontNr.l) ;- Läd einen System-Font (WinTitel, Menü, Message, Status...) und liefert dessen FontHandle
Protected RegID.l, RegKey$, RegEntry.l, *LogFont.LOGFONT, FontID.l, Pos.l, Char.l, Win_DC.l
Protected PB4_MemNr
Select FontNr
Case 1 : RegKey$ = "CaptionFont" ;FensterTitel (aktiv und deaktiv)
Case 2 : RegKey$ = "IconFont" ;Symbol (Icon-Texte)
Case 3 : RegKey$ = "MenuFont" ;Menü, markierte Elemente
Case 4 : RegKey$ = "MessageFont" ;DialogFeld (MessageRequester...)
Case 5 : RegKey$ = "SmCaptionFont" ;Paletten-Titel
Case 6 : RegKey$ = "StatusFont" ;QuickInfo (auch StatusZeile)
EndSelect
SystemFont_Name$ = "" : SystemFont_Size = 0 : SystemFont_Style = 0 ;reset Global´s
If RegKey$>"" ;FontID gültig
RegOpenKeyEx_(#HKEY_CURRENT_USER, "Control Panel\Desktop\WindowMetrics", 0, #KEY_READ, @RegID)
RegQueryValueEx_(RegID, RegKey$, 0, 0, 0, @RegEntry)
*LogFont=AllocateMemory( 100)
PB4_MemNr = *LogFont
RegQueryValueEx_(RegID, RegKey$, 0, 0, *LogFont, @RegEntry)
Pos = 28 ;start of lfFaceName
Repeat
Char = PeekB(*LogFont + Pos)
If Char : SystemFont_Name$ + Chr(Char) : Pos + 2 : EndIf
Until Char = 0
SystemFont_Size = PeekL(*LogFont) : If SystemFont_Size<0 : SystemFont_Size * - 1 : EndIf
Win_DC = GetDC_(GetDesktopWindow_())
SystemFont_Size = Round(SystemFont_Size * 72 / GetDeviceCaps_(Win_DC, #LOGPIXELSY), 1)
; If PeekL(*LogFont + 16) = 700 : SystemFont_Style + #PB_Font_Bold : EndIf
If PeekB(*LogFont + 20) : SystemFont_Style + #PB_Font_Italic : EndIf
If PeekB(*LogFont + 21) : SystemFont_Style + #PB_Font_Underline : EndIf
If PeekB(*LogFont + 22) : SystemFont_Style + #PB_Font_StrikeOut : EndIf
If PeekB(*LogFont + 26) : SystemFont_Style + #PB_Font_HighQuality : EndIf
;FontID = LoadFont(FreeFont(0), SystemFont_Name$, SystemFont_Size, SystemFont_Style) <-- updated by PB_SrcChg Vers. 8A21a
PB4_FontNr = LoadFont(#PB_Any, SystemFont_Name$, SystemFont_Size, SystemFont_Style)
FontID = FontID(PB4_FontNr)
RegCloseKey_(RegID)
FreeMemory(PB4_MemNr)
EndIf
ProcedureReturn FontID
EndProcedure
Debug GetSystemFont(2)
Debug SystemFont_Name$ ;Schriftart-Name
Debug SystemFont_Size ;Schriftart-Größe
Debug SystemFont_Style ;Schriftart-Attribute
viel Erfolg...
