BevNap - Recently Updated Pages

PutRecordsetInCells

2buck — Sat, 02 Dec 2006 11:09:19 CST

Function PutRecordsetInCells(ByVal vrs, ByVal voWorksheet, ByVal vsStartCell)

'Puts the results of a SQL statement into the Excel worksheet.
'Returns row count.
'vsStartCell is a cell identifier like "A1" of the
'upper left corner of where the results should go.
' Call PutRecordsetInCells(rs, oWorksheet, "A1")
Dim i, iRowCount

For i = 0 To vrs.Fields.Count - 1
With voWorksheet.Range(vsStartCell).Offset(0, i)
.Value2 = vrs.Fields(i).Name
.Font.Bold = True
.Borders(9).LineStyle = 1 ' <-- 9 means bottom, 1 means continuous.
End With
Next

iRowCount = voWorksheet.Range(vsStartCell).Offset(1, 0).CopyFromRecordset(vrs)
PutRecordsetInCells = iRowCount

End Function

GetSettings

2buck — Sat, 02 Dec 2006 10:35:43 CST

Function GetSettings(ByVal vsFilePath)

'Returns a collection of names and values from the file.
'The file is an Excel spreadsheet saved as a CSV file.
'The first column in the file is the setting name and the second is the value.
'A third column can be used for comments.
' Dim cSettings
' Set cSettings = GetCSVCollection("Settings.csv")
Dim asRows, cSettings, i, asEntries

asRows = Split(GetFileContents(vsFilePath), vbCrLf)
Set cSettings = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(asRows)
asEntries = Split(asRows(i), ",")
If UBound(asEntries) > 0 Then
cSettings.Add Trim(asEntries(0)& ""), Trim(asEntries(1) & "")
End If
Next

Set GetSettings = cSettings

End Function

VBSCript GetCSVCollection

2buck — Sat, 02 Dec 2006 10:27:34 CST

NOTE: This one is not as good as the VB6 one.

Function GetCSVCollection(ByVal vsFilePath)

'Returns a collection of collections.
'There's a collection for each row.
'The file is made by saving an Excel spreadsheet as a CSV file.
' Dim cEntries
' Set cEntries = GetCSVCollection("Entries.csv")
Dim asRows, asFieldNames, cRecordSet, i, asFieldValues
Dim cRecord, iFieldCount, j

asRows = Split(GetFileContents(vsFilePath), vbCrLf)
asFieldNames = Split(asRows(0), ",")
Set cRecordSet = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(asRows)
asFieldValues = Split(asRows(i), ",")
Set cRecord = CreateObject("Scripting.Dictionary")
If UBound(asFieldNames) < UBound(asFieldValues) Then
iFieldCount = UBound(asFieldNames) + 1
Else
iFieldCount = UBound(asFieldValues) + 1
End If

For j = 0 To iFieldCount - 1
cRecord.Add Trim(asFieldNames(j)), asFieldValues(j)
Next
cRecordSet.add i - 1, cRecord
Next

Set GetCSVCollection = cRecordSet

End Function

GetFileContents

2buck — Fri, 01 Dec 2006 23:01:56 CST

Function GetFileContents(ByVal vsFilePath)

'Returns a string containing all the text in a file.
'The default folder depends on how the script is run.
'But it's usually the folder the script is in.
' Dim sContents
' sContents = GetFileContents("smr_mt571_extract.txt")
' MsgBox Len(sContents)
Dim oFso, oFile, oTs

Set oFso = CreateObject("Scripting.FileSystemObject")
Set oFile = oFso.GetFile(vsFilePath)
Set oTs = oFile.OpenAsTextStream(1) ' <-- 1 means ForReading
GetFileContents = oTs.Read(oFile.Size)
oTs.Close Set oTs = Nothing
Set oFile = Nothing
Set oFso = Nothing

End Function

VBScript

2buck — Fri, 01 Dec 2006 22:59:07 CST

There is no abstract available for this page revision.

GetCSVCollection

2buck — Fri, 01 Dec 2006 22:57:27 CST

Private Function GetCSVCollection(ByVal vstrListFilePath As String) As Collection

' Reads in a Comma Seporated Values (CSV) file
' and puts it all into collections with nice labels.
' Parameters: vstrListFilePath - the path and file name of the CSV file.
' This function uses the Split function to carve up CSV file
' and load it all into collections.
' In the CSV file, the first row is for field names (headers)
' and only the right most column can contain commas.
' That's usually used for comments.
' --- EXAMPLE ---
' Set cData = GetCSVCollection(Command)
' For Each cFields In cData
' Debug.Print cFields("Header")
' Next
Dim arrRecs() As String ' <-- array of records or lines
Dim arrFieldNames() As String ' <-- field names are in the first line
Dim arrVals() As String ' <-- array of values in one line goes to colVals
Dim colRecs As New VBA.Collection ' <-- where all this data ends up
Dim colVals As VBA.Collection ' <-- values from one line with field names as keys
Dim lngValUBound As Long ' <-- max index of vals in rec
Dim lngFieldNamesUBound As Long
Dim i As Long ' <-- row loop index
Dim j As Long ' <-- column loop index

