CD Actual Thematic 25: Programming/pc_actual_25.iso/Basic/GridOne/setup.EXE/SAMPLESLIB.BAS

BASIC Source File | 2001-09-09 | 10.6 KB | 349 lines

Attribute VB_Name = "modSamplesLib"
'-----------------------------------------------------------------------------
' This is a part of the BeeGrid ActiveX control.
' Copyright ⌐ 2000 Stinga
' All rights reserved.
'
' You have a right to use and distribute the BeeGrid sample files in original
' form or modified, provided that you agree that Stinga has no warranty,
' obligations, or liability for any sample application files.
'-----------------------------------------------------------------------------
Option Explicit

Public g_NorthwindPath As String

Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function CommDlgExtendedError Lib "comdlg32.dll" () As Long

'data buffer for the GetOpenFileName and GetSaveFileName functions
Private Type OPENFILENAME
        lStructSize As Long
        hwndOwner As Long
        hInstance As Long
        lpstrFilter As String
        lpstrCustomFilter As String
        nMaxCustFilter As Long
        iFilterIndex As Long
        lpstrFile As String
        nMaxFile As Long
        lpstrFileTitle As String
        nMaxFileTitle As Long
        lpstrInitialDir As String
        lpstrTitle As String
        Flags As Long
        nFileOffset As Integer
        nFileExtension As Integer
        lpstrDefExt As String
        lCustData As Long
        lpfnHook As Long
        lpTemplateName As String
End Type

Private Const PO_DLG_DELIMITER As String = ";"
'registry stuff
Const HKEY_LOCAL_MACHINE = &H80000002
Const KEY_QUERY_VALUE = &H1&
Const KEY_ENUMERATE_SUB_KEYS = &H8&
Const KEY_NOTIFY = &H10&
Const READ_CONTROL = &H20000
Const STANDARD_RIGHTS_READ = READ_CONTROL
Const KEY_READ = STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY

