Set Options


Option Explicit

‘ form level variable used to store the selected parameter from the list
‘ in the keys combo box
Private m_lSelectedParameter As Long

‘ form level constant declarations used throughout the application to name
‘ the application and section when using the Get and Save settings methods
Private Const APPLICATION_TITLE = “VB6DBHT Chapter 11”
Private Const SECTION_NAME = “Jet 3.5”

Private Sub Form_Load()

‘ load all Jet Registry settings from application section fo the
‘ Windows Registry
LoadJetRegistryInformation APPLICATION_TITLE, SECTION_NAME

With cboKeys

‘ add all of the available parameters for the SetOption method

.AddItem “dbPageTimeout”
.AddItem “dbSharedAsyncDelay”
.AddItem “dbExclusiveAsyncDelay”
.AddItem “dbLockRetry”
.AddItem “dbUserCommitSync”
.AddItem “dbImplicitCommitSync”
.AddItem “dbMaxBufferSize”
.AddItem “dbMaxLocksPerFile”
.AddItem “dbLockDelay”
.AddItem “dbRecycleLVs”
.AddItem “dbFlushTransactionTimeout”

‘ select the first item in the combo box control
.ListIndex = 0

End With

End Sub

Private Sub cboKeys_Click()

Dim lDefaultSetting As Variant

With cboKeys

‘ get a long value from the text version of the key
m_lSelectedParameter = GetParameterFromKey(.Text)

‘ obtain the default setting for the key
lDefaultSetting = GetDefaultKeySetting(.Text)

‘ display the current setting from the applications Registry
‘ settings if there is one, otherwise, display the default
txtSetting = GetSetting(APPLICATION_TITLE, _
SECTION_NAME, _
.Text, _
lDefaultSetting)

End With

End Sub

Private Sub cmdClose_Click()

‘ end the application
Unload Me

End Sub

Private Sub cmdSave_Click()

‘ if there is an error, goto the code labeled by ERR_cmdSave_Click
On Error GoTo ERR_cmdSave_Click:

‘ constant declarations for expected errors
Const ERR_TYPE_MISMATCH = 13
Const ERR_RESERVED_ERROR = 3000

‘ attempt to set the DBEngine option for the given key
‘ an error will occur here if an incorrect setting data type is
‘ entered by the user
DBEngine.SetOption m_lSelectedParameter, GetValueFromSetting(txtSetting)

‘ if the SetOption method was successful, then save the new setting
‘ value in the application Registry section
SaveSetting APPLICATION_TITLE, SECTION_NAME, cboKeys.Text, txtSetting

‘ inform the user of the success
MsgBox “Change has been made.”, vbInformation, “Set Option”

Exit Sub

ERR_cmdSave_Click:

Dim sMessage As String

With Err

Select Case .Number

‘ wrong data type entered for key setting
Case ERR_TYPE_MISMATCH, ERR_RESERVED_ERROR:
sMessage = “Value is of incorrect format.”

‘ unexpected error, create a message from the error
Case Else:
sMessage = “ERROR #” & .Number & “: ” & .Description

End Select

End With

‘ inform the user of the error
MsgBox sMessage, vbExclamation, “ERROR”

‘ repopulate the setting text box with the current or default key
‘ setting and set focus to the text box

cboKeys_Click
txtSetting.SetFocus

End Sub

Private Sub cmdDelete_Click()

‘ remove the setting from the application section of the Windows
‘ Registry
DeleteSetting APPLICATION_TITLE, SECTION_NAME, cboKeys.Text

‘ refresh the setting text box with the default value
cboKeys_Click

‘ inform the user of the success
MsgBox “Key has been deleted.”, vbInformation, “Delete Key”

End Sub

 

——————–

‘Module

Option Explicit

Public Sub LoadJetRegistryInformation(sApplicationName As String, _
sSectionName As String)

‘ if there is an error, goto the code labeled by
‘ ERR_LoadJetRegistryInformation
On Error GoTo ERR_LoadJetRegistryInformation:

Dim vSettings As Variant
Dim nCount As Integer

‘ constant declaration for expected error
Const ERR_TYPE_MISMATCH = 13

‘ obtain all of the settings from the Registry section for the given
‘ application
vSettings = GetAllSettings(sApplicationName, sSectionName)

‘ set all of the options that were specified in the Jet 3.5 section for
‘ the current application
For nCount = 0 To UBound(vSettings, 1)

DBEngine.SetOption GetParameterFromKey _
(vSettings(nCount, 0)), _
GetValueFromSetting(vSettings(nCount, 1))

Next nCount

Exit Sub

ERR_LoadJetRegistryInformation:

With Err

Select Case .Number

‘ there was no settings specified in the Registry for the
‘ given application, just continue without displaying an
‘ error message
Case ERR_TYPE_MISMATCH:

‘ unexpected error, create a message from the error
Case Else:
MsgBox “ERROR #” & .Number & “: ” & .Description, _
vbExclamation, “ERROR”

End Select

End With

End Sub

Public Function GetValueFromSetting(vSetting As Variant) As Variant