arrRecs = Split(GetFileContents(vstrListFilePath), vbCrLf)
arrFieldNames = Split(arrRecs(0), ",")
lngFieldNamesUBound = UBound(arrFieldNames)
For i = 1 To UBound(arrRecs)
arrVals = Split(arrRecs(i), ",")
' --- This handles commas in the last column. ---
lngValUBound = UBound(arrVals)
If lngValUBound > lngFieldNamesUBound Then
For j = lngFieldNamesUBound + 1 To lngValUBound
arrVals(lngFieldNamesUBound) = arrVals(lngFieldNamesUBound) + "," + arrVals(j)
Next
lngValUBound = lngFieldNamesUBound
End If

If lngValUBound >= 0 Then
Set colVals = New Collection
For j = 0 To lngValUBound
colVals.Add Trim(arrVals(j)), Trim(arrFieldNames(j))
Next
For j = lngValUBound + 1 To lngFieldNamesUBound
colVals.Add "", Trim(arrFieldNames(j))
Next
colRecs.Add colVals
End If
Next
Set GetCSVCollection = colRecs

End Function

Get Excel Range Column

2buck — Fri, 01 Dec 2006 22:49:36 CST

Private Function Column(ByVal vlngX As Long) As String

' Returns an Execl range column like "A".
' EX: objSheet.Columns(Column(1) & ":" & Column(10)).Select
' 1 <= vlngX <= 676
' 1 <= vlngY
Dim strColumn As String

strColumn = Chr(Asc("A") + ((vlngX - 1) Mod 26))
If vlngX > 26 Then
strColumn = Chr(Asc("A") + Fix(vlngX / 26) - 1) & strColumn
End If
Column = strColumn

End Function

AutoTab

2buck — Fri, 01 Dec 2006 22:42:46 CST

Public Sub AutoTab()

'For TextBoxes with MaxLength property > 0.
'Tabs only if the cursor is at the end of the text.
'Sub Text1_Change ()
' Call AutoTab
'End Sub
Dim Text1 As Control
Dim Text As String
Dim Length As Integer
Dim MaxLen As Integer

On Error GoTo AutoTabTrap
Set Text1 = Screen.ActiveControl
Text = Text1.Text
Length = Len(Text)
MaxLen = Text1.MaxLength
If Length > MaxLen Then
'How can this be? Maybe it was pasted.
'This causes another change event so we'll be back.
Text1.Text = Left$(Text, MaxLen)
ElseIf Length = MaxLen And Text1.SelStart = MaxLen Then
SendKeys "{TAB}"
End If
AutoTabTrap:
Exit Sub

End Sub

GetMDACVersion GetExcelVersion

2buck — Fri, 01 Dec 2006 22:37:33 CST

Public Function GetMDACVersion() As String

Dim objObject As Object

GetMDACVersion = "n/a"
On Error Resume Next
Set objObject = New ADODB.Connection
GetMDACVersion = objObject.Version

End Function

Public Function GetExcelVersion() As String

Dim objObject As Object

GetExcelVersion = "n/a"
On Error Resume Next
Set objObject = New Excel.Application
GetExcelVersion = objObject.Version

End Function

Visual Basic 6.0

2buck — Fri, 01 Dec 2006 22:30:36 CST

There is no abstract available for this page revision.

SelectActiveText

2buck — Thu, 30 Nov 2006 22:23:23 CST

Public Sub SelectActiveText()

'Call from the GetFocus events for all the TextBoxes and
'ComboBoxes with Style=0 - Dropdown Combo.
'Select only if tabbed not clicked.
Dim ctrl As Control
Const KEY_LBUTTON = &H1

On Error GoTo SelectActiveTextTrap
Set ctrl = Screen.ActiveControl
If IsLButtonDown() Then
ctrl.SelLength = 0
Else
ctrl.SelStart = 0
ctrl.SelLength = Len(ctrl.Text)
End If
SelectActiveTextTrap:
Exit Sub

End Sub

IsVBIDE

2buck — Thu, 30 Nov 2006 22:20:18 CST

Public Function IsVBIDE() As Boolean

' Returns True if this code is running
' inside the VB Integrated Development Environment (IDE).
' The trick here is that Debug.Print only runs in the VB IDE.
On Error Resume Next
Debug.Print 1 / 0
IsVBIDE = Err.Number <> 0

End Function

Home

2buck — Wed, 29 Nov 2006 22:22:20 CST

Some of the best ideas are written on BEVerage NAPkins.

See also: bevnap.blogspot.com