Private Declare Function RegQueryValueEx& Lib "advapi32.dll" Alias "RegQueryValueExA" _
   (ByVal hKey&, ByVal lpszValueName$, ByVal lpdwRes&, lpdwType&, ByVal lpDataBuff$, nSize&)
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" _
   (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long

Public Function OpenRecordset(sSQL$, _
                              Optional CursorType As ADODB.CursorTypeEnum, _
                              Optional LockType As ADODB.LockTypeEnum, _
                              Optional Options As ADODB.CommandTypeEnum) As ADODB.Recordset
   Dim rs As ADODB.Recordset

   If Len(g_NorthwindPath) = 0 Then
      g_NorthwindPath = GetNorthwindPath()
   End If

   Dim strCn$
   strCn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & g_NorthwindPath & _
           ";Persist Security Info=False"

   Dim conn As ADODB.Connection
   Set conn = New ADODB.Connection
   conn.ConnectionString = strCn
   conn.CursorLocation = adUseClient
   conn.Open

   Set rs = New Recordset
   rs.Open sSQL, conn, CursorType, LockType, Options

   Set OpenRecordset = rs
End Function

Private Function GetNorthwindPath() As String

   Dim sPath As String, sPathFile As String

   sPathFile = App.path & "\..\..\nwind.txt"

   If Len(sPath) = 0 Then

      ' Was db path saved before?
      Dim fileNum As Integer
      fileNum = FreeFile
      On Error Resume Next
      Open sPathFile For Input As fileNum
      If Err.Number = 0 Then
         Input #fileNum, sPath
      End If
      Close #fileNum
      On Error GoTo 0

      If Len(sPath) > 0 Then
         If Not FileDoesExist(sPath) Then sPath = ""
      End If

      If Len(sPath) = 0 Then
         ' Unable to locate northwind database.
         ' Ask user to locate it
         sPath = OpenNorthWind
      End If

      ' Verify that database exists
      If Len(sPath) > 0 Then
         If FileDoesExist(sPath) Then
            ' Write northwind's path to the persistent storage
            fileNum = FreeFile
            On Error Resume Next
            Open sPathFile For Output As fileNum
            If Err.Number = 0 Then
               Print #fileNum, sPath
            End If
            Close #fileNum
         Else
            ' Northwind file does not exist
            sPath = ""
         End If
      End If
   End If

   GetNorthwindPath = sPath
End Function


Public Sub LoadDefinition( _
   oGridObject As Object, sFileName As String)
   Dim iFreeFile As Integer
   Dim sDefinition As String

   sDefinition = String(FileLen(sFileName), " ")

   iFreeFile = FreeFile

   Open sFileName For _
      Binary Access Read As iFreeFile

   Get #iFreeFile, , sDefinition
   Close #iFreeFile

   oGridObject.SetDefinition sDefinition
End Sub


Public Sub SaveDefinition( _
   oGridObject As Object, sFileName As String)
   Dim iFreeFile As Integer
   Dim sDefinition As String

   sDefinition = oGridObject.GetDefinition

   iFreeFile = FreeFile

   Open sFileName For _
      Binary Access Write As iFreeFile

   Put #iFreeFile, , sDefinition
   Close #iFreeFile
End Sub



Private Function FileDoesExist(sFileName As String) As Boolean

   On Error GoTo FileExistError

   If (Len(VBA.Trim(sFileName)) = 0) Or (Len(Dir(sFileName)) = 0) Then
      FileDoesExist = False
   Else
      FileDoesExist = True
   End If

   Exit Function
FileExistError:
   FileDoesExist = False
   Exit Function
End Function
Private Function GetProfileString(sSection$, sEntry$) As String
   Dim lSecKey As Long, sTmp As String * 255
   Dim lResult As Long, lLen As Long

   lLen = 255

   lResult = RegOpenKeyEx(HKEY_LOCAL_MACHINE, sSection, 0, KEY_READ, lSecKey)
   If lResult = 0 Then
      lResult = RegQueryValueEx(lSecKey, sEntry, 0, 0, sTmp, lLen)
      If lResult = 0 Then
         GetProfileString = Left$(sTmp, lLen - 1)
      End If
      RegCloseKey lSecKey
   End If

End Function

Private Function GetVBPath() As String
   Dim sPath As String
   Const VB5_REG_SECTION = "SOFTWARE\Microsoft\Visual Basic\5.0"
   Const VB5_REG_ENTRY = "InstallDir"
   Const VB6_REG_SECTION = "Software\Microsoft\VisualStudio\6.0\Setup\Microsoft Visual Basic"
   Const VB6_REG_ENTRY = "ProductDir"

   sPath = GetProfileString(VB6_REG_SECTION, VB6_REG_ENTRY)

   If Len(sPath) = 0 Then _
      sPath = GetProfileString(VB5_REG_SECTION, VB5_REG_ENTRY)

    GetVBPath = sPath
End Function

Public Function OpenNorthWind() As String
   Dim sVBPath As String
   Dim sNorthWind As String

   sVBPath = GetVBPath

   If Len(sVBPath) > 0 Then
      sNorthWind = sVBPath & "\Nwind.mdb"
      If FileDoesExist(sNorthWind) Then
         OpenNorthWind = sNorthWind
         Exit Function
      End If
   End If

   OpenNorthWind = ShowOpen( _
      "MS Access Database *.mdb|*.mdb|All Files *.*|*.*", _
      "Open NortWind Database")

End Function

Public Function ShowOpen( _
   Optional sFilter As String = "All Files *.*|*.*", _
   Optional sTitle As String = "Open file") As String
   'display the file dialog for ShowOpen or ShowSave
   Const DLG_ACTION = 1
   Const dlg_poPathMustExist = &H800
   Const dlg_poFileMustExist = &H1000
   Const dlg_poExplorer = &H80000
   Const dlg_Flags = dlg_poPathMustExist + dlg_poFileMustExist + dlg_poExplorer
   Const dlg_MaxSize = 255
   Const dlg_MaxFileSize = 1024
   Dim tOpenFile As OPENFILENAME
   Dim sFileNameBuff As String, sFileTitleBuff As String
   Dim sValue As String, lApiReturn As Long
   Dim lExtendedError As Long, n As Long
   Dim buf As String, dirBuf As String, sSep As String

   On Error GoTo ShowFileDialogError

   'init property buffers
   lApiReturn = 0  'APIReturn property
   lExtendedError = 0  'ExtendedError property

   'prepare tOpenFile data
   tOpenFile.lStructSize = Len(tOpenFile)
   tOpenFile.hwndOwner = 0
   tOpenFile.lpstrFilter = APIFilter(sFilter)
   tOpenFile.iFilterIndex = 0

   'tOpenFile.lpstrFile As Long - init from FileName property
   'prepare sFileNameBuff
   sFileNameBuff = ""
   sFileNameBuff = Space(dlg_MaxSize - 1)
   'trim to length of dlg_MaxFileSize - 1
   sFileNameBuff = Mid$(sFileNameBuff, 1, dlg_MaxFileSize - 1)
   'null terminate
   sFileNameBuff = sFileNameBuff & Chr$(0)
   tOpenFile.lpstrFile = sFileNameBuff

   'nMaxFile As Long - init from MaxFileSize property
   tOpenFile.nMaxFile = dlg_MaxFileSize

   'lpstrFileTitle As String - init from FileTitle property
   'prepare sFileTitleBuff
   sFileTitleBuff = sTitle
   'pad with spaces
   sFileTitleBuff = Space(dlg_MaxSize - 1)
   'trim to length of dlg_MaxFileSize - 1
   sFileTitleBuff = Mid$(sFileTitleBuff, 1, dlg_MaxFileSize - 1)
   'null terminate
   sFileTitleBuff = sFileTitleBuff & Chr$(0)
   tOpenFile.lpstrFileTitle = sFileTitleBuff

   'tOpenFile.lpstrInitialDir As String - init from InitDir property
   tOpenFile.lpstrInitialDir = App.path

   'tOpenFile.lpstrTitle As String - init from DialogTitle property
   tOpenFile.lpstrTitle = "Open File"

   tOpenFile.Flags = dlg_Flags

   'tOpenFile.lpstrDefExt As String - init from DefaultExt property
   tOpenFile.lpstrDefExt = ""
   'call the GetOpenFileName API function
   lApiReturn = GetOpenFileName(tOpenFile)

    'handle return from GetOpenFileName API function
    Select Case lApiReturn
        Case 0  'user canceled
            'generate an error
            Err.Raise (2001)
            Exit Function
        Case 1  'user selected or entered a file
            'sFileName gets part of tOpenFile.lpstrFile to the left of first Chr$(0)
            ShowOpen = Left$(tOpenFile.lpstrFile, InStr(tOpenFile.lpstrFile, Chr$(0)) - 1)
        Case Else   'an error occured
            lExtendedError = CommDlgExtendedError
    End Select

Exit Function

ShowFileDialogError:
    Exit Function
End Function


Private Function APIFilter(sIn)
    'prepares sIn for use as a filter string in API common dialog functions
    Dim lChrNdx As Long
    Dim sOneChr As String
    Dim sOutStr As String

    'convert any | characters to nulls
    For lChrNdx = 1 To Len(sIn)
        sOneChr = Mid$(sIn, lChrNdx, 1)
        If sOneChr = "|" Then
            sOutStr = sOutStr & Chr$(0)
        Else
            sOutStr = sOutStr & sOneChr
        End If
    Next

    'add a null to the end
    sOutStr = sOutStr & Chr$(0)

    'return sOutStr
    APIFilter = sOutStr

End Function