‘ if the setting is a number, return a long, otherwise return a string

If (IsNumeric(vSetting)) Then
GetValueFromSetting = CLng(vSetting)
Else
GetValueFromSetting = CStr(vSetting)
End If

End Function

Public Function GetDefaultKeySetting(sKey As String) As Variant

‘ return the defualt key setting for the key specified

Select Case sKey

Case “dbPageTimeout”:
GetDefaultKeySetting = 5000

Case “dbSharedAsyncDelay”:
GetDefaultKeySetting = 0

Case “dbExclusiveAsyncDelay”:
GetDefaultKeySetting = 2000

Case “dbLockEntry”:
GetDefaultKeySetting = 20

Case “dbUserCommitSync”:
GetDefaultKeySetting = “Yes”

Case “dbImplicitCommitSync”:
GetDefaultKeySetting = “No”

Case “dbMaxBufferSize”:
GetDefaultKeySetting = 0

Case “dbMaxLocksPerFile”:
GetDefaultKeySetting = 9500

Case “dbLockDelay”:
GetDefaultKeySetting = 100

Case “dbRecycleLVs”:
GetDefaultKeySetting = 0

Case “dbFlushTransactionTimeout”:
GetDefaultKeySetting = 500

End Select

End Function

Public Function GetParameterFromKey(ByVal sKey As String) As Long

‘ return the correct constant for the given key

Select Case sKey

Case “dbPageTimeout”:
GetParameterFromKey = dbPageTimeout

Case “dbSharedAsyncDelay”:
GetParameterFromKey = dbSharedAsyncDelay

Case “dbExclusiveAsyncDelay”:
GetParameterFromKey = dbExclusiveAsyncDelay

Case “dbLockRetry”:
GetParameterFromKey = dbLockRetry

Case “dbUserCommitSync”:
GetParameterFromKey = dbUserCommitSync

Case “dbImplicitCommitSync”:
GetParameterFromKey = dbImplicitCommitSync

Case “dbMaxBufferSize”:
GetParameterFromKey = dbMaxBufferSize

Case “dbMaxLocksPerFile”:
GetParameterFromKey = dbMaxLocksPerFile

Case “dbLockDelay”:
GetParameterFromKey = dbLockDelay

Case “dbRecycleLVs”:
GetParameterFromKey = dbRecycleLVs

Case “dbFlushTransactionTimeout”:
GetParameterFromKey = dbFlushTransactionTimeout

End Select

End Function

Advertisements

Detects the drive letter associated with the CD – ROM Drive


‘Description: Detects the drive letter associated with the CD – ROM Drive.

