Attribute VB_Name = "mod_ctSoundSchemeSwitcher"
' Calaym - Media player GUI for sound systems
' Copyright (C) 2002-2012 Jan Vorel
'
' You can redistribute the official software packages under the terms of the
' User-friendly Open-source License Version 1.00, published by Jan Vorel
'
' You can use this software under the terms of the
' User-friendly Software License Version 1.00, published by Jan Vorel
'
' You should have received copies of the licenses along with this program. If
' not, contact the author.
'
' If you want to use or distribute this software under a different license, ask
' the author.
'
' The software is provided "as is" without warrenty of any kind. The Licensor
' cannot be held responsible for any damage caused by using, extracting or
' installing the software.

Option Explicit
Option Base 0



' This is currently only tested / optimized for Calaym !!!!!!




#Const ctSoundSchemeSwitcher_FlagA = &H120
'  100 = UseAllApplications
' reserved  10 = byrefGetCaption
'   20 = AllowWriteCaption

Public Enum ctSoundSchemeSwitcher_DeleteOnReadModes
  DeleteOff = 0
  DeleteFileName = 1
  DeleteScheme = 2
  End Enum

#If (ctSoundSchemeSwitcher_FlagA And &H100&) = &H100& Then
  Public Function ctSoundSchemeSwitcher_ReadScheme(ByVal SchemeName As String, ByVal ApplicationName As String, Optional ByVal DeleteAfterwards As ctSoundSchemeSwitcher_DeleteOnReadModes = DeleteOff) As Long
  #Else
  Public Function ctSoundSchemeSwitcher_ReadScheme(ByVal SchemeName As String, Optional ByVal DeleteAfterwards As ctSoundSchemeSwitcher_DeleteOnReadModes = DeleteOff) As Long
  #End If

  Dim xLong1 As Long
  Dim xLong2 As Long
'  Dim xLong3 As Long
  Dim xLong4 As Long
  Dim xChar1 As String
  Dim xChar2 As String
  Dim xChar3 As String
  Dim xBool1 As Boolean

  If LCase(SchemeName) = ".current" And DeleteAfterwards = DeleteScheme Then
    DeleteAfterwards = DeleteFileName
    End If
  SchemeName = "\" & SchemeName

  #If (ctSoundSchemeSwitcher_FlagA And &H100&) = &H100& Then
    Dim xLong1x As Long
    Dim xLong2x As Long
    
    If ApplicationName = "" Then
      If RegOpenKeyEx(&H80000001, "AppEvents\Schemes\Apps", 8&, xLong1x) Then
        Do
          If RegEnumKey(xLong1x, xLong2x, ApplicationName) Then
            GoSub lbl1
            Else
            Exit Do
            End If
          xLong2x = xLong2x + 1&
          Loop
        Call RegCloseKey(xLong1x)
        End If
      Else
      If DeleteAfterwards = DeleteScheme Then
        DeleteAfterwards = DeleteOff
        End If
      GoSub lbl1
      End If
    GoTo lbl2

