Visual Basic Sticky/Basic Projects

DoubleTop · 9 March 2005 10:00

I was wondering as I have a whole host of code for VB6, if anyone would like to see a bit of a sticky with some examples of basic tasks and routines from Visual Basic.

I know at last Mojo’s there were a lot of people saying “I’ve always meant to try it…”, wondered who may be interested if I was to knock up a few basic “Hello World” projects and a couple of tutorials whether this would help those who have always wanted but not yet found the time.

I can do the same for vb.net if interested.

Simple yays will do

DT.

STEP2000 · 9 March 2005 14:41

I have a similar set sitting in a FMS Codetools product. It comes with tons of code, and then you can add to it…great tool…I have over 6 MB of text/code in this tool.

It’s nice to just have it around…sometimes I forget the simple stuff…so DT if you’re going to have a sticky…let me know I can add also to it… VBA/VBX/Access/VB/.NET I’ve got it…also I’m a MS Partner so I have MSDN like everything…

ike · 9 March 2005 19:35

yay

jontyc · 16 March 2005 15:44

aye

DoubleTop · 16 March 2005 16:23

I best start sorting it all out then :eek:

DT.

STEP2000 · 22 March 2005 02:03

DT…got lots of code sitting for you…when is the sticky coming and how can I add to it when you get it up and running? Thanks!

DoubleTop · 22 March 2005 09:11

it’ll be a while, probably over the easter weekend, I’ve been given a deadline thats about four days earlier than when I reckon I can complete :eek:

Plus it sounds like your a lot more organised than me !!! If you have the time knock up a starter and I’ll sticky it

DT.

STEP2000 · 22 March 2005 17:04

’ Class : CCommandArgs
’ Description : Command Line parser
’ Source : STEP2000

Private Type typStringParseTokens
Key As String
Value As String
End Type

Private m_strTestString As String
Private m_strDelim As String
Private m_intCount As Integer

Private maTokens() As typStringParseTokens

Public Property Get Count() As Integer
’ Returns: Count of the number of key/value pairs found
’ Source: STEP2000

Count = m_intCount

End Property

Public Property Get Delim() As String
’ Returns: current value of the Delim property
’ Source: STEP2000
Delim = m_strDelim

End Property

Public Property Let Delim(ByVal strValue As String)
’ strValue: the character to use to delimit keys from values
’ Source: STEP2000

m_strDelim = strValue

End Property

Public Property Get Item(varIndex As Variant) As String
’ Returns: if varIndex is numeric, use the index value.
’ If it is a string, use the key value
’ Source: STEP2000

Dim intCounter As Integer

On Error GoTo PROC_ERR

’ If the user specifies a number, use it as an index to
’ find the corresponding item
If IsNumeric(varIndex) Then
If varIndex > 0 And varIndex <= m_intCount Then
Item = maTokens(varIndex).Value
End If
Else

' If the user specifies a non-numeric value, search the
' collection serially to find a match
For intCounter = 1 To m_intCount
  If StrComp(maTokens(intCounter).Key, varIndex, vbTextCompare) = 0 Then
    Item = maTokens(intCounter).Value
    Exit For
  End If
Next intCounter

End If

PROC_EXIT:
Exit Property

PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
“Item”
Resume PROC_EXIT

End Property

Public Property Get Key(intIndex As Integer) As String
’ Returns: the value of the key at the specified index
’ value. For example if the value of intIndex
’ is 0, the value of the first key is returned
’ Source: STEP2000
’
Key = maTokens(intIndex).Key

End Property

Public Property Get TestString() As String
’ Returns: current value of the TestString property
’ Source: STEP2000

TestString = m_strTestString

End Property

Public Property Let TestString(ByVal strValue As String)
’ strValue: The command line or other string to test
’ Source: STEP2000

m_strTestString = strValue

End Property

Public Property Get Value(intIndex As Integer) As String
’ Returns: the value at the specified index
’ location. For example if intIndex
’ is 0, the first value is returned
’ Source: STEP2000

Value = maTokens(intIndex).Value

End Property

Public Sub Parse()
’ Comments : Parses the current value of the TestString property
’ Parameters: none
’ Returns : nothing
’ Source : STEP2000
’
Dim intCurPos As Integer
Dim intPosFound As Integer
Dim intNextPos As Integer
Dim strItem As String
Dim strTest As String
Dim intDelimLen As Integer
Dim fDone As Boolean

On Error GoTo PROC_ERR