‘Private Declare Function GetDriveType Lib “kernel32” Alias “GetDriveTypeA” (ByVal nDrive As String) As Long
‘Private Declare Function GetLogicalDriveStrings Lib “kernel32” Alias “GetLogicalDriveStringsA” (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
‘Private Const DRIVE_REMOVABLE = 2
‘Private Const DRIVE_FIXED = 3
‘Private Const DRIVE_REMOTE = 4
‘Private Const DRIVE_CDROM = 5
‘Private Const DRIVE_RAMDISK = 6

‘Place the following code in under a command button or in a menu, etc…

Dim r&, allDrives$, JustOneDrive$, pos%, DriveType&
Dim CDfound As Integer
allDrives$ = Space$(64)
r& = GetLogicalDriveStrings(Len(allDrives$), allDrives$)
allDrives$ = Left$(allDrives$, r&)
Do
pos% = InStr(allDrives$, Chr$(0))
If pos% Then
JustOneDrive$ = Left$(allDrives$, pos%)
allDrives$ = Mid$(allDrives$, pos% + 1, Len(allDrives$))
DriveType& = GetDriveType(JustOneDrive$)
If DriveType& = DRIVE_CDROM Then
CDfound% = True
Exit Do
End If
End If
Loop Until allDrives$ = “” Or DriveType& = DRIVE_CDROM
If CDfound% Then
label1 = “The CD-ROM drive on your system is drive ” & UCase$(JustOneDrive$)
Else: label1 = “No CD-ROM drives were detected on your system.”
End If

Save and Lost Text Files


Sub LoadText(Lst As TextBox, file As String)
‘Call LoadText (Text1,”C:\Windows\System\Saved.txt”)
On Error GoTo error
Dim mystr As String
Open file For Input As #1
Do While Not EOF(1)
Line Input #1, a$
texto$ = texto$ + a$ + Chr$(13) + Chr$(10)
Loop
Lst = texto$
Close #1
Exit Sub
error:
X = MsgBox(“File Not Found”, vbOKOnly, “Error”)
End Sub

Sub SaveText(Lst As TextBox, file As String)
‘Call SaveText (Text1,”C:\Windows\System\Saved.txt”)
On Error GoTo error
Dim mystr As String
Open file For Output As #1
Print #1, Lst
Close 1
Exit Sub
error:
X = MsgBox(“There has been a error!”, vbOKOnly, “Error”)
End Sub

‘From:PulseWave

cd tray open


Set oWMP = CreateObject(“WMPlayer.OCX.7”)
Set colCDROMs = oWMP.cdromCollection

If colCDROMs.Count >= 1 Then

For i = 0 To colCDROMs.Count – 1
colCDROMs.Item(i).Eject
Next

End If


‘The next code opens only the CD-rw:
Set oWMP = CreateObject(“WMPlayer.OCX.7”)
Set colCDROMs = oWMP.cdromCollection

If colCDROMs.Count >= 1 Then

For i = 0 To colCDROMs.Count – 1
colCDROMs.Item(1).Eject
Next

End If


‘And this one ONLY the DVD-rw:
Set oWMP = CreateObject(“WMPlayer.OCX.7”)
Set colCDROMs = oWMP.cdromCollection

If colCDROMs.Count >= 1 Then

For i = 0 To colCDROMs.Count – 1
colCDROMs.Item(2).Eject
Next

End If

Show and hide assistant


Private Sub CommandButton1_Click()
With Assistant
    .Visible = True
    .Animation = msoAnimationGreeting
End With
End Sub

Private Sub CommandButton2_Click()
With Assistant
    .Visible = False
    .Animation = msoAnimationGreeting
End With

End Sub

Private Sub CommandButton3_Click()
With Assistant.NewBalloon
    .BalloonType = msoBalloonTypeBullets
    .Icon = msoIconTip
    .Button = msoButtonSetOK
    .Heading = “Tips for Saving Information.”
    .Labels(1).Text = “Save your work often.”
    .Labels(2).Text = “Install a surge protector.”
    .Labels(3).Text = “Exit your application properly.”
    .Show
End With

End Sub

Using an interface class


Sub FilterTextFile(filter As IFilter)
 
    BugAssert filter.Source <> sEmpty
    ' Target can be another file or replacement of current file
    Dim sTarget As String, fReplace As Boolean
    sTarget = filter.Target
    If sTarget = sEmpty Or sTarget = filter.Source Then
        sTarget = MUtility.GetTempFile("FLT", ".")
        fReplace = True
    End If
 
    ' Open input file
    On Error GoTo FilterTextError1
    Dim nIn As Integer, nOut As Integer
    nIn = FreeFile
    Open filter.Source For Input Access Read Lock Write As #nIn
 
    ' Open target output file
    On Error GoTo FilterTextError2
    nOut = FreeFile
    Open sTarget For Output Access Write Lock Read Write As #nOut
 
    ' Filter each line
    On Error GoTo FilterTextError3
    Dim sLine As String, iLine As Long, eca As EChunkAction
    Do Until EOF(nIn)
        Line Input #nIn, sLine
        iLine = iLine + 1
        eca = filter.Translate(sLine, iLine)
        Select Case eca
        Case ecaAbort
            GoTo FilterTextError3   ' Stop processing
        Case ecaTranslate
            Print #nOut, sLine      ' Write modified line to output
        Case ecaSkip
                                    ' Ignore
        Case Else
            BugAssert True          ' Should never happen
        End Select
    Loop
 
    ' Close files
    On Error GoTo FilterTextError1
    Close nIn
    Close nOut
    If fReplace Then
        ' Destroy old file and replace it with new one
        Kill filter.Source
        On Error Resume Next   ' No more errors allowed
        Name sTarget As filter.Source
        ' If this fails, you’re in trouble
        BugAssert Err = 0
    End If
    Exit Sub
 
FilterTextError3:
    Close nOut
FilterTextError2:
    Close nIn
FilterTextError1:
    MErrors.ErrRaise Err
End Sub

Altering application properties from vb using automation


Function ExcelApplicationEvents(oExcel As Excel.Application,bEventsStatus As Boolean) As Boolean

Dim xlTempBook As Workbook

On Error GoTo ErrFailed

Set xlTempBook=oExce.WorkBooks.Add

xlTempBook.VBProject.VBComponents.Add 1

With

xlTempBook.VBProject.VBComponents(xlTempBook.VBProject.VBComponents.Count).CodeModule

.InsertLines.CountOfLines+1,”Public Sub SetEventsStatus(bEventsStatus As boolean)”

.InsertLines.CountOfLines+1,Chr$(9) & “Application.EnableEvents=bEventsStatus”

.InsertLines.CountOfLines+1,”End Sub”

End with

oExcel.Run”‘”&xclTempBook.Name & “‘”!SetEventsStatus”,bEventStatus

xlTempBook.Close False

Set xlTempBook=Nothing

Exit function

ErrFailed:

Debug.Print”Error in ExcelApplicationEvents:” & Err.Description

Excel.ApplicationEvents=False

End Function

Private sub Form_Load()

Dim oExcel as Excel.Application

Set oExcel=New Excel.Application

Debug.Print “Application Events are:” & oExcel.EnabledEvents

ExcelApplicationEvents oExcel, False

Debug.Print “Application Events are:” & oExcel.EnabledEvents

ExcelApplicationEvents oExcel,True

Debug.Print “Application Events are:” & oExcel.EnabledEvents

oExcel.Quit

Set oExcel=Nothinh

End Sub