PureBoard

Code: Alles auswählen

;/ Application Registry
;/ Eigene Registry (XML) anstatt Preferencedateien (INI) für Anwendung verwenden
;/ (c) 2009 by Thorsten Hoeppner

;- Definitionen
Structure AppRegStructure
  id.l
  File.s
EndStructure

;- Tools
Procedure.s XMLDecode(xml$) ; XML-eigene Zeichen ersetzen
  txt$ = ReplaceString(xml$, "&", "&")
  txt$ = ReplaceString(txt$, "<", "<")
  txt$ = ReplaceString(txt$, ">", ">")
  txt$ = ReplaceString(txt$, "&apos;", "'")
  txt$ = ReplaceString(txt$, """, Chr(34))
  txt$ = ReplaceString(txt$, "&#128", "€")
  ProcedureReturn Trim(txt$)
EndProcedure

Procedure.s XMLEncode(txt$) ; XML-eigene Zeichen ersetzen
  xml$ = ReplaceString(txt$, "&", "&")
  xml$ = ReplaceString(xml$, "<", "<")
  xml$ = ReplaceString(xml$, ">", ">")
  xml$ = ReplaceString(xml$, "'", "&apos;")
  xml$ = ReplaceString(xml$, "€", "&#128")
  xml$ = ReplaceString(xml$, Chr(34), """)
  ProcedureReturn xml$
EndProcedure

;- Lade & Speichern der Registry
Procedure.b Open_AppReg(FileName.s="Registry.xml") ; Registry öffnen bzw. neu anlegen
  Protected *Node
  Global AppReg.AppRegStructure
  If FileSize(FileName) > 0 ;{ Registry vorhanden
    AppReg\id = LoadXML(#PB_Any, FileName, #PB_UTF8)
    If XMLStatus(AppReg\id) = #PB_XML_Success
      AppReg\File = FileName
      ProcedureReturn #True
    Else
      MessageRequester("Fehlermeldung", "Die Registry-Datei ist defekt und wird neu erstellt.", #MB_OK|#MB_ICONERROR)
    EndIf 
  EndIf ;}
  ;{ Neue Registry anlegen
  AppReg\id = CreateXML(#PB_Any, #PB_UTF8)
  If AppReg\id
    *Node = CreateXMLNode(RootXMLNode(AppReg\id))
    If *Node
      SetXMLNodeName(*Node, "Registry") 
      AppReg\File = FileName
      ProcedureReturn #True
    EndIf
  EndIf
  ; --- fehlgeschlagen ---
  AppReg\File = ""
  ProcedureReturn #False
  ;}
EndProcedure

Procedure.b Close_AppReg() ; Registry speichern und schließen
  If IsXML(AppReg\id) And AppReg\File
    If SaveXML(AppReg\id, AppReg\File)
      FreeXML(AppReg\id)
      ProcedureReturn #True
    Else
      Debug "AppReg: Speichern fehlgeschlagen"
      FreeXML(AppReg\id)
      ProcedureReturn #False
    EndIf
  ElseIf IsXML(AppReg\id)
    Debug "AppReg: Dateiname fehlt"
    FreeXML(AppReg\id)
    ProcedureReturn #False
  Else
    ProcedureReturn #False 
  EndIf
EndProcedure

Procedure.b Save_AppReg() ; aktuellen Stand sichern
  If IsXML(AppReg\id) And AppReg\File
    If SaveXML(AppReg\id, AppReg\File)
      ProcedureReturn #True
    Else
      Debug "AppReg: Speichern fehlgeschlagen"
    EndIf
  EndIf
  ProcedureReturn #False 
EndProcedure

;- Abfragen / Schreiben
Procedure.s GetAppRegPath(hKey.s, key.s, Name.s) ; Ermitteln des Pfades für den Node
  If hKey And key
    If Name
      ProcedureReturn hKey+"/"+ReplaceString(key, "\", "/")+"/"+Name
    Else
      ProcedureReturn hKey+"/"+ReplaceString(key, "\", "/")
    EndIf
  ElseIf hKey
    If Name
      ProcedureReturn hKey+"/"+Name
    Else
      ProcedureReturn hKey
    EndIf
  ElseIf key
    If Name
      ProcedureReturn ReplaceString(key, "\", "/")+"/"+Name
    Else
      ProcedureReturn ReplaceString(key, "\", "/")
    EndIf
  Else
    ProcedureReturn Name
  EndIf
EndProcedure

Procedure Set_AppReg(hKey.s, key.s, Name.s, Value.s) ; Wert in Registry schreiben
  Protected RegPath.s, NodeName.s, *MainNode, *Node
  RegPath = GetAppRegPath(hKey.s, key.s, Name.s)
  If IsXML(AppReg\id) And RegPath
    *MainNode = MainXMLNode(AppReg\id)
    If *MainNode
      *Node = XMLNodeFromPath(*MainNode, RegPath) 
      If Not *Node ;{ Neuen Node erzeugen
        *LastNode = *MainNode
        For n = 1 To CountString(RegPath, "/")+1
          NodeName = StringField(RegPath, n, "/")
          *Node = XMLNodeFromPath(*LastNode, NodeName)
          If Not *Node
            *Node = CreateXMLNode(*LastNode, -1)
            If *Node
              SetXMLNodeName(*Node, NodeName)
              *LastNode = *Node
            EndIf
          Else
            *LastNode = *Node
          EndIf
        Next
      EndIf ;}
      If *Node ; Wert für Node setzen
        SetXMLNodeText(*Node, XMLEncode(Value))
      EndIf
    EndIf
  EndIf
EndProcedure

Procedure.s Get_AppReg(hKey.s, key.s, Name.s, DefaultValue.s="", min.s="", max.s="") ; Wert aus Registry auslesen
  Protected *MainNode, *Node, RegPath.s
  RegPath = GetAppRegPath(hKey.s, key.s, Name.s)
  If IsXML(AppReg\id)
    *MainNode = MainXMLNode(AppReg\id)
    If *MainNode
      *Node = XMLNodeFromPath(*MainNode, RegPath)
      If *Node And GetXMLNodeText(*Node)
        If min And max
          wert = Val(GetXMLNodeText(*Node))
          If wert >= Val(min) And wert <= Val(max) 
            ProcedureReturn XMLDecode(GetXMLNodeText(*Node))
          Else
            ProcedureReturn DefaultValue
          EndIf
        Else
          ProcedureReturn XMLDecode(GetXMLNodeText(*Node))
        EndIf
      EndIf
    EndIf
  EndIf
  ProcedureReturn DefaultValue
EndProcedure

; Inhalte löschen 
Procedure ClearChilds_AppReg(*CurrentNode)
  If XMLNodeType(*CurrentNode) = #PB_XML_Normal
    *ChildNode = ChildXMLNode(*CurrentNode)
    While *ChildNode <> 0
      If XMLChildCount(*ChildNode)
        ClearChilds_AppReg(*ChildNode)
      Else
        SetXMLNodeText(*ChildNode, "")
      EndIf
      *ChildNode = NextXMLNode(*ChildNode)
    Wend        
  EndIf
EndProcedure

Procedure Clear_AppReg(hKey.s, key.s="") ; Wert(e) in Registry löschen (=> DefaultValue)
  Protected *MainNode, *Node, RegPath.s
  If IsXML(AppReg\id)
    *MainNode = MainXMLNode(AppReg\id)
    If *MainNode
      If hKey And key ;{ RegPath ermitteln
        RegPath = hKey+"/"+ReplaceString(key, "\", "/")
      ElseIf hKey
        RegPath = hKey
      EndIf ;}
      If RegPath
        *Node = XMLNodeFromPath(*MainNode, RegPath)
        If *Node
          If XMLChildCount(*Node)
            ClearChilds_AppReg(*Node)
          Else
            SetXMLNodeText(*Node, "")
          EndIf
        EndIf 
      EndIf
    EndIf
  EndIf  
EndProcedure

Procedure.b Delete_AppReg(hKey.s, key.s, Name.s) ; Eintrag  komplett löschen
  Protected *MainNode, *Node, RegPath.s
  RegPath = GetAppRegPath(hKey.s, key.s, Name.s)
  If IsXML(AppReg\id)
    *MainNode = MainXMLNode(AppReg\id)
    If *MainNode
      *Node = XMLNodeFromPath(*MainNode, RegPath)
      If *Node
        DeleteXMLNode(*Node) 
        ProcedureReturn #True
      EndIf
    EndIf
  EndIf
  ProcedureReturn #False
EndProcedure

Code: Alles auswählen

Open_AppReg("MeinProgramm.reg")
;
; ... Programmcode ------
;
Set_AppReg("Einstellungen", "Benutzer", "Name", "Thorsten Hoeppner")
Set_AppReg("Einstellungen", "Benutzer", "Ort", "Kaufbeuren")
Set_AppReg("Last", "Path", "Load", "C:\MeinProgramm\Daten\") ; letzten Pfad merken
Set_AppReg("Last", "Path", "Save", "C:\MeinProgramm\Export\") ; letzten Pfad merken
;
; ... Programmcode ------
;
Debug "Benutzer: "+Get_AppReg("Einstellungen", "Benutzer", "Name", "unbekannt")+" aus "+Set_AppReg("Einstellungen", "Benutzer", "Ort", "")

File$ = OpenFileRequester("Bitte Datei auswählen", Get_AppReg("Last", "Path", "Load", "C:\"), "(*.*)|*.*", 0)
;
; ... Programmcode ------
;
Close_AppReg()