Function which Removes Only Non-ASCII characters in a column in access table - vba

I have a access table and i am writing a vba code to remove non-ascii characters from the table, i have tried using below two functions
Public Function removeall(stringData As String) As String
Dim letter As Integer
Dim final As String
Dim i As Integer
For i = 1 To Len(stringData) 'loop thru each char in stringData
letter = Asc(Mid(stringData, i, 1)) 'find the char and assign asc value
Select Case letter 'Determine what type of char it is
Case Is < 91 And letter > 64 'is an upper case char
final = final & Chr(letter)
Case Is < 123 And letter > 96 'is an lower case char
final = final & Chr(letter)
Case Is = 32 'is a space
final = final & Chr(letter)
End Select
Next i
removeall = final
End Function
And also tried using below function
Public Function Clean(InString As String) As String
'-- Returns only printable characters from InString
Dim x As Integer
For x = 1 To Len(InString)
If Asc(Mid(InString, x, 1)) > 31 And Asc(Mid(InString, x, 1)) < 127 Then
Clean = Clean & Mid(InString, x, 1)
End If
Next x
End Function
But the problem is : In removeall function it removes everything including # and space characters.. And In Clean function also removes special characters as well.
I need a correct function which retains key board characters and removes all other characters
Examples of strings in tables are :
1) "ATTACHMENT FEEDING TUBE FITS 5-18 ºFR# "
2) "CATHETER FOLEY 3WAY SILI ELAST 20FR 30ML LATEXº"
Any help would be greatly appreciated
Output should be like
1) "ATTACHMENT FEEDING TUBE FITS 5-18 FR"
2) "CATHETER FOLEY 3WAY SILI ELAST 20FR 30ML LATEX"

One approach would be to use a whitelist of accepted characters. e.g.
' You can set up your domain specific list:
Const Whitelist = "1234567890" & _
"qwertyuiopasdfghjklzxcvbnm" & _
"QWERTYUIOPASDFGHJKLZXCVBNM" & _
" `~!##$%^&*()_-=+[]{};:""'|\<>?/ –"
Public Sub test()
Debug.Print Clean("ATTACHMENT FEEDING TUBE FITS 5-18 ºFR#")
Debug.Print Clean("CATHETER FOLEY 3WAY SILI ELAST 20FR 30ML LATEXº")
End Sub
Public Function isAllowed(char As String) As Boolean
isAllowed = InStr(1, Whitelist, char, vbBinaryCompare) > 0
End Function
Public Function Clean(dirty As String) As String
'-- Returns only printable characters from dirty
Dim x As Integer
Dim c As String
For x = 1 To Len(dirty)
c = Mid(dirty, x, 1)
If isAllowed(c) Then
Clean = Clean & c
End If
Next x
End Function

Alternate approach that preserves ALL ASCII characters, without working with a whitelist, in a single function:
Public Function RemoveNonASCII(str As String) As String
Dim i As Integer
For i = 1 To Len(str)
If AscW(Mid(str, i, 1)) < 127 Then 'It's an ASCII character
RemoveNonASCII = RemoveNonASCII & Mid(str, i, 1) 'Append it
End If
Next i
End Function

Related

6-BIT (or 5 bit) encode and decode to/from strings for packing into 128 bit pseudo-GUIDs