’ if either the Delim property or the TestString property
’ has not been set, do not continue
If m_strDelim = “” Then
GoTo PROC_EXIT
End If

If m_strTestString = “” Then
GoTo PROC_EXIT
End If

’ prepare the token array
Erase maTokens

m_intCount = 0
intCurPos = 1
fDone = False

’ iterate across the test string, breaking it out into key/value
’ pairs based on the occurrence of the Delim character
Do Until fDone

strItem = ""

' find occurrence of delimiter in remaining portion of string
intPosFound = _
  InStr(intCurPos, m_strTestString, m_strDelim, vbTextCompare)

If intPosFound Then
  intCurPos = intPosFound
  intNextPos = _
    InStr(intCurPos + 1, m_strTestString, m_strDelim, vbTextCompare)
  
  ' test for another occurence of the delim
  If intNextPos Then
    strItem = Mid$(m_strTestString, intCurPos, intNextPos - intCurPos)
    intCurPos = intNextPos
  Else
    strItem = Mid$(m_strTestString, intCurPos)
    fDone = True
  End If
  
Else
  ' no delimiter found in remainder of string
  fDone = True
End If

' break the key/value string into parts and store in array
If strItem &lt;&gt; "" Then
  m_intCount = m_intCount + 1
  
  ReDim Preserve maTokens(m_intCount)
  
  intDelimLen = Len(m_strDelim)
  intPosFound = InStr(intDelimLen + 1, strItem & " ", " ")
  
  'get key portion
  strTest = _
    Trim$(Mid$(strItem, intDelimLen + 1, intPosFound - intDelimLen))
  maTokens(m_intCount).Key = strTest
  
  'get value portion. If missing repeat the key portion
  strTest = Trim$(Mid$(strItem, intPosFound + 1))
  If strTest = "" Then
    strTest = maTokens(m_intCount).Key
  End If
  
  maTokens(m_intCount).Value = strTest
  
End If

Loop

PROC_EXIT:
Exit Sub

PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
“Parse”
Resume PROC_EXIT

End Sub

OK Now for some Examples using this Code

’ Example code for the CCommandArgs class
’
’ To try this example, do the following:
’ 1. Create a new form
’ 2. Create a text box called ‘txtTestString’
’ 3. Create a text box called ‘txtSearch’
’ 4. Create a command button called ‘cmdParse’
’ 5. Create a command button called ‘cmdSearch’
’ 6. Paste all the code from this example to the new form’s module
’ 7. Run the form. Press the cmdParse button to parse the
’ command line contained in the txtTestString text box
’ 8. Press the cmdSearch button to search for a particular key value

’ In the Declarations section of the form declare the variable
Private mStartString As CCommandArgs

Private Sub Form_Load()
’ Instantiate the variable, and set any desired properties
Set mStartString = New CCommandArgs
mStartString.Delim = “/”

’ Provide a sample test string to parse
txtTestString = “/Name Smith /Pwd My Password /Title Supervisor”

’ Provide a sample word to search for
txtSearch = “Pwd”

End Sub

Private Sub cmdParse_Click()
’ Parse out the input string contained in the “txtTestString” text box.
’ Display each item in a message box

Dim intCounter As Integer

If txtTestString <> “” Then

' Assign the string to test
mStartString.TestString = txtTestString

' Parse the test string
mStartString.Parse
  
' Loop through each item, and display the key and value found
For intCounter = 1 To mStartString.Count
  MsgBox "Key: " & mStartString.Key(intCounter) & vbCrLf & _
         "Value: " & mStartString.Value(intCounter)
  
Next intCounter

End If

End Sub

Private Sub cmdSearch_Click()
’ Display the Item corresponding to the key indicated in the txtSearch text box

MsgBox mStartString.Item(txtSearch.Text)

End Sub

STEP2000 · 25 March 2005 15:37

Public Sub StartWord(Optional fVisible As Boolean = True)
’ Comments : Starts an instance of Word
’ Parameters: fVisible - Set to False to hide the Word application
’ Returns : Nothing
’ Source : STEP2000 ’
On Error GoTo PROC_ERR

’ Instantiate Word with the New command
Set m_appWord = New Word.Application

’ Set the visible property of Word according to the method’s argument
m_appWord.Visible = fVisible

>>>>Excel<<<<
Set m_objExcel = New Excel.Application
m_objExcel.Visible = fVisible

PROC_EXIT:
Exit Sub

PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
“StartWord”
Resume PROC_EXIT

End Sub

Ok Now use:

’ Start the instance of Excel
Dim ExcelTest As CExcel2000
Set ExcelTest = New CExcel2000
ExcelTest.StartExcel (True) in your Code

Or for Word:
Dim WordTest As CWord2000
’ Instantiate the class
Set WordTest = New CWord2000
WordTest.StartWord True

You can do lots of other things like :

’ Create a new document and save it (leaving it open)
WordTest.NewDocument cstrTempDoc1, “Arial”, 8

’ Create a new worksheet
ExcelTest.CreateWorkbook cstrTempFile1

’ Print the workbook
ExcelTest.PrintSheet 1, 1, 1, False, False, False

The list is long for this process…little code can do lots!

STEP2000 · 3 May 2005 15:19

Object Code:
Private Declare Function OpenClipboard _
Lib “USER32” _
(ByVal hwnd As Long) _
As Long

Private Declare Function WinGetClipboardData _
Lib “USER32” _
Alias “GetClipboardData” _
(ByVal wFormat As Long) _
As Long

Private Declare Function GlobalAlloc _
Lib “kernel32” _
(ByVal wFlags As Long, _
ByVal dwBytes As Long) _
As Long

Private Declare Function GlobalLock _
Lib “kernel32” _
(ByVal hMem As Long) _
As Long

Private Declare Function lstrCopy _
Lib “kernel32” _
Alias “lstrcpyA” _
(ByVal lpString1 As Any, _
ByVal lpString2 As Any) _
As Long

Private Declare Function GlobalUnlock _
Lib “kernel32” _
(ByVal hMem As Long) _
As Long

Private Declare Function CloseClipboard _
Lib “USER32” () _
As Long

Private Declare Function WinSetClipboardData _
Lib “USER32” _
Alias “SetClipboardData” _
(ByVal wFormat As Long, _
ByVal hMem As Long) _
As Long

Private Declare Function EmptyClipBoard _
Lib “USER32” _
Alias “EmptyClipboard” () _
As Long

Private Const GHND = &H42
Private Const CF_TEXT = 1
Private Const mcintMaxSize As Integer = 4096

Public Sub ClearClipboardData()
’ Comments : Clears the clipboard
’ Parameters: None
’ Returns : Nothing
’ Source : Total Visual SourceBook 2000
’
Dim lngTmp As Long

On Error GoTo PROC_ERR

If OpenClipboard(0&) <> 0 Then

' Clear the Clipboard.
lngTmp = EmptyClipBoard()

lngTmp = CloseClipboard()

End If

PROC_EXIT:
Exit Sub

PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
“ClearClipboardData”
Resume PROC_EXIT

End Sub

Public Function GetClipboardData() As String
’ Comments : Returns the text contents of the clipboard
’ Parameters: None
’ Returns : String
’ Source : Total Visual SourceBook 2000
’
Dim lngClipMemory As Long
Dim lngHandle As Long
Dim strTmp As String
Dim lngTmp As Long

On Error GoTo PROC_ERR

If OpenClipboard(0&) <> 0 Then

' Get handle to global memory holding clipboard text
lngHandle = WinGetClipboardData(CF_TEXT)
  
' Could we allocate the memory?
If lngHandle &lt;&gt; 0 Then
  
  ' Lock memory so we can get the string
  lngClipMemory = GlobalLock(lngHandle)
 
   ' If we could lock it
   strTmp = Space$(mcintMaxSize)
   lngTmp = lstrCopy(strTmp, lngClipMemory)
   lngTmp = GlobalUnlock(lngHandle)

   ' Strip off any nulls and trim the result
   strTmp = Left$(strTmp, InStr(strTmp, Chr(0)) - 1)
   
End If

lngTmp = CloseClipboard()

End If

GetClipboardData = strTmp

PROC_EXIT:
Exit Function

PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
“GetClipboardData”
Resume PROC_EXIT

End Function

Public Sub SetClipboardData(strText As String)
’ Comments : Writes the supplied string to the clipboard
’ Parameters: strText - text to write
’ Returns : Nothing
’ Source : Total Visual SourceBook 2000
’
Dim lngHoldMem As Long
Dim lngGlobalMem As Long
Dim lngClipMem As Long
Dim lngTmp As Long

On Error GoTo PROC_ERR

’ Allocate moveable global memory.
lngHoldMem = GlobalAlloc(GHND, LenB(strText) + 1)

