Useful functions and code fragments

Useful functions and code fragments

Note: For clarity of demonstrating these functions to beginning programmers, I've used "a, b, c, d" for all strings and "x, y, z" for all integers in most of these functions & fragments. When you actually use these, it will generally be more clear to replace all instances of a$, b$, c$, d$, x%, y%, and z% with more descriptive variable names.

Remove x% characters from the right side of a$

Function ChopRight(a$, x%)
  ChopRight = Left(a$, Len(a$) - x%)
End Function

Remove x% characters from the left side of a$

Function ChopLeft(a$, x%)
  ChopLeft = Mid(a$, x% + 1)
End Function

Another way of doing the same thing:

Function ChopLeft(a$, x%)
  ChopLeft = Right(a$, Len(a$) - x%)
End Function

Ensure that the first letter in a$ is uppercase

Function Capitalize(a$)
  If Asc(Left(a$, 1))>=97 And Asc(Left(a$, 1))<=122 Then
    Mid(a$, 1, 1) = UCase(Left(a$, 1))
  End If
  Capitalize = a$
End Function

Another way of doing the same thing:

Function Capitalize(a$)
  If Left(a$, 1) Like "[a-z]" Then
    a$ = UCase(Left(a$, 1)) & Mid(a$, 2)
  End If
  Capitalize = a$
End Function

Split a$ into b$ & c$ after character x%. b$ will contain everything from the first character up to and including the x%th charcter, and c$ will contain everything from the character after the x%th character to the end of a$

Sub Split(a$, x%, b$, c$)
  b$ = Left(a$, x%)
  c$ = Mid(a$, x% + 1) 'could also use: Right(a$, Len(a$) - x%)
End Sub

Find the line number of the first occurrence of a specific tag

  bool=TRUE : cc%=0 : TagNum% = 0
  Do Until bool=FALSE
    cc%=cc%+1
    If cc>999 Then
      MsgBox "Error: macro linecounter is out of control. Exiting..."
      Goto Done
    End If
    bool=CS.GetFieldData( cc%,indata$ )
    If Left(indata$, 4)=Chr(220)+"300" or Left(indata$, 4)=chr(255)+"300" or bool=FALSE Then
      bool=FALSE
      TagNum% = cc%
      '*** Put code that looks at or alters the record here.
      'Use TagNum% to indicate the line number in CS.* commands
    ElseIf Val(Mid(indata$, 2, 3))>300 Then
      Exit Do
    End If
  Loop

Find all occurrences of a specific tag

  bool=TRUE : cc%=0 : TagNum% = 0
  Do Until bool=FALSE
    cc%=cc%+1
    If cc>999 Then
      MsgBox "Error: macro linecounter is out of control. Exiting..."
      Goto Done
    End If
    bool=CS.GetFieldData( cc%,indata$ )
    If Left(indata$, 4) = Chr(220)+"246" or Left(indata$, 4) = Chr(255)+"246" Then 
      TagNum%=cc%
      '*** Put code that looks at or alters the record here.
      'Use TagNum% to indicate the line number in CS.* commands
    ElseIf Val(Mid(indata$, 2, 3)) > 949 Then
      Goto Looper
    End If
  Loop

Iterate through all records from the selected to the end of the list

bool = CS.GetActiveTruncatedList
bool = CS.GetFirstRecord

nextrec = TRUE
Do While nextrec <> FALSE
  bool = CS.GetActiveRecord

'*** Put code that looks at or alters each record here ***

  'If not altering the MARC data of each record, delete this line:
  bool = CS.SaveRecord

  nextrec = CS.GetNextRecord
  If nextrec = FALSE Then Exit Do
Loop

  bool = CS.CloseRecord(TRUE)

Iterate through all selected records only

Note: the lined-out code *should* work, but doesn't due to fatal bugs in the Get###SelectedItem commands.


bool = CS.GetActiveTruncatedList
bool = CS.GetFirstSelectedItem

nextrec = TRUE
Do While nextrec <> FALSE
  bool = CS.GetActiveRecord
  bool = TRUE : cc=0