lbl1:
  If RegOpenKeyEx(&H80000001, "AppEvents\Schemes\Apps\" & ApplicationName, 8&, xLong1) Then
    xLong2 = 0&
    ApplicationName = ApplicationName & "\"
    #Else
  If RegOpenKeyEx(&H80000001, "AppEvents\Schemes\Apps\.Default", 8&, xLong1) Then
    #End If
    Do
      If RegEnumKey(xLong1, xLong2, xChar1) Then
  #If (ctSoundSchemeSwitcher_FlagA And &H100&) = &H100& Then
        If RegOpenKeyEx(&H80000001, "AppEvents\Schemes\Apps\" & ApplicationName & xChar1 & SchemeName, 1& + (CLng(Not DeleteAfterwards = 0&) * (-2&)), xLong4) Then
  #Else
        If RegOpenKeyEx(&H80000001, "AppEvents\Schemes\Apps\.Default\" & xChar1 & SchemeName, 1& + (CLng(Not DeleteAfterwards = 0&) * (-2&)), xLong4) Then
  #End If
          If RegQueryValueEx_String(xLong4, "", xChar2) Then
            If Not xChar2 = "" Then
              xBool1 = True
              End If
                
            #If (ctSoundSchemeSwitcher_FlagA And &H100&) = &H100& Then
              xChar3 = xChar3 & ApplicationName & xChar1 & vbNullChar & xChar2 & vbNullChar
              #Else
              xChar3 = xChar3 & ApplicationName & xChar1 & vbNullChar & xChar2 & vbNullChar
              #End If
            If DeleteAfterwards = DeleteFileName Then
              Call RegDeleteValue(xLong4, "")
              End If
            End If
          Call RegCloseKey(xLong4)
          'xChar3 = xChar1
          If DeleteAfterwards = DeleteScheme Then
            #If (ctSoundSchemeSwitcher_FlagA And &H100&) = &H100& Then
              Call RegDeleteKey(&H80000001, "AppEvents\Schemes\Apps\" & ApplicationName & xChar1 & SchemeName)
              #Else
              Call RegDeleteKey(&H80000001, "AppEvents\Schemes\Apps\.Default\" & xChar1 & SchemeName)
              #End If
            End If
          End If
        
        'If Not xChar1 = "" Then
          'End If
        Else
        Exit Do
        End If
      xLong2 = xLong2 + 1&
      Loop
    End If
  
'  If DeleteAfterwards = DeleteScheme Then
'    End If
  
  #If (ctSoundSchemeSwitcher_FlagA And &H100&) = &H100& Then
  Return
  
lbl2:
    #End If

  If DeleteAfterwards = DeleteScheme Then
    Call RegDeleteKey(&H80000001, "AppEvents\Schemes\Names" & SchemeName)
    End If
  
  xLong1 = (1& - CLng(IsUnicode)) * Len(xChar3)
  If xBool1 Then
    ctSoundSchemeSwitcher_ReadScheme = LocalAlloc(0&, xLong1 + 4&)
    If Not ctSoundSchemeSwitcher_ReadScheme = 0& Then
      xLong2 = ctSoundSchemeSwitcher_ReadScheme
      Call RtlMoveMemory(ByVal xLong2, ByVal VarPtr(xLong1), 4&)
      UIntAddUInt xLong2, 4&
      If IsUnicode Then
        Call RtlMoveMemory(ByVal xLong2, ByVal StrPtr(xChar3), xLong1)
        Else
        Call RtlMoveMemory(ByVal xLong2, ByVal xChar3, xLong1)
        End If
      End If
    End If
  End Function

Public Sub ctSoundSchemeSwitcher_FreeScheme(ByRef SchemePointer As Long)
  If Not SchemePointer = 0& Then
    Call LocalFree(SchemePointer)
    SchemePointer = 0&
    End If
  End Sub

Public Sub ctSoundSchemeSwitcher_DeleteScheme(ByVal SchemeName As String)
  Call RegDeleteKey(&H80000001, "AppEvents\Schemes\Names\" & SchemeName)
  End Sub

#If (ctSoundSchemeSwitcher_FlagA And &H20&) = &H20& Then
  Public Function ctSoundSchemeSwitcher_WriteScheme(ByVal SchemePointer As Long, ByVal SchemeName As String, Optional ByVal Caption As String) As Boolean
  #Else
  Public Function ctSoundSchemeSwitcher_WriteScheme(ByVal SchemePointer As Long, ByVal SchemeName As String) As Boolean
  #End If
  
  Dim xLong1 As Long
  Dim xLong2 As Long
  'Dim xLong3 As Long
  Dim xChar1 As String
  Dim xChar2 As String
  
  If Not (SchemePointer = 0& Or SchemeName = "") Then
    Call RtlMoveMemory(ByVal VarPtr(xLong2), ByVal SchemePointer, 4&)
    If Not xLong2 < 1& Then
      xChar1 = String(xLong2, vbNullChar)
      UIntAddUInt SchemePointer, 4&
      If IsUnicode Then
        Call RtlMoveMemory(ByVal StrPtr(xChar1), ByVal SchemePointer, xLong2)
        Else
        Call RtlMoveMemory(ByVal xChar1, ByVal SchemePointer, xLong2)
        End If
      SchemeName = "\" & SchemeName
      Do
        xLong1 = InStr(xChar1, vbNullChar)
        xLong2 = InStr(xLong1 + 1&, xChar1, vbNullChar)
        If xLong2 = 0& Then
          Exit Do
          Else
#If (ctSoundSchemeSwitcher_FlagA And &H100&) = &H100& Then
          If RegCreateKeyEx(&H80000001, "AppEvents\Schemes\Apps\" & Left(xChar1, xLong1 - 1&) & SchemeName, SchemePointer) Then
#Else
          If RegCreateKeyEx(&H80000001, "AppEvents\Schemes\.Default\" & Left(xChar1, xLong1 - 1&) & SchemeName, SchemePointer) Then
#End If
            xChar2 = Mid(xChar1, xLong1 + 1&, xLong2 - xLong1 - 1&)
            Call RegSetValueEx_String(SchemePointer, "", xChar2)
            Call RegCloseKey(SchemePointer)
            End If
          xChar1 = Mid(xChar1, xLong2 + 1&)
          End If
        Loop
      End If
    #If (ctSoundSchemeSwitcher_FlagA And &H20&) = &H20& Then
      If Not Caption = "" Then
        If RegCreateKeyEx(&H80000001, "AppEvents\Schemes\Names" & SchemeName, xLong1) Then
          Call RegSetValueEx_String(xLong1, "", Caption)
          Call RegCloseKey(xLong1)
          End If
        End If
      #End If
    End If
  End Function