’ Lock the block to get a far pointer to this memory.
lngGlobalMem = GlobalLock(lngHoldMem)

’ Copy the string to this global memory.
lngGlobalMem = lstrCopy(lngGlobalMem, strText)

’ Unlock the memory.
If GlobalUnlock(lngHoldMem) = 0 Then

' Open the Clipboard to copy data to.
If OpenClipboard(0&) &lt;&gt; 0 Then

  ' Clear the Clipboard.
  lngTmp = EmptyClipBoard()

  ' Copy the data to the Clipboard.
  lngClipMem = WinSetClipboardData(CF_TEXT, lngHoldMem)

  lngTmp = CloseClipboard()
End If

End If

PROC_EXIT:
Exit Sub

PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
“SetClipboardData”
Resume PROC_EXIT

End Sub

Example Code to Call Object:

Private Sub cmdTest_Click()
’ This procedure shows how to use the modClipboard class.
Dim strTest As String

’ Put a string of text onto the clipboard
Debug.Print “Putting text on the clipboard”
SetClipboardData “This is a test”

’ Get the text
strTest = GetClipboardData()
Debug.Print "Clipboard is: " & strTest

’ Clear the clipboard
Debug.Print “Emptying the clipboard…”
ClearClipboardData
Debug.Print "Clipboard is: " & GetClipboardData()

End Sub

STEP2000 · 3 May 2005 15:40

Private Declare Sub GetSystemInfo _
Lib “kernel32” _
(lpSystemInfo As SYSTEM_INFO)

Private Declare Function IsProcessorFeaturePresent _
Lib “kernel32” _
(ByVal ProcessorFeature As Long) _
As Long

Private Declare Function GetSystemMetrics _
Lib “user32” _
(ByVal nIndex As Long) _
As Long

Private Type SYSTEM_INFO
wProcessorArchitecture As Integer
wReserved As Integer
dwPageSize As Long
lpMinimumApplicationAddress As Long
lpMaximumApplicationAddress As Long
dwActiveProcessorMask As Long
dwNumberOfProcessors As Long
dwProcessorType As Long
dwAllocationGranularity As Long
wProcessorLevel As Integer
wProcessorRevision As Integer
End Type

Private Const SM_SLOWMACHINE = 73

Private Const PF_FLOATING_POINT_PRECISION_ERRATA = 0
Private Const PF_FLOATING_POINT_EMULATED = 1
Private Const PF_COMPARE_EXCHANGE_DOUBLE = 2
Private Const PF_MMX_INSTRUCTIONS_AVAILABLE = 3

Public Enum EnumProcessorType
cmiIntel386 = 386
cmiIntel486 = 486
cmiIntelPENTIUM = 586
cmiMIPSR4000 = 4000
cmiALPHA21064 = 21064
End Enum

Public Enum EnumProcessorArchitecture
cmiIntel = 0
cmiMIPS = 1
cmiALPHA = 2
cmiPPC = 3
cmiUnknown = &HFFFF
End Enum

Property Get ActiveProcessorMask() As Long
’ Returns : The active processors in the system
’ Source: STEP2000
Dim si As SYSTEM_INFO

On Error GoTo PROC_ERR

GetSystemInfo si

ActiveProcessorMask = si.dwActiveProcessorMask

PROC_EXIT:
Exit Property

PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
“ActiveProcessorMask”
Resume PROC_EXIT

End Property

Property Get AllocationGranularity() As Long
’ Returns : The granularity with which virtual memory is allocated.
’ Source: STEP2000
Dim si As SYSTEM_INFO

On Error GoTo PROC_ERR

GetSystemInfo si

AllocationGranularity = si.dwAllocationGranularity

PROC_EXIT:
Exit Property

PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
“AllocationGranularity”
Resume PROC_EXIT

End Property

Property Get CompareExchangeDouble() As Boolean
’ Returns : True if the compare and exchange double operation is available
’ False if it is not
’ Source: STEP2000

On Error GoTo PROC_ERR

CompareExchangeDouble = _
IsProcessorFeaturePresent(PF_COMPARE_EXCHANGE_DOUBLE)

PROC_EXIT:
Exit Property

PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
“CompareExchangeDouble”
Resume PROC_EXIT

End Property

Property Get FloatingPointEmulated() As Boolean
’ Returns : True if floating point emulation is used, False if it is not
’ Source: STEP2000
’
On Error GoTo PROC_ERR