'*** Put code that looks at or alters each record here ***

  'If not altering the MARC data of each record, delete this line:
  bool = CS.SaveRecord

  nextrec = CS.GetNextSelectedItem
  If nextrec = FALSE Then Exit Do
Loop

bool=CS.CloseRecord(TRUE)

This is a workaround that allows you to edit "selected" records, by first marking them with a unique MyStatus

bool = CS.GetItemType
If bool <> 2 Then
  MsgBox "Not viewing the proper type of list."
  Goto Done
End If

Dim MSArr$(35)
For i = 0 To 25
  MSArr(i) = Chr(i+97)  'sequence of lowercase letters (ASCII 97-122)
Next
For i = 26 To 35
  MSArr(i) = Chr(i+22)  'sequence of digits (ASCII 48-57)
Next
   
Dim NumRecs$(50)
NumRecs$(0)="ALL"
For i = 1 to 50
  NumRecs$(i) = CStr(i)
Next i

Begin Dialog newdlg 187, 100, "Batch Change 'Selected' Records"
   Text  3, 5, 155, 10, "Enter MyStatus code used as selection indicator:"
   DropListBox  159, 3, 25, 150, MSArr(), .MyStatus
   CheckBox  5, 22, 165, 9, "Clear MyStatus of selected records when done", .ClearMS
   Text  7, 55, 174, 28, "If you have not yet given a unique MyStatus for the selected records, click Cancel, do that, then restart the macro."
   OkButton  73, 84, 50, 14
   CancelButton  129, 84, 50, 14
   Text  8, 38, 123, 9, "Maximum number of records to check:"
   DropListBox  132, 37, 27, 159, NumRecs$(), .MaxRecs
End Dialog

Dim MSInfo as newdlg
MSInfo.MyStatus = 12
retval = Dialog(MSInfo)
If retval = 0 Then Goto Done

On Error Resume Next
CS.GetActiveTruncatedList
If Err = 440 Then
  Msgbox "No active list. Exiting..."
  Goto Done
End If
On Error Goto 0
bool = CS.GetFirstRecord
If bool = FALSE then 
  MsgBox "First record could not be opened. Exiting..."
  Goto Done
End If

If MSInfo.MaxRecs = 0 Then k = -1 Else k = 1
nextrec = TRUE
Do While (nextrec = TRUE) and (k <= MSInfo.MaxRecs)
  On Error Resume Next
  CS.GetActiveRecord
  If Err = 440 Then
    Msgbox "Timed out while opening record. Exiting..."
    Goto Done
  End If
  On Error Goto 0
  bool = CS.QueryRecordStatus("my", CurMyStatus$)
  If CurMyStatus = MSArr$(MSInfo.MyStatus) Then
    If MSInfo.ClearMS = 1 Then bool = CS.SetMyStatus(" ")

'***Insert record-altering commands here

  bool = CS.SaveRecord
  End If

  If MSInfo.MaxRecs >0 Then k = k + 1  
  If k <= MSInfo.MaxRecs Then
    nextrec = CS.GetNextRecord
    If nextrec = FALSE Then Exit Do
  End If
Loop

  bool = CS.CloseRecord(TRUE)

Wait for an active record to appear before proceeding. Especially useful after CS.GetFirstRecord, or when programmatically opening a workform, and before any record-specific commands.

Function WaitForActiveRecord(CurrSess, seconds%) As Integer
  Dim CS as Object
  Set CS = CurrSess
  Dim sTime as Long
  Dim eTime as Long

  On Error Goto ErrHandler
  sTime = Timer
  Do
    eTime = Timer
    If eTime > sTime + seconds% Then
      WaitForActiveRecord = FALSE
      Goto Done
    End If
    CS.GetActiveRecord
    If Err = 0 Then Exit Do
  Loop While Err = 440
  On Error Goto 0
  WaitForActiveRecord = TRUE
  Goto Done

ErrHandler:
  If Err = 440 Then
    Resume Next
  Else
    MsgBox "Error "& Err & "(" & Erl & "): " & Error
    WaitForActiveRecord = FALSE
    Resume Done
  End If

Done:
End Function

Return to the index page.