Unfortunately, when I posted this many years ago I did not include some of the additional functions that GetVarFromAdventExp calls. I have amended the code below to include these missing functions, but nobody ever inquired or complained about this oversight. Perhaps it went unnoticed. I am likely make some updates to this code in the near future in order to clean it up and add some comments to make it easier to read and understand.
VB
Function GetVarFromAdventExp(filename As String, var As String, pad As Integer) As String
' This function pulls requested label values from their corresponding
' exported Axys and APX files. It was created a long, long time ago,
' but has been maintained over the years to work with nearly every
' version of APX and Axys. Current versions of Axys 3.x and APX
' should work, but may require certain parameters to be used when
' calling IMEX to export files.
' written in VBA by Kevin Shea (aka AdventGuru) & updated 06/26/2019
' Disclaimer: This routine works fine for the specific instance it was
' created for, but could need additional modifications for different
' circumstances.
DoEvents
Dim temp As String, adjvar As String, record As String, VarNotFound As Integer, ff As Integer, TypeOfRecord As Integer, labellocation As Integer, checkfields As Integer
adjvar = var
Select Case LCase$(Right$(filename, 3))
Case "grp"
checkfields = 6
labellocation = 201
Case "cpg"
checkfields = 8
labellocation = 218
Case "cli"
checkfields = 53
labellocation = 420
Case "dex"
checkfields = 53
labellocation = 420
Case "pbf"
checkfields = 72
labellocation = 420
Case "prf"
checkfields = 72
labellocation = 420
Case Else
labellocation = 420
End Select
temp = ""
If exists(filename) Then
VarNotFound = True
ff = FreeFile
TypeOfRecord = 36 ' var
openwithtrap filename, "Input", ff
While Not EOF(ff) And TypeOfRecord < 38 And VarNotFound
Line Input #ff, record
If Left$(record, 1) = "," And Right$(var, 1) = " " Then adjvar = Left(var, Len(var) - 1) + ","
If Len(record) >= labellocation Then
TypeOfRecord = Asc(Mid$(record, labellocation, 1))
End If
If InStr(record, (adjvar)) <> 0 Then
VarNotFound = False
End If
Wend
If VarNotFound Then
temp = ""
Else
If Len(record) < labellocation Then
If Left$(var, 1) = "$" Then temp = RTrim$(LTrim$(Mid$(record, InStr(record, adjvar) + Len(adjvar) + 3, Len(Right(record, Len(record) - (InStr(record, adjvar) + Len(adjvar)))))))
If Left$(var, 1) = "%" Then temp = RTrim$(LTrim$(Mid$(record, InStr(record, adjvar) + Len(adjvar) + 2, Len(Right(record, Len(record) - (InStr(record, adjvar) + Len(adjvar)))))))
If Left$(var, 1) = "#" Then temp = RTrim$(LTrim$(Mid$(record, InStr(record, adjvar) + Len(adjvar), Len(Right(record, Len(record) - (InStr(record, adjvar) + Len(adjvar)))))))
Else
temp = RTrim$(LTrim$(Mid$(record, labellocation + 23, Len(record$) - (labellocation + 24))))
End If
End If
If Len(temp) < pad Then temp = temp + Space$(pad - Len(temp))
Close #ff
End If
GetVarFromAdventExp = RemoveQuotesAndTrailingCommas(temp)
End Function
'The missing functions... start here.
Sub OpenWithTrap(fname As String, TypeOfAccess As String, FileNumber As Integer)
'sample use OpenWithTrap filename,"Input", ff
On Error GoTo FileErrorHandler
Select Case LCase$(Trim$(TypeOfAccess))
Case "input"
Open fname For Input As #FileNumber
Case "output"
Open fname For Output As #FileNumber
Case "append"
Open fname For Append As #FileNumber
End Select
Exit Sub
FileErrorHandler:
MsgBox "Could not open " + Trim$(fname) + " for " + Trim$(TypeOfAccess), 16, Trim$(App.Title) + " File Error"
End
End Sub
Function RemoveQuotesAndTrailingCommas(ins As String) As String
Dim di As Integer
Dim bins As String
Dim maxlength As Integer
Dim conseq As Boolean
bins = ""
conseq = True
For di = 1 To Len(ins)
If Asc(Mid$(ins, di, 1)) <> 34 Then
bins = bins + Mid$(ins, di, 1)
End If
Next di
maxlength = Len(bins)
For di = Len(bins) To 1 Step -1
If Asc(Mid$(bins, di, 1)) = 44 Then
maxlength = maxlength - 1
Else
conseq = False
End If
If conseq = False Then Exit For
Next di
RemoveQuotesAndTrailingCommas = Left$(bins, maxlength)
End Function
Function exists%(F$)
On Error GoTo ExistErrorHandler
x& = FileLen(F$)
exists% = True
Exit Function
ExistErrorHandler:
exists% = False
End Function
Expand
1 Trackback or Pingback for this entry:
[…] Axys and APX: VB function to get label values from exported CSV and fixed format files […]