FloatingPointEmulated = _
IsProcessorFeaturePresent(PF_FLOATING_POINT_EMULATED)

PROC_EXIT:
Exit Property

PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
“FloatingPointEmulated”
Resume PROC_EXIT

End Property

Property Get FloatingPointError() As Boolean
’ Returns : True if the pentium floating point bug exists in this processor
’ False if it does not
’ Source: STEP2000
’
On Error GoTo PROC_ERR

FloatingPointError = _
IsProcessorFeaturePresent(PF_FLOATING_POINT_PRECISION_ERRATA)

PROC_EXIT:
Exit Property

PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
“FloatingPointError”
Resume PROC_EXIT

End Property

Property Get LowMemory() As Boolean
’ Returns : True if the computer is considered a low memory machine, False
’ if it is not
’ Source: STEP2000
On Error GoTo PROC_ERR

’ The following flags are defined for the return value of the
’ GetSystemMetrics(SM_SLOWMACHINE) function
’
’ &H0001 - CPU is a 386
’ &H0002 - low memory machine (less than 5 megabytes)
’ &H0004 - slow (non-accelerated) display card

LowMemory = (GetSystemMetrics(SM_SLOWMACHINE) And 2) > 0

PROC_EXIT:
Exit Property

PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
“LowMemory”
Resume PROC_EXIT

End Property

Property Get MaxAppAddress() As Long
’ Returns : the highest memory address accessible to applications and DLLs.
’ Source: STEP2000
Dim si As SYSTEM_INFO

On Error GoTo PROC_ERR

GetSystemInfo si

MaxAppAddress = si.lpMaximumApplicationAddress

PROC_EXIT:
Exit Property

PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
“MaxAppAddress”
Resume PROC_EXIT

End Property

Property Get MinAppAddress() As Long
’ Returns : the lowest memory address accessible to applications and DLLs.
’ Source: STEP2000
Dim si As SYSTEM_INFO

On Error GoTo PROC_ERR

GetSystemInfo si

MinAppAddress = si.lpMinimumApplicationAddress

PROC_EXIT:
Exit Property

PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
“MinAppAddress”
Resume PROC_EXIT

End Property

Property Get MMXAvailable() As Boolean
’ Returns : True if the processor supports MMX, False if it does not
’ Source: STEP2000
On Error GoTo PROC_ERR

MMXAvailable = _
IsProcessorFeaturePresent(PF_MMX_INSTRUCTIONS_AVAILABLE)

PROC_EXIT:
Exit Property

PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
“MMXAvailable”
Resume PROC_EXIT

End Property

Property Get NumberOfProcessors() As Long
’ Returns : The number of processors in the system
’ Source: STEP2000
Dim si As SYSTEM_INFO

On Error GoTo PROC_ERR

GetSystemInfo si

NumberOfProcessors = si.dwNumberOfProcessors

PROC_EXIT:
Exit Property

PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
“NumberOfProcessors”
Resume PROC_EXIT

End Property

Property Get PageSize() As Long
’ Returns : Indicate the page size.
’ Source: STEP2000
’
Dim si As SYSTEM_INFO

On Error GoTo PROC_ERR

GetSystemInfo si

PageSize = si.dwPageSize

PROC_EXIT:
Exit Property

PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
“PageSize”
Resume PROC_EXIT

End Property

Property Get ProcessorArchitecture() As EnumProcessorArchitecture
’ Returns : The processor architecture
’ Source: STEP2000
Dim si As SYSTEM_INFO

On Error GoTo PROC_ERR

GetSystemInfo si

ProcessorArchitecture = si.wProcessorArchitecture

PROC_EXIT:
Exit Property

PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
“ProcessorArchitecture”
Resume PROC_EXIT

End Property

Property Get ProcessorLevel() As Long
’ Returns : The system’s architecture-dependent processor level
’ Source: STEP2000
Dim si As SYSTEM_INFO

On Error GoTo PROC_ERR

GetSystemInfo si

ProcessorLevel = si.wProcessorLevel

PROC_EXIT:
Exit Property

PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
“ProcessorLevel”
Resume PROC_EXIT

End Property

Property Get ProcessorRevision() As Long
’ Returns : The architecture-dependent processor revision.
’ Source: STEP2000
Dim si As SYSTEM_INFO

On Error GoTo PROC_ERR

GetSystemInfo si

ProcessorRevision = si.wProcessorRevision

PROC_EXIT:
Exit Property

PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
“ProcessorRevision”
Resume PROC_EXIT

End Property

Property Get ProcessorType() As EnumProcessorType
’ Returns : The processor type
’ Source: STEP2000
Dim si As SYSTEM_INFO

On Error GoTo PROC_ERR

GetSystemInfo si

ProcessorType = si.dwProcessorType

PROC_EXIT:
Exit Property

PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
“ProcessorType”
Resume PROC_EXIT

End Property

Property Get SlowGraphics() As Boolean
’ Returns : True if the graphics are considered slow, False if they are not
’ Source: STEP2000
On Error GoTo PROC_ERR

’ The following flags are defined for the return value of the
’ GetSystemMetrics(SM_SLOWMACHINE) function
’
’ &H0001 - CPU is a 386
’ &H0002 - low memory machine (less than 5 megabytes)
’ &H0004 - slow (non-accelerated) display card

SlowGraphics = (GetSystemMetrics(SM_SLOWMACHINE) And 4) > 0

PROC_EXIT:
Exit Property

PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
“SlowGraphics”
Resume PROC_EXIT

End Property

Property Get SlowMachine() As Boolean
’ Returns : True if the computer is considered a slow machine, False if it
’ is not
’ Source: STEP2000
On Error GoTo PROC_ERR

’ The following flags are defined for the return value of the
’ GetSystemMetrics(SM_SLOWMACHINE) function
’
’ &H0001 - CPU is a 386
’ &H0002 - low memory machine (less than 5 megabytes)
’ &H0004 - slow (non-accelerated) display card

SlowMachine = (GetSystemMetrics(SM_SLOWMACHINE) And 1) > 0

PROC_EXIT:
Exit Property

PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
“SlowMachine”
Resume PROC_EXIT

End Property

STEP2000 · 3 May 2005 15:42

Calling the Object:

Private Sub cmdTest_Click()
Dim ComputerInfo As CComputerInfo

Set ComputerInfo = New CComputerInfo

’ Print the value of each property
Debug.Print "ActiveProcessorMask = " & ComputerInfo.ActiveProcessorMask
Debug.Print "AllocationGranularity = " & ComputerInfo.AllocationGranularity
Debug.Print "CompareExchangeDouble = " & ComputerInfo.CompareExchangeDouble
Debug.Print "FloatingPointEmulated = " & ComputerInfo.FloatingPointEmulated
Debug.Print "FloatingPointError = " & ComputerInfo.FloatingPointError
Debug.Print "LowMemory = " & ComputerInfo.LowMemory
Debug.Print "MaxAppAddress = " & ComputerInfo.MaxAppAddress
Debug.Print "MinAppAddress = " & ComputerInfo.MinAppAddress
Debug.Print "MMXAvailable = " & ComputerInfo.MMXAvailable
Debug.Print "NumberOfProcessors = " & ComputerInfo.NumberOfProcessors
Debug.Print "PageSize = " & ComputerInfo.PageSize

Select Case ComputerInfo.ProcessorArchitecture
Case cmiIntel
Debug.Print “Intel processor”
Case cmiMIPS
Debug.Print “MIPS processor”
Case cmiALPHA
Debug.Print “Alpha processor”
Case cmiPPC
Debug.Print “Power PC processor”
Case cmiUnknown
Debug.Print “Unknown processor”
End Select

Debug.Print "ProcessorLevel = " & ComputerInfo.ProcessorLevel
Debug.Print "ProcessorRevision = " & ComputerInfo.ProcessorRevision

Select Case ComputerInfo.ProcessorType
Case cmiIntel386
Debug.Print “Intel 386”
Case cmiIntel486
Debug.Print “Intel 486”
Case cmiIntelPENTIUM
Debug.Print “Intel Pentium”
Case cmiMIPSR4000
Debug.Print “MIPS R4000”
Case cmiALPHA21064
Debug.Print “Alpha 21064”
End Select

Debug.Print "SlowGraphics = " & ComputerInfo.SlowGraphics
Debug.Print "SlowMachine = " & ComputerInfo.SlowMachine

Set ComputerInfo = Nothing
End Sub

abonghit · 13 March 2007 01:28

Ok Now use:

’ Start the instance of Excel
Dim ExcelTest As CExcel2000
Set ExcelTest = New CExcel2000
ExcelTest.StartExcel (True) in your Code

