Results 1 to 2 of 2
  1. #1
    Join Date
    Feb 2004
    Location
    Irving, TX (Dallas, Fort Worth)
    Posts
    379

    Unanswered: Tricks - Optimization 2

    Since the board is screwed y'day and today I'll add my posts here:

    This is the optimized code for WORDPOS:

    Code:
    Public Function WordPos(ByVal sSource As String, sTarget As String) As Integer
      	Dim n As Integer
      	WordPos = 0
      	If InStr(1, sSource, sTarget) > 0 Then
      		For n = 1 To Words(sSource)
      			If Word(sSource, n) = sTarget Then
      				WordPos = n
      				Exit For
      			End If
      		Next n
      	End If
      End Function
    You'll have to have the code for WORD and WORDS from thread:

    http://www.dbforums.com/t1177520.html

    for this to work. This is not possible today as board is hosed and error occur on trying to access it.

    DBS4M
    Last edited by dbsupport4me; 09-21-05 at 15:15.

  2. #2
    Join Date
    Feb 2004
    Location
    Irving, TX (Dallas, Fort Worth)
    Posts
    379

    Repost

    Since the old thread is no longer viewable, due to problems on the board, I'm reposting the code.

    Code:
     Function JulDat(TheDate As Date) As Integer
     	JulDat = DateDiff("d", ("12-31-" & Year(TheDate) - 1), TheDate)
     End Function
     
     
     Function FixLine(MyLine As String) As String
     	FixLine = Replace(MyLine, "'", "`")
     End Function
     
     
     Function Words(sWord As String) As Integer
     	' Find the Words in the input string <MyWLine> whether
     	' Blank <" ">, Comma <","> or Blank+Comma <", "> seperated
     	Dim bCount As Integer, cCount As Integer, bcCount As Integer
     	Words = 0
     	If Len(sWord) = 0 Then Exit Function
     	Words = 1
     	bCount = UBound(Split(sWord, " ")) + 1
     	cCount = UBound(Split(sWord, ",")) + 1
     	bcCount = UBound(Split(sWord, ", ")) + 1
     	If bcCount > 1 Then
     		Words = bcCount
     	ElseIf bCount > 1 Then
     		Words = bCount
     	ElseIf cCount > 1 Then
     		Words = cCount
     	End If
     End Function
     
     
     Function Word(MyWLine As String, MyIdx As Integer) As String
     	' Find the nth <MyIdx> Word in the input string <MyWLine>
     	Dim MyArr1() As String, MyArr2() As String, MyArr3() As String
     	Word = MyWLine
     	If Len(MyWLine) > 0 Then
     		MyArr1 = Split(MyWLine, " ")
     		MyArr2 = Split(MyWLine, ",")
     		MyArr3 = Split(MyWLine, ", ")
     		If MyArr3(0) <> MyWLine Then
     			Word = MyArr3(MyIdx - 1)
     		ElseIf MyArr1(0) <> MyWLine Then
     			Word = MyArr1(MyIdx - 1)
     		ElseIf MyArr2(0) <> MyWLine Then
     			Word = MyArr2(MyIdx - 1)
     		End If
     	End If
     End Function
     
     
     Function PrsCnt(MyWLine As String, MyChar As String) As Integer
     	' Find the Words in the input string <MyWLine> when seperated by character <MyChar>
     	Dim pCount As Integer
     	PrsCnt = 0
     	If Len(MyWLine) = 0 Then Exit Function
     	PrsCnt = 1
     	pCount = UBound(Split(MyWLine, MyChar)) + 1
     	If pCount > 1 Then
     		PrsCnt = pCount
     	End If
     End Function
     
     
     Function PrsLin(MyWLine As String, MyIdx As Integer, MyChar As String) As String
     	' Find the nth <MyIdx> Word in the input string <MyWLine>
     	Dim MyArr() As String
     	PrsLin = MyWLine
     	If Len(MyWLine) > 0 Then
     		MyArr = Split(MyWLine, MyChar)
     		If MyArr(0) <> MyWLine Then
     			PrsLin = MyArr(MyIdx - 1)
     		End If
     	End If
     End Function
     
     
     Function DoesTblExist(strTblName As String) As Boolean
     	On Error GoTo Err_Set
     	Dim db As DAO.Database, SQLstr As String
     	Set db = CurrentDb
     	SQLstr = "SELECT * from MSysObjects WHERE ([Name]='" & strTblName & "');"
     	Set RCs2 = db.OpenRecordset(SQLstr)
     	RCs2.MoveLast
     	If RCs2.RecordCount > 0 And Not IsNull(RCs2.RecordCount) Then
     		DoesTblExist = True
     	End If
     	Exit Function
     
     Err_Set:
     	DoesTblExist = False
     End Function
     
     
     Function delword(sWord As String, dWord As String) As String
     	Dim lStr As String, rStr As String, CurPos As Integer
     	CurPos = InStr(1, sWord, dWord)
     	lStr = Left(sWord, CurPos - 1)
     	rStr = Mid(sWord, CurPos + Len(dWord) + 1)
     	delword = RTrim(lStr & rStr)
     End Function
     
     
     Function delwords(sWord As String, sPos As Integer, Optional nWrds As Integer) As String
     	Dim lStr As String, rStr As String, CurWrd As String, CurPos As Integer, NxtPos As Integer
     	CurWrd = Word(sWord, sPos)
     	CurPos = InStr(1, sWord, CurWrd)
     	lStr = Left(sWord, CurPos + Len(CurWrd))
     	If IsMissing(nWrds) Then
     		delword = RTrim(lStr)
     	Else
     		CurWrd = Word(sWord, sPos + nWrds)
     		CurPos = InStr(1, sWord, CurWrd)
     		rStr = Mid(sWord, CurPos)
     		delword = lStr & rStr
     	End If
     End Function
     
     
     Function MixName(MyName As String) As String
     	Dim DshNum As Integer, BlkNum As Integer, WrdNum As Integer, tmpName As String, n As Integer
     	Dim ChkChr As String, StrStr As String
     	MyName = Strip_Dept(MyName)
     	DshNum = UBound(Split(MyName, "-"))
     	BlkNum = UBound(Split(MyName, " "))
     	If DshNum = 0 And BlkNum = 0 Then
     		MixName = UCase(Left(MyName, 1)) & LCase(Mid(MyName, 2))
     	End If
     	If DshNum > 0 And BlkNum = 0 Then ChkChr = "-"
     	If DshNum = 0 And BlkNum > 0 Then ChkChr = " "
     	WrdNum = PrsCnt(MyName, ChkChr)
     	MixName = ""
     	For n = 1 To WrdNum
     		tmpName = PrsLin(MyName, n, ChkChr)
     		If Len(tmpName) > 1 Then
     		    MixName = Trim(MixName & ChkChr & UCase(Left(tmpName, 1)) & LCase(Mid(tmpName, 2)))
     		Else
     		    MixName = Trim(MixName & ChkChr & UCase(Left(tmpName, 1)))
     		End If
     	Next n
     	If Left(MixName, 1) = "-" Then MixName = Mid(MixName, 2)
     End Function
     
     
     Function WordPos(ByVal sSource As String, sTarget As String) As Integer
     	Dim n As Integer
     	WordPos = 0
     	If InStr(1, sSource, sTarget) > 0 Then
     		For n = 1 To Words(sSource)
     			If Word(sSource, n) = sTarget Then
     				WordPos = n
     				Exit For
     			End If
     		Next n
     	End If
     End Function
    I will list all commands in a later post.

    DBS4M

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •