Attribute VB_Name = "MODUL_ApplicationBase"
' modul for Visual Basic 6
' Copyright (C) 2003,2004 Jan Vorel

' This program is free software; you can redistribute it and/or modify
' it under the terms of the GNU General Public License as published by
' the Free Software Foundation; either version 2 of the License, or
' (at your option) any later version.

' This program is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY; without even the implied warranty of
' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
' GNU General Public License for more details.

' You should have received a copy of the GNU General Public License
' along with this program; if not, write to the Free Software
' Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

' This is a shared modul, class modul, usercontrol or form. It is also
' published under the GNU General Public License.

' If you have any questions, suggestions or bug reports about this product,
' contact me: info@ctuser.net; Do not contact me about general B.A.S.I.C.
' language or A.P.I. issues

Option Explicit
Option Base 0

'#Const AppBase_UseLightVersion = 1
'#Const AppBase_ExenameOnly = 1
'#Const AppBase_NonCaseSensitive = 1
Private Declare Function GetCommandLineA Lib "kernel32" () As Long
Private Declare Function lstrcpynA Lib "kernel32" (ByVal lpString1 As String, ByVal lpString2 As Long, ByVal iMaxLength As Long) As Long


#If AppBase_UseLightVersion Or AppBase_ExenameOnly Or AppBase_NonCaseSensitive Then
  #If AppBase_UseLightVersion Or AppBase_ExenameOnly Then
    Public Function AppBase() As String
    #Else
    Public Function AppBase(Optional ByVal ExtensionToAdd As String = vbNullChar) As String
    #End If
  
  
    Dim xLong1 As Long
    
    xLong1 = GetCommandLineA
    If Not xLong1 = 0& Then
      AppBase = String(65535, vbNullChar)
      Call lstrcpynA(AppBase, xLong1, 65534)
      AppBase = Trim(Left(AppBase, InStr(AppBase & vbNullChar, vbNullChar) - 1&))
      End If
    If Left(AppBase, 1&) = Chr(34&) Then
      AppBase = Mid(AppBase, 2&)
      xLong1 = Len(AppBase)
      If Not xLong1 = 0 Then
        AppBase = Left(AppBase, xLong1 - 1&)
        End If
      xLong1 = InStr(AppBase, Chr(34&))
      Else
      xLong1 = InStr(AppBase, " ")
      End If
    If Not xLong1 = 0& Then
      AppBase = Left(AppBase, xLong1 - 1&)
      End If
    
    #If AppBase_UseLightVersion Or AppBase_NonCaseSensitive Then
      #If AppBase_NonCaseSensitive Then
        If Not ExtensionToAdd = vbNullChar Then
          #End If
            xLong1 = InStrRev(AppBase, ".")
            If xLong1 = 0& Then
              If xLong1 > InStrRev(AppBase, "\") Then
                #If AppBase_UseLightVersion Then
                  AppBase = Left(AppBase, xLong1 - 1&)
                  #Else
                  AppBase = Left(AppBase, xLong1) & ExtensionToAdd
                  #End If
                End If
              End If
            #If AppBase_NonCaseSensitive Then
          End If
        #End If
      #End If
    End Function
  #Else
  Public Function AppBase(Optional ByVal ExtensionToAdd As String = vbNullChar) As String

    Static xLong1 As Long
    Static xChar1 As String
    Static xChar2 As String
    Static xChar3 As String
    
    If xChar2 = "" Then
      xLong1 = GetCommandLineA
      xChar2 = String(65535, vbNullChar)
      Call lstrcpynA(ByVal xChar2, xLong1, 65534)
      xChar2 = Trim(Left(xChar2, InStr(xChar2, vbNullChar) - 1&))
    
      If Left(xChar2, 1&) = Chr(34&) Then
        xChar2 = Mid(xChar2, 2&)
        xLong1 = Len(xChar2)
        If Not xLong1 = 0& Then
          xChar2 = Left(xChar2, xLong1 - 1&)
          End If
        xLong1 = InStr(xChar2, Chr(34&))
        Else
        xLong1 = InStr(xChar2, " ")
        End If
      If Not xLong1 = 0& Then
        xChar2 = Left(xChar2, xLong1 - 1&)
        End If
    
      xLong1 = InStrRev(xChar2, "\")
      AppBase = Mid(xChar2, xLong1 + 1&)
      xChar2 = Left(xChar2, xLong1)
      xChar3 = xChar2
      xLong1 = InStrRev(AppBase, ".")
      If xLong1 = 0& Then
        xChar1 = AppBase & "."
        Else
        xChar1 = Left(AppBase, xLong1)
        End If
      Select Case xChar1
        Case LCase(xChar1)
          xLong1 = 1&
        Case UCase(xChar1)
          xLong1 = 2&
        Case Else
          xLong1 = 0&
        End Select
      xChar1 = xChar2 & xChar1
      xChar2 = xChar2 & AppBase
      End If
    
    Select Case ExtensionToAdd
      Case vbNullChar
        AppBase = xChar2
      Case Chr(1&)
        AppBase = xChar3
      Case LCase(ExtensionToAdd), UCase(ExtensionToAdd)
        If xLong1 = 2 Then
          AppBase = xChar1 & UCase(ExtensionToAdd)
          Else
          AppBase = xChar1 & LCase(ExtensionToAdd)
          End If
      Case Else
        AppBase = xChar1 & ExtensionToAdd
      End Select
    End Function
  #End If