Or for Word:
Dim WordTest As CWord2000
’ Instantiate the class
Set WordTest = New CWord2000
WordTest.StartWord True

You can do lots of other things like :

’ Create a new document and save it (leaving it open)
WordTest.NewDocument cstrTempDoc1, “Arial”, 8

’ Create a new worksheet
ExcelTest.CreateWorkbook cstrTempFile1

’ Print the workbook
ExcelTest.PrintSheet 1, 1, 1, False, False, False

The list is long for this process…little code can do lots!

Do you have the code for the CWord2000 and CExcel2000 class modules (from Total Visual Sourcebook, I think)? Or any other code from it for that matter?

STEP2000 · 14 March 2007 15:30

I would go to www.FMSINC.COM and check out code tools for yourself.

Excellent tool, and worth the $. I have added to my dataset about 500 other code related snipets. It’s like visual studio source safe…just cheaper, and well comes with lots of starters. Many of the code items used in the FMS are from MS but tweaked a little…

Good luck building your library.

STEP2000 · 26 April 2009 17:38

Ok this sometimes gets passed over by many, but here is a little help.
Dim sSQL, VALUE1 as String
Dim Rst as Recordset
Dim dbs as Database
Dim Workspace As Workspace
VALUE1 = “TEXT”

Set Workspace = Workspaces(0)
Set dbs = Workspace.OpenDatabase(“c:\YOUR DATABASE”, , False)
Set Rst = dbs.OpenRecordset(sSQL, dbOpenSnapshot)
sSQL = "Select * from TABLENAME Where TABLENAME.REF Like " & Chr(34) & (Either other recordset pointer or VALUE1) & Chr(34)

The key is the CHR(34) " wrapper on either side of the Value you are search for.

Just a quick how to from I to you…

system · 29 May 2009 14:08

’ Class : CCommandArgs
’ Description : Command Line parser
’ Source : STEP2000

Private Type typStringParseTokens
Key As String
Value As String
End Type

Private m_strTestString As String
Private m_strDelim As String
Private m_intCount As Integer

Private maTokens() As typStringParseTokens

Public Property Get Count() As Integer
’ Returns: Count of the number of key/value pairs found
’ Source: STEP2000

Count = m_intCount

End Property

Public Property Get Delim() As String
’ Returns: current value of the Delim property
’ Source: STEP2000
Delim = m_strDelim

End Property

Public Property Let Delim(ByVal strValue As String)
’ strValue: the character to use to delimit keys from values
’ Source: STEP2000

m_strDelim = strValue

End Property

Public Property Get Item(varIndex As Variant) As String
’ Returns: if varIndex is numeric, use the index value.
’ If it is a string, use the key value
’ Source: STEP2000

Dim intCounter As Integer

On Error GoTo PROC_ERR

’ If the user specifies a number, use it as an index to
’ find the corresponding item
If IsNumeric(varIndex) Then
If varIndex > 0 And varIndex <= m_intCount Then
Item = maTokens(varIndex).Value
End If
Else

’ If the user specifies a non-numeric value, search the
’ collection serially to find a match
For intCounter = 1 To m_intCount
If StrComp(maTokens(intCounter).Key, varIndex, vbTextCompare) = 0 Then
Item = maTokens(intCounter).Value
Exit For
End If
Next intCounter

End If

PROC_EXIT:
Exit Property

PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
“Item”
Resume PROC_EXIT

End Property

Public Property Get Key(intIndex As Integer) As String
’ Returns: the value of the key at the specified index
’ value. For example if the value of intIndex
’ is 0, the value of the first key is returned
’ Source: STEP2000
’
Key = maTokens(intIndex).Key

End Property
Start the instance of Excel
Dim ExcelTest As CExcel2000
Set ExcelTest = New CExcel2000
ExcelTest.StartExcel (True) in your Code

Or for Word:
Dim WordTest As CWord2000
’ Instantiate the class
Set WordTest = New CWord2000
WordTest.StartWord True

You can do lots of other things like :

’ Create a new document and save it (leaving it open)
WordTest.NewDocument cstrTempDoc1, “Arial”, 8

’ Create a new worksheet
ExcelTest.CreateWorkbook cstrTempFile1

’ Print the workbook
ExcelTest.PrintSheet 1, 1, 1, False, False, False

The list is long for this process…little code can do lots!

sports nutrition
raid data recovery

STEP2000 · 9 September 2009 16:49

BCC Code in VB (Check Digit)