(Apologies if this is a repeat but my question disappeared- THIS ONE IS MORE DETAILED)
I have names that need conversation into a 'static' of 'fixed' GUID. Using ASCII- I have a GUID that represents a a 16-character name. I can re-run these in reverse to see if it is one of our names. But I would like to expand it so I only use an indexed set of characters, and can effectively jam 16 characters into the 128 bits of the GUID (ASCII-8 bit - FF in hex, easy to fake and parse) I am only using 64 characters which I could reduce to 6 bit if I could figure out how to pack the bits in VBA/EXCEL. I could lower that to 5-bit potentially if I dropped the caps.
With 6 or 5 bit, I could get names that were 128/5=25(r3) bits or 128/6=21(r2) bits, or is this even possible?
so the indexes would look like:
''stripped character index tables
'''''''''''''''''''0'''''''''1'''''''''2'''''''''3'
'''''''''''''''''''0123456789x123456789x123456789x1
Const b32_5_bit = "()+.ABCDEFGHIJKLMNOPQRSTUVWXYZ_" '' basic text only naming
'''''''''''''''''''0'''''''''1'''''''''2'''''''''3'''''''''4'''''''''5'''''''''6'''
'''''''''''''''''''0123456789x123456789x123456789x123456789x123456789x123456789x123
Const b64_6_bit = ".0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz" ''Text and numbers naming
'''''''''''''''''''0'''---''''''1'''''''''2'''''''''3'''''''''4'''''''''5'''''''''6'''''''''7'''''''''8'''''''''9'''''''''0'''''''''1'''''''''2
'''''''''''''''''''0123---456789x123456789x123456789x123456789x123456789x123456789x123456789x123459789x123456789x12345978
Const b128_7_bit = " !""""#$%&'()*+,-./0123456789:;<=>?#ABCEDFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcedfghijklmnopqrstufwxyz{|}~" ''Full printable characters for naming ''And on to more unused spaces....
I cannot figure out how to pack the bits in VBA so they can be unpacked. Tried masking against
2^6(n-1)+ 2^(Return index of character in array)
where (n) is the position in the string masking. This encoded but didn't decode correctly.
I am About to revert to a hack where I convert to string representation of binary and then nibble 6 characters at a time and convert back to the index. e.g. ".a" = "000000" & "100100"
Looked at hashing - but that doesn't reverse(for back checks)- and a few other things - and been trying to wrap my head around the ins and out of 6-bit base64 numbering. Any help is appreciated.
Here is what I had for the Text to GUID(base256-8-bit):
Attribute VB_Name = "Base16"
Option Explicit
Const HEX_STRING_PREFIX As String = "0x"
Const VBA_HEX_PREFIX As String = "&h"
''UUID record layout total numbers =32
''Name Length (bytes) Length (hex digits)Contents
''time_low 4 8 integer giving the low 32 bits of the time
''time_mid 2 4 integer giving the middle 16 bits of the time
''time_hi_and_version 2 4 4-bit "version" in the most significant bits, followed by the high 12 bits of the time
''clock_seq_hi_and_res clock_seq_low 2 4 1–3-bit "variant" in the most significant bits, followed by the 13–15-bit clock sequence
''node 6 12 the 48-bit node id
Public Function GUIDfromStr(Prefix As String, Variable As String) As String
''encodes decodeable GUID based on previx and a variable to run out to end of line (as many characters as possible)
''Used to generate GUIDS or UUIDs in a way that is identifiable
''PREFIX Is KTGY
''Variable is N...characters of variable name to encode to HEX for use as a GUID in parameter name generation. Not random but still random enough to backtrack.
''ASCII letters are encoded in hex pairs(0-255) and truncated
Prefix = UCase(Left(Prefix, 4))
GUIDfromStr = HexEncode(Prefix, "") & HexEncode(Variable, "")
GUIDfromStr = Left(GUIDfromStr & String(32, "0"), 32)
GUIDfromStr = Format(GUIDfromStr, String(8, "&") & "-" & String(4, "&") & "-" & String(4, "&") & "-" & String(4, "&") & "-" & String(12, "&"))
End Function
Public Function STRfromGUID(str As String) As String
''conver the first 8 characters, add a separator convert the remaining to reval up to 26 characters of parameter name
str = Replace(str, "-", "") ''remove the dashes
STRfromGUID = HexDecode(HEX_STRING_PREFIX & Left(str, 8)) _
& "|" _
& HexDecode(HEX_STRING_PREFIX & Right(str, Len(str) - 8))
End Function
Public Function HexEncode(AsciiText As String, Optional HexPrefix As String = HEX_STRING_PREFIX) As String
If AsciiText = vbNullString Then
HexEncode = AsciiText
Else
Dim asciiChars() As Byte
asciiChars = StrConv(AsciiText, vbFromUnicode)
ReDim hexChars(LBound(asciiChars) To UBound(asciiChars)) As String
Dim char As Long
For char = LBound(asciiChars) To UBound(asciiChars)
hexChars(char) = Right$("00" & Hex$(asciiChars(char)), 2)
Next char
HexEncode = HexPrefix & Join(hexChars, "")
End If
End Function
Public Function HexDecode(HexString As String, Optional HexPrefix As String = HEX_STRING_PREFIX)
'Check if there's anything to decode
If HexString = vbNullString Then
HexDecode = vbNullString
Exit Function
Else
If Not StrComp(Left$(HexString, Len(HexPrefix)), HexPrefix, vbTextCompare) = 0 Then
'Unexpected string format
GoTo DecodeError
End If
Dim hexRaw As String
hexRaw = Mid$(HexString, 1 + Len(HexPrefix))
'Check if the string is valid for decoding
If Len(hexRaw) Mod 2 = 1 Then
GoTo DecodeError
End If
Dim numHexChars As Long
numHexChars = Len(hexRaw) / 2
ReDim hexChars(0 To numHexChars - 1) As Byte
Dim char As Long
For char = 0 To numHexChars - 1
Dim hexchar As String
hexchar = VBA_HEX_PREFIX & Mid$(hexRaw, 1 + char * 2, 2)
'Check if the hex-pair is actually hex
If Not IsNumeric(hexchar) Then
GoTo DecodeError
End If
hexChars(char) = CByte(hexchar)
Next char
'Return the concatenated bytes as a string
HexDecode = StrConv(hexChars, vbUnicode)
End If
SafeExit:
Exit Function
DecodeError:
HexDecode = CVErr(xlErrValue)
End Function
Attribute VB_Name = "base2_6"
''Total hack- BUT it works to jam 21 characters using a 6 bit reference
''into a 128bit GUID
''Characters register 6 bit binary MSB at left,
''every 8 bits gets jammed into a HEX and those bits removed off the stack
''when max characters is reached- there are 2 bits left over - filled with
''LSB "00" to force the HEX to generate for 32 characters of hex for
''A 128 bit GUID. Will work on the round trip next to convert from GUID
''to string - 5 more characters than a straight ASCII to hex conversion
Option Explicit
''Background - to create as long of a static GUID from a string (21)
''Base 2^6 = 6 bit, 64 characters, # 0-63
''decode = Value - (CharPosition*Base)
''Encode = Value + (CharPosition*Base)
'look at 24 bit chunks (6bit and 8bit share every 24 bits bit group.)
'00000x00000x00000x00000x = every four characters in 6 bit = 24 bits
'0000000x0000000x0000000x = 3 bytes
'-2hex--x-2hex--x-2hex--x = 3 hex bytes per 4 characters
'128bit = 16 hex pairs or 21 characters + 2 leftover bits.
Const vbqt = """"
''Full VISUAL ASCII characters from 32(space) through 126 ~
Const strASC = " !" & vbqt & "#$%&'()*+,-./0123456789:;<=>?#ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~"
''Revit illegal chars "Filesystem" :;< >? [\] ` {|}
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''5 bit - would allow for 25 charqacters simplified- ignoring upper and lower case
''would require a UCASE convert prior to checking. can contain a few digits only
''Optional simpler base 5bit- not used - do not change this - it will change the whole field base and compression!
''do not change this - it will change the whole field base and compression!
''''''''''''''''0''''''''1'''''''''2'''''''''3'*<31 MAX (32 CHARS)
''''''''''''''''01234567890123456789012345678901 ''NoSpaces!
Const Base5b = ".0123ABCDEFGHIJKLMNOPQRSTUVWXYZ_"
Const x5b = 5 ''Encoding bitsize
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''6 bit - allows for 21 charqacters simplified- ignoring upper and lower case
''do not change this - it will change the whole field base and compression!
''''''''''''''''00''''''''1'''''''''2'''''''''3'''''''''4'''''''''5'''''''''6''''
''''''''''''''''0123456789012345678901234567890123456789012345678901234567890123 ''NoSpaces!
Const Base6b = ".0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz"
Const x6b = 6 ''Encoding bitsize
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''7 bit - would only allow for 18 characters
''do not change this - it will change the whole field base and compression!
''''''''''''''''00 ''''''''1'''''''''2'''''''''3'''''''''4'''''''''5'''''''''6'''''''''7'''''''''''12 *<127
''''''''''''''''01 2 34567890123456789012345678901234567890123456789012345678901234567890123456789---01234567
Const Base7b = " !" & vbqt & "#$%&'()*+.123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz"
Const x7b = 7 ''Encoding bitsize
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''8 bit - allows for 256 characters
''Same as straight hex encoding xFF 256 bits - mostly 173 wasted spaces
''''''''''''''''0------------''''''''1'''''''''2'''''''''3'''''''''4'''''''''5'''''''''6'''''''''7'''''''''8'''
''''''''''''''''0----1-------2345678901234567890123456789012345678901234567890123456789012345678901234567890123
Const Base8b = "!" & vbqt & "#$%&'()*+,-./0123456789:;=#ABCDEFGHIJKLMNOPQRSTUVWXYZ^_`abcdefghijklmnopqrstuvwxyz"
Function Encode6Bit2HexGUID(VarName As String) As String ''Range) As String ''guid in HEX
''takes a string of fixed characters Base6b compared against 6 bits to compress 4 characters for every 3 Bytes (FFFFFF)
''To pack into 128 bit string for GUID.
Dim i As Integer ''count integer
Dim ie As Integer ''iend of count either MaxChar or less
Dim strName As String ''string to nibble
Dim HexStr As String ''Hex string to build
Const MaxChar = 21
Dim enc6b As Long ''6bit value per character
Dim binStr As String ''Binary representation of number
''strName = VarName.value ''get value to work with
strName = VarName
If Len(strName) > MaxChar Then
MsgBox MaxChar & " character limite exceeded, variables must be unique within the first MaxChar characters.", vbExclamation + vbOKOnly, "Warning"
'
ie = MaxChar
strName = Left(strName, MaxChar)
Else
ie = Len(Left(strName, MaxChar)) '''''''''''''''''''<<<<<<<<<<<<<<DEBUG test
'If ie < 4 Then ie = 4 ''need every 4 characters to make up 3 hex pairs
ie = Round((ie / 4) + 0.5, 0) * 4
End If
For i = 1 To ie ''loop thorugh string name
enc6b = enc6Bc(Mid(strName, i, 1)) ''Get char position in matrix
binStr = binStr & Dec2Bin(enc6b, 6) ''ENCODE 6 BIT BINARY
If i = MaxChar Then binStr = binStr & "00" ''force last two bits 1 & 2 to register to process byte
''check if 8 or more binaries to byte into a hex
Do While Len(binStr) >= 8
HexStr = HexStr & Right("0" & Hex(Bin2Dec(Left(binStr, 8))), 2)
binStr = Right(binStr, Len(binStr) - 8)
Loop
Next i
Encode6Bit2HexGUID = Left(HexStr & String(32, "0"), 32)
'''''''''0 1 2 3
'''''''''12 34 56 78 90 12 34 56 78 90 12 34 56 78 90 12
''guid = XX.XX.XX.XX-XX.XX-XX.XX-XX.XX-XX.XX.XX.XX.XX.XX
''format GUID
Encode6Bit2HexGUID = Format(Encode6Bit2HexGUID, String(8, "&") & "-" & String(4, "&") & "-" & String(4, "&") & "-" & String(4, "&") & "-" & String(12, "&"))
End Function
Function enc6Bc(X As String) As Integer
enc6Bc = InStr(1, Base6b, Left(X, 1), vbBinaryCompare) - 1
If enc6Bc = -1 Then enc6Bc = 0 ''substitute 1st character if not found (returns 0)
End Function
Function Dec2Bina(X As Long, BitNo As Integer) As String
''RA: MAY TAKE A HEAVIER COMPUTATIONAL TOLL THAN THE DIVIDE/2 METHOD
Dim i
For i = BitNo - 1 To 0 Step -1
If X >= 2^ ^ i Then
X = X - 2^ ^ i
Dec2Bina = Dec2Bina & "1"
Else
Dec2Bina = Dec2Bina & "0"
End If
Next i
End Function
'Decimal To Binary
' =================
' Source: http://groups.google.ca/group/comp.lang.visual.basic/browse_thread/thread/28affecddaca98b4/979c5e918fad7e63
' Author: Randy Birch (MVP Visual Basic)
' NOTE: You can limit the size of the returned
' answer by specifying the number of bits
Function Dec2Bin(ByVal DecimalIn As Variant, _
Optional NumberOfBits As Variant) As String
Dec2Bin = ""
DecimalIn = Int(CDec(DecimalIn))
Do While DecimalIn <> 0
Dec2Bin = Format$(DecimalIn - 2 * Int(DecimalIn / 2)) & Dec2Bin
DecimalIn = Int(DecimalIn / 2) ''SHIFT ONE BIT TO THE LEFT WITH DIV2
Loop
If Not IsMissing(NumberOfBits) Then
If Len(Dec2Bin) > NumberOfBits Then
Dec2Bin = "Error - Number exceeds specified bit size"
Else
Dec2Bin = Right$(String$(NumberOfBits, _
"0") & Dec2Bin, NumberOfBits)
End If
End If
End Function
'Binary To Decimal
' =================
Function Bin2Dec(BinaryString As String) As Variant
Dim X As Integer
For X = 0 To Len(BinaryString) - 1
Bin2Dec = CDec(Bin2Dec) + Val(Mid(BinaryString, _
Len(BinaryString) - X, 1)) * 2 ^ X
Next
End Function
Public Function String_from_6Bit2HexGUID(strGUID As String) As String
Dim i As Integer
Dim strBin As String
Dim str3byte As String
Dim Long3Byte As Long
Dim strVarName As String
strGUID = Replace(strGUID, "-", "") ''remove the dashes
For i = 1 To Len(strGUID) Step 6
str3byte = Left(strGUID, 6)
strGUID = Right(strGUID, Len(strGUID) - Len(str3byte))
Long3Byte = CLng("&H" & str3byte)
If i = 31 Then
strBin = Left(Dec2Bin(Long3Byte, 8), 6)
Else
strBin = Dec2Bin(Long3Byte, 24)
End If
Do While strBin > ""
strVarName = strVarName & Mid(Base6b, Bin2Dec(Left(strBin, 6)) + 1, 1)
strBin = Right(strBin, Len(strBin) - 6)
Loop
Next i
String_from_6Bit2HexGUID = strVarName
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''
''Testing funcitons for in and back
Private Sub test_Encode6Bit2Hex()
''''''''''''''''''''''''''''''''0 1 2
'123456789012345687901<MAX
Debug.Print Encode6Bit2HexGUID("zzzz................z")
'''''''''''''''''''''''equals = FFFFFF00-0000-0000-0000-0000000000FC
End Sub
Private Sub test_String_from_6Bit2HexGUID()
Const StrEncode = "__.CLEAR.HARD12345678"
'''''''''''''''''''0 1 2
'123456789012345687901<MAX
Debug.Print StrEncode
Debug.Print Encode6Bit2HexGUID(StrEncode)
Debug.Print String_from_6Bit2HexGUID(Encode6Bit2HexGUID(StrEncode))
End Sub
Private Sub printASCII()
Dim i
Dim str
For i = 32 To 126
str = str & Chr(i)
Next i
Debug.Print str
End Sub

VBA Function not Returning Value

I have a VBA code that's designed to search a CSV String and add Carriage Returns where they should exist. I've split it up into two seperate functions - one to search the string and put the index of where the CRs should go into an array and a second function to actually add the CRs.
The issue I'm running into is that the value in the immediate window/in the watch window for the functions is correct within the function itself, but it assigns the result variable a blank string.
'*****************Import CSV**********************
'Took this straight off the internet because it was reading Jet.com files as one single line
'
Sub ImportCSVFile(filepath As String)
.....
line = SearchString(line, "SALE")
.....
End Sub
'****************Search String***************************
'This is search the string for something - It will then call a function to insert carriage returns
Function SearchString(source As String, target As String) As String
Dim i As Integer
Dim k As Integer
Dim myArray() As Variant
Dim resultString As String
Do
i = i + 1
If Mid(source, i, Len(target)) = target Then
ReDim Preserve myArray(k)
myArray(k) = i
k = k + 1
End If
DoEvents
Loop Until i = Len(source)
resultString = addCarriageReturns(source, myArray) 'resultString here is assigned a blank string
SearchString = resultString
End Function
'***************Add Carraige Returns**************************
'Cycle through the indices held in the array and place carriage returns into the string
Function addCarriageReturns(source As String, myArray As Variant) As String
Dim i As Integer
Dim resultString As String
resultString = source
For i = 0 To UBound(myArray, 1)
resultString = Left(resultString, myArray(i) + i) & Chr(13) & Right(resultString, Len(resultString) - myArray(i) + i)
Next i
addCarraigeReturns = resultString 'The value of addCarriageReturn is correct in the immediate window here
End Function
In the function the value is not blank
...but when it passes it back, it says the value is blank
I'm just curious, why do you want separate functions like this?
Can you just use:
line = Replace(line, "SALE", "SALE" & Chr(13))

Converting string to ASCII number

I am trying to write a function using Excel VBA to convert a string to its respective ASCII number. For example:
"ABCD" => "65666768"
I have written this code but it's failed to do the conversion:
Public Function asciien(s As String) As String
' Returns the string to its respective ascii numbers
Dim i As Integer
For i = 1 To Len(s)
asciien = asciien & CStr(Asc(Mid(s, x, 1)))
Next i
End Function
This line
asciien = asciien & CStr(Asc(Mid(s, x, 1)))
should read
asciien = asciien & CStr(Asc(Mid(s, i, 1)))
"x" has no value

Query or VBA Function for adding leading zeroes to a field with special conditions

I have a macro I am trying to turn into a VBA Function or Query for adding leading zeros to a field.
For my circumstances, their needs to be 4 numeric digits plus any alphabetic characters that follow so a simple format query doesn't do the trick.
The macro I have uses Evaluate and =Match but I am unsure how this could be achieved in Access.
Sub Change_Number_Format_In_String()
Dim iFirstLetterPosition As Integer
Dim sTemp As String
For Each c In Range("A2:A100")
If Len(c) > 0 Then
iFirstLetterPosition = Evaluate("=MATCH(TRUE,NOT(ISNUMBER(1*MID(" & c.Address & ",ROW($1:$20),1))),0)")
sTemp = Left(c, iFirstLetterPosition - 1) 'get the leading numbers
sTemp = Format(sTemp, "0000") 'format the numbers
sTemp = sTemp & Mid(c, iFirstLetterPosition, Len(c)) 'concatenate the remainder of the string
c.NumberFormat = "#"
c.Value = sTemp
End If
Next
End Sub
In my database the field in need of formatting is called PIDNUMBER
EDIT:
To expand on why FORMAT doesnt work in my situation. Some PIDNUMBERS have an alpha character after the number that should not be counted when determining how many zeroes to add.
In example:
12 should become 0012
12A should become 0012A
When using format, it counts the letters as part of the string, so 12A would become 012A instead of 0012A as intended.
You could try:
Public Function customFormat(ByRef sString As String) As String
customFormat = Right("0000" & sString, 4 + Len(sString) - Len(CStr(Val(sString))))
End Function
Try utilize this function, if you only want this to be available in VBA, put Private in front of the Function:
Function ZeroPadFront(oIn As Variant) As String
Dim zeros As Long, sOut As String
sOut = CStr(oIn)
zeros = 4 - Len(sOut)
If zeros < 0 Then zeros = 0
ZeroPadFront = String(zeros, "0") & sOut
End Function
The Val() function converts a string to a number, and strips off any trailing non-numeric characters. We can use it to figure out how many digits the numeric portion has:
Function PadAlpha$(s$)
Dim NumDigs As Long
NumDigs = Len(CStr(Val(s)))
If NumDigs < 4 Then
PadAlpha = String$(4 - NumDigs, "0") & s
Else
PadAlpha = s
End If
End Function
? padalpha("12")
> 0012
? padalpha("12a")
> 0012a
Bill,
See if this will work. It seems like a function would better suit you.
Function NewPIDNumber(varPIDNumber As Variant) As String
Dim lngLoop As Long
Dim strChar As String
For lngLoop = 1 to Len(varPIDNumber)
strChar = Mid(varPIDNumber, lngLoop, 1)
If IsNumeric(strChar) Then
NewPIDNumber = NewPIDNumber & strChar
Else
Exit For
End If
Next lngLoop
If Len(NewPIDNumber) > 4 Then
MsgBox "Bad Data Maaaaan...." & Chr(13) & Chr(13) & "The record = " & varPIDNumber
Exit Function
End If
Do Until Len(NewPIDNumber) = 4
NewPIDNumber = "0" & NewPIDNumber
Loop
End Function
Data Result
012a 0012
12a 0012
12 0012
85 0085
85adfe 0085
1002a 1002
1002 1002

Increment character in a string

I have a 2 character string composed only of the 26 capital alphabet letters, 'A' through 'Z'.
We have a way of knowing the "highest" used value (e..g "IJ" in {"AB", "AC", "DD", "IH", "IJ"}). We'd like to get the "next" value ("IK" if "IJ" is the "highest").
Function GetNextValue(input As String) As String
Dim first = input(0)
Dim last = input(1)
If last = "Z"c Then
If first = "Z"c Then Return Nothing
last = "A"c
first++
Else
last++
EndIf
Return first & last
End Function
Obviously char++ is not valid syntax in VB.NET. C# apparently allows you to do this. Is there something shorter less ugly than this that'd increment a letter? (Note: Option Strict is on)
CChar(CInt(char)+1).ToString
Edit: As noted in comment/answers, the above line won't even compile. You can't convert from Char -> Integer at all in VB.NET.
The tidiest so far is simply:
Dim a As Char = "a"
a = Chr(Asc(a) + 1)
This still needs handling for the "z" boundary condition though, depending on what behaviour you require.
Interestingly, converting char++ through developerfusion suggests that char += 1 should work. It doesn't. (VB.Net doesn't appear to implicitly convert from char to int16 as C# does).
To make things really nice you can do the increment in an Extension by passing the char byref. This now includes some validation and also a reset back to a:
<Extension>
Public Sub Inc(ByRef c As Char)
'Remember if input is uppercase for later
Dim isUpper = Char.IsUpper(c)
'Work in lower case for ease
c = Char.ToLower(c)
'Check input range
If c < "a" Or c > "z" Then Throw New ArgumentOutOfRangeException
'Do the increment
c = Chr(Asc(c) + 1)
'Check not left alphabet
If c > "z" Then c = "a"
'Check if input was upper case
If isUpper Then c = Char.ToUpper(c)
End Sub
Then you just need to call:
Dim a As Char = "a"
a.Inc() 'a is now = "b"
My answer will support up to 10 characters, but can easily support more.
Private Sub Test
MsgBox(ConvertBase10ToBase26(ConvertBase26ToBase10("AA") + 1))
End Sub
Public Function ConvertBase10ToBase26(ToConvert As Integer) As String
Dim pos As Integer = 0
ConvertBase10ToBase26 = ""
For pos = 10 To 0 Step -1
If ToConvert >= (26 ^ pos) Then
ConvertBase10ToBase26 += Chr((ToConvert \ (26 ^ pos)) + 64)
ToConvert -= (26 ^ pos)
End If
Next
End Function
Public Function ConvertBase26ToBase10(ToConvert As String) As Integer
Dim pos As Integer = 0
ConvertBase26ToBase10 = 0
For pos = 0 To ToConvert.Length - 1
ConvertBase26ToBase10 += (Asc(ToConvert.Substring(pos, 1)) - 64) * (26 ^ pos)
Next
End Function
Unfortunately, there's no easy way -- even CChar(CInt(char)+1).ToString doesn't work. It's even uglier:
CChar(Char.ConvertFromUtf32(Char.ConvertToUtf32(myCharacter, 0) + 1))
but of course you could always put that in a function with a short name or, like Jon E. pointed out, an extension method.
Try this
Private Function IncBy1(input As String) As String
Static ltrs As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
Dim first As Integer = ltrs.IndexOf(input(0))
Dim last As Integer = ltrs.IndexOf(input(1))
last += 1
If last = ltrs.Length Then
last = 0
first += 1
End If
If first = ltrs.Length Then Return Nothing
Return ltrs(first) & ltrs(last)
End Function
This DOES assume that the code is only two chars, and are A-Z only.
Dim N as String = ""
Dim chArray As Char = Convert.ToChar(N)
Dim a As String = CChar(Char.ConvertFromUtf32(Char.ConvertToUtf32(chArray, 0) + 1))