Dim BCC, strCommand as String
Dim i as Long 'Or Int if smaller number set
'strCommand is the inbound String to BCC/XOR
'BCC will be the check digit value once completed

For i = 1 To Len(strCommand)
BCC = BCC Xor Asc(Mid(strCommand, i, 1))
Next

'Many times the BCC needs to be converted to a CHR so ’ CHR(BCC) handles that.

Ok back to regular scheduled show…

STEP2000 · 6 November 2009 22:17

Numbering Code for WORDS - Taken from my account software.

Static Function NumWord(ByVal AmountPassed As Currency) As String

'** Convert a number to words for filling in the Amount of a check
'** Example: NumWord(120.45) returns ONE HUNDRED TWENTY AND 45/100
'** Can handle numbers from 0 to $999,999.99
'** Created by Greg (STEP2000)
'** 

'** The array below, and other variables, are dimensioned
'** in the Declarations section.
If ErrorTrapping Then
On Error GoTo NumWord_Err
End If

Dim msg As String
'** Fill EngNum array, if it's not filled already)
If Not EngNum(1) = "One" Then
    EngNum(0) = ""
    EngNum(1) = "One"
    EngNum(2) = "Two"
    EngNum(3) = "Three"
    EngNum(4) = "Four"
    EngNum(5) = "Five"
    EngNum(6) = "Six"
    EngNum(7) = "Seven"
    EngNum(8) = "Eight"
    EngNum(9) = "Nine"
    EngNum(10) = "Ten"
    EngNum(11) = "Eleven"
    EngNum(12) = "Twelve"
    EngNum(13) = "Thirteen"
    EngNum(14) = "Fourteen"
    EngNum(15) = "Fifteen"
    EngNum(16) = "Sixteen"
    EngNum(17) = "Seventeen"
    EngNum(18) = "Eighteen"
    EngNum(19) = "Nineteen"
    EngNum(20) = "Twenty"
    EngNum(30) = "Thirty"
    EngNum(40) = "Forty"
    EngNum(50) = "Fifty"
    EngNum(60) = "Sixty"
    EngNum(70) = "Seventy"
    EngNum(80) = "Eighty"
    EngNum(90) = "Ninety"
End If


'** Convert incoming Currency value to a string for parsing.
StringNum = Format$(AmountPassed, "000000.00")

'** Initialize other variables
English = ""
LoopCount = 1
StartVal = 1
Pennies = Mid$(StringNum, 8, 2)

'** Just in case the check is for less than a buck...
If AmountPassed &lt; 1 Then
    English = "Zero"
End If

'** Now do each 3-digit section of number.
While LoopCount &lt;= 2
    Chunk = Mid$(StringNum, StartVal, 3)
    Hundreds = Val(Mid$(Chunk, 1, 1))
    Tens = Val(Mid$(Chunk, 2, 2))
    Ones = Val(Mid$(Chunk, 3, 1))

    '** Do the hundreds portion of 3-digit number
    If Val(Chunk) &gt; 99 Then
        English = English & EngNum(Hundreds) & " Hundred "
    End If

    '** Do the tens & ones portion of 3-digit number
    TensDone = False

    '** Is it less than 10?
    If Tens &lt; 10 Then
        English = English & " " & EngNum(Ones)
        TensDone = True
    End If

    '** Is it a teen?
    If (Tens &gt;= 11 And Tens &lt;= 19) Then
        English = English & EngNum(Tens)
        TensDone = True
    End If

    '** Is it Evenly Divisible by 10?
    If (Tens / 10#) = Int(Tens / 10#) Then
       English = English & EngNum(Tens)
       TensDone = True
    End If

    '** Or is it none of the above?
    If Not TensDone Then
        English = English & EngNum((Int(Tens / 10)) * 10)
        English = English & " " & EngNum(Ones)
    End If

    '** Add the word "thousand" if necessary.
    If AmountPassed &gt; 999.99 And LoopCount = 1 Then
        English = English + " Thousand "
    End If

    '** Do pass through second three digits
    LoopCount = LoopCount + 1
    StartVal = 4
Wend
'** Done: Return english with pennies tacked on.
NumWord = Trim(English) & " and " & Pennies & "/100"
Exit Function

NumWord_Err:
msg = "Error is " & Error$ & Chr(13) & Chr(10) & “In NumWord()” & Chr(13) & Chr(10) & CPBSMSG
MsgBox msg, 16, “Application Error”
Exit Function

End Function