I got this string here: \server\Documents\test\\954076
how i check if there is a \ a second time and how i cut it then off?
So that \server\Documents\test\\954076 is gonna be \server\Documents\test\954076
Here's a general solution to reduce any consecutive repetitions of a given character:
Sub RemoveRepetitions(s As String, c As String)
Dim len1 As Long, len2 As Long
Do
len1 = Len(s)
s = Replace(s, c & c, c)
len2 = Len(s)
Loop Until len2 = len1
End Sub
Sub testing()
Dim s As String: s = "\\server\\\\\\Documents\\\\\test\\954076"
RemoveRepetitions s, "\"
Debug.Print s
End Sub
\server\Documents\test\954076
if you're worried about double repetitions then it suffices
Dim strng As String
strng = "\server\Documents\test\\\954076"
strng = Replace(strng, "\\", "\")
if you want to handle multiple repetitions then:
Dim strng As String
strng = "\server\Documents\test\\\954076"
Do While Len(strng) - Len(Replace(strng, "\\", "\")) > 0
strng = Replace(strng, "\\", "\")
Loop
Related
Newbie here. I have an HTML source code and would like to look for string in between header tags <h1></h1>, <h2></h2>till <h5></h5> and then convert the text to lower case except acronyms or abbreviations (these are all capitals in 2 or more characters). And make sure that all country names in between use proper case.
As an example: It will find <h1>HR Policies and Procedures for Hiring - argentina LTD</h1>
It will convert it to:<H1>HR policies and procedures for hiring - Argentina LTD</H1>
I've tried a user defined function for Excel VBA found online: CapIt(A2). It uses Search, Split and Join. I'm not able to put them together to come up with the result. Would appreciate very much your help. Thank you.
Code I saw online as initial reference:
Function Capit(s As String)
Dim v As Variant, j As Long
v = Split(s, " ") ' separates the words
For j = LBound(v) To UBound(v)
If StrComp(v(j), UCase(v(j)), vbBinaryCompare) <> 0 Then v(j) = StrConv(v(j), vbProperCase)
Next j
Capit = Join(v, " ") ' joins the words
End Function
'Added this code below, can we use the results to lowercase the string and exclude the output in this function
Function FindAcronyms(yourWord As String)
Dim I As Integer
Dim ctr As Integer
FindAcronyms = Null
For I = 1 To Len(yourWord)
If Asc(Mid(yourWord, I, 1)) <= 90 And _
Asc(Mid(yourWord, I, 1)) >= 65 Then
If ctr > 0 Then
FindAcronyms = FindAcronyms & Mid(yourWord, I - 1, 1)
End If
ctr = ctr + 1
Else
If ctr > 1 Then
FindAcronyms = FindAcronyms & Mid(yourWord, I - 1, 1) & ", "
End If
ctr = 0
End If
Next
If ctr > 1 Then
FindAcronyms = FindAcronyms & Mid(yourWord, I - 1, 1)
End If
If Right(FindAcronyms, 2) = ", " Then
FindAcronyms = Left(FindAcronyms, Len(FindAcronyms) - 2)
End If
End Function
'the final look would be something like this
Sub TitleChange()
'define array
myarray = Range("A1:A100")
' Define the pattern
Dim pattern As String: pattern = "<h*>*</h*>" 'looks for the header tags
Dim f As Variant
For Each f In myarray
If f Like pattern = True Then Capital (f) 'changes all string to lower case except countries (to retain proper case) and acronyms (to retain uppercase)
Next f
End Sub
You can include the countries in an array
Sub Test()
Debug.Print Capital("HR Policies and Procedures for Hiring - argentina LTD")
End Sub
Function Capital(ByVal s As String)
Dim a, v As Variant, j As Long
a = Array("Argentina", "Egypt", "Enland")
v = Split(s, " ")
For j = LBound(v) To UBound(v)
If StrComp(v(j), UCase(v(j)), vbBinaryCompare) <> 0 Then v(j) = StrConv(v(j), vbLowerCase)
If Not IsError(Application.Match(v(j), a, 0)) Then v(j) = StrConv(v(j), vbProperCase)
Next j
Capital = Join(v, " ")
End Function
Added UDF that parses HTML code, used the Sub Test above as UDF Capital and UDF to bring together. Welcome suggestions to make it cleaner or more efficient
Dim rng As Range, cell As Range
Set rng = Range("A1:A5")
' Define the pattern
Dim pattern As String: pattern = "*<h?>*</h?>*"
' Check each item against the pattern
For Each cell In rng
If (cell Like pattern = True) Then
cell.Offset(0, 16).Value = cell.Value
cell.Offset(0, 16).Value = joinCell(Capital(StripHTML(cell)), cell.Offset(0, 0).Value) 'used UDF for striping innertext, applying rules and joining back string
End If
Next cell
End Sub
My String (strSQL) Value is 1,2,3,,4 and My result shows blank between 3 and 4 due to Double comma (,,). My Code is Following:-
strParts = Split(strSQL, ", ")
For intCounter = LBound(strParts()) To UBound(strParts())
Me.Controls("cmd" & intCounter).Visible = True
Me.Controls("cmd" & intCounter).Caption = strParts(intCounter)
Next intCounter
You can replace a double (,,) by a single one (,) before splitting:
strSQL = Replace(strSQL, ",,", ",")
Or you use a separate index:
strParts = Split(strSQL, ",")
Dim index As Long
Dim counter As Long
For index = LBound(strParts()) To UBound(strParts())
If Len(Trim(strParts(index))) > 1 Then
counter = counter + 1
Me.Controls("cmd" & counter).Visible = True
Me.Controls("cmd" & counter).Caption = strParts(index)
End If
Next index
As you also could have tripled commas, just ignore the empty entries:
Dim Part As String
strParts = Split(strSQL, ",")
For intCounter = LBound(strParts()) To UBound(strParts())
Part = Trim(strParts(intCounter))
If Part <> "" Then
Me.Controls("cmd" & Part).Visible = True
Me.Controls("cmd" & Part).Caption = Part
Else
Me.Controls("cmd" & Part).Visible = False
End If
Next
I think the best way to do this is to "sanitize" your string to remove extra commas before splitting. However, as #Gustaf notes, you could have more than 2 commas in a row. So a possible solution is to iteratively remove extra commas until you don't have any. Such a function looks like this:
' given a string that contains consecutive commas (e.g. abc,,def,,,ghi),
' removes all but the first commas (e.g. abc,def,ghi
Public Function RemoveDuplicateCommas(ByVal s As String) As String
Do While InStr(1, s, ",,", vbBinaryCompare) > 0
s = Replace(s, ",,", ",")
Loop
RemoveDuplicateCommas = s
End Function
To use this function, do something like this:
strSQL = "1,2,3,,4,,,5"
strSQL = RemoveDuplicateCommas(strSQL)
?strSQL
1,2,3,4,5
?join(split(strsql, ","), ",")
1,2,3,4,5
i have an access form consisting of a textbox , i need to check the last word of it and if this word is one of many words (array or a table column ) do an action , and this check will occurs in after_update event , something like
Private Sub textbox_AfterUpdate()
Dim txt As String
Dim lastword As String
txt = TextBox.Value
lastword= Right(txt, Len(txt) - InStrRev(txt, " "))
if lastword in (array() or column in a table) then
' do an action
End If
End Sub
we can also us an external function , could you help me with it ??
Looks like you got the function for the last word already... Now for the search in an array and table use this:
Function isInArray(stringToBeFound As String, arr As Variant) As Boolean
IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function
and
Function isColumnName(stringToBeFound As String, tableName As String) As Boolean
Dim db As Database
Dim rs1 As DAO.Recordset
Set db = CurrentDb()
Set rs1 = db.OpenRecordset(tableName)
isColumnName = False
Dim fld As DAO.Field
do until rs1.EOF
if rs1.Fields.Item(0).Value = stringToBeFound then
isColumnName = true
exit loop
end if
rs1.moveNext
loop
Set fld = Nothing
End Function
usage:
if isInArray(lastWord, youArray) or isColumnName(lastWord, "yourTable")
MsgBox "The word is already used!"
end if
How about something like this:
Private Sub TextBox1_AfterUpdate()
Dim txtStr As String
Dim vWords, v
txtStr = TextBox1.Text
If InStr(txtStr, " ") > 0 Then
txtStr = Right(txtStr, Len(txt) - InStrRev(txt, " "))
End If
vWords = Split("word1 word2 word3 word4", " ") ' fill vWords with the words you need
For Each v In vWords
If v = txtStr Then
' do an action
Exit For
End If
Next
End Sub
I am trying to import a comma delimted csv file in access. The issue i am having is that one of the columns "Amount" has commas in the data itself e.g. "1,433.36". And there will always be commas in this data.
How can I import is successfully?
Sample Data:
sjonn,one,"1,855.9"
ptele,two,344.0
jrudd,one,334.8
Thanks in advance
I would change the delimiter to a different character, like a pipe "|".
if the DoCmd.TransferText does not work for you, then you can define a method to do that 'manually' :
Set fs = Server.CreateObject("Scripting.FileSystemObject")
Set objFile = fs.GetFile("import.txt")
Set objFileTextStream = objFile.OpenAsTextStream(1, 2)
objFileTextStream.skipLine 'if the file contains the header
Do While objFileTextStream.AtEndOfStream <> True
strLine = objFileTextStream.ReadLine 'read a line
strLinePart = split(strLine,",") 'Split the line using the , delimiter
firstField = strLinePart(0)
secondField = strLinePart(1)
thirdField = strLinePart(2)
strSQL = "INSERT INTO myTable Values('"& firstField &"','"& secondField &"','"& thirdField &"')"
conn.Execute strSQL
Loop
objFileTextStream.Close: Set objFileTextStream = Nothing
Set fs = Nothing
conn.Close: Set conn = Nothing
Save the file as a tab delimited text file and import that instead.
reading the file using input handles the quotes for you
Dim f1 As String
Dim f2 As String
Dim f3 As String
Open "d:\test.txt" For Input As #1
Input #1, f1, f2, f3
Debug.Print f1, f2, f3
Input #1, f1, f2, f3
Debug.Print f1, f2, f3
Close #1 '
giving
sjonn one 1,855.9
ptele two 344.0
I once encountered the problem and this is another method that might help, it however splits the lines themselves, i.e. you must split the string first into lines before using this method
Its also assumed that its contained in a Module named Module1
''Perfoms a smart split that takes care of the ""
Public Function SmartSplit(Str As String) As Variant
''New collection
Dim Quote As String
Dim Delimiter As String
Dim MyString As String
Dim Sample As String
Dim StrCollection As New Collection
Dim Array_1() As String
Dim HasSeenQuote As Boolean
Dim index As Long
Quote = "" & CStr(Chr(34))
Delimiter = "" & CStr(Chr(44))
HasSeenQuote = False
Array_1 = Split(Str, Delimiter)
For index = LBound(Array_1) To UBound(Array_1)
Sample = Array_1(index)
If Module1.StartsWith(Sample, Quote, False) Then
HasSeenQuote = True
End If
''We append the string
If HasSeenQuote Then
MyString = MyString & "," & Sample
End If
''We add the term
If Module1.EndsWith(Sample, Quote, False) Then
HasSeenQuote = False
MyString = Replace(MyString, Quote, "")
MyString = Module1.TrimStartEndCharacters(MyString, ",", True)
MyString = Module1.TrimStartEndCharacters(MyString, Quote, True)
StrCollection.Add (MyString)
MyString = ""
GoTo LoopNext
End If
''We did not see a quote before
If HasSeenQuote = False Then
Sample = Module1.TrimStartEndCharacters(Sample, ",", True)
Sample = Module1.TrimStartEndCharacters(Sample, Quote, True)
StrCollection.Add (Sample)
End If
LoopNext:
Next index
''Copy the contents of the collection
Dim MyCount As Integer
MyCount = StrCollection.Count
Dim RetArr() As String
ReDim RetArr(0 To MyCount - 1) As String
Dim X As Integer
For X = 0 To StrCollection.Count - 1 ''VB Collections start with 1 always
RetArr(X) = StrCollection(X + 1)
Next X
SmartSplit = RetArr
End Function
''Returns true of false if the string starts with a string
Public Function EndsWith(ByVal Str As String, Search As String, IgnoreCase As Boolean) As Boolean
EndsWith = False
Dim X As Integer
X = Len(Search)
If IgnoreCase Then
Str = UCase(Str)
Search = UCase(Search)
End If
If Len(Search) <= Len(Str) Then
EndsWith = StrComp(Right(Str, X), Search, vbBinaryCompare) = 0
End If
End Function
''Trims start and end characters
Public Function TrimStartEndCharacters(ByVal Str As String, ByVal Search As String, ByVal IgnoreCase As Boolean) As String
If Module1.StartsWith(Str, Search, IgnoreCase) Then
Str = Right(Str, (Len(Str) - Len(Search)))
End If
If Module1.EndsWith(Str, Search, IgnoreCase) Then
Str = Left(Str, (Len(Str) - Len(Search)))
End If
TrimStartEndCharacters = Str
End Function
''Returns true of false if the string starts with a string
Public Function StartsWith(ByVal Str As String, Search As String, IgnoreCase As Boolean) As Boolean
StartsWith = False
Dim X As Integer
X = Len(Search)
If IgnoreCase Then
Str = UCase(Str)
Search = UCase(Search)
End If
If Len(Search) <= Len(Str) Then
StartsWith = StrComp(Left(Str, X), Search, vbBinaryCompare) = 0
End If
End Function
Anybody have some VBA code that will store a byte array into a MySQL blob column?
Here is some code. Requires a reference to Microsoft Active Data Objects 2.x Library. It uses the OLE DB provider for MySQL (Might need to install that on the client machine).
Sub StoreBLOB(data() As Byte, key As Double)
'stores the BLOB byte array into the row identified by the key
'requires reference to Microsoft Active Data Objects 2.x Library
On Error GoTo handler:
Dim con As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim conStr As String
Dim strSQL As String
'have it return only the record you want to store your blob
strSQL = strSQL & "SELECT * FROM YOURTABLE WHERE KEY = " & key
'setup connection
conStr = conStr & "Provider=MySQLProv;"
conStr = conStr & "Data Source=mydb;"
conStr = conStr & "User Id=myUsername;"
conStr = conStr & "Password=myPassword;"
con.ConnectionString = conStr
con.Open
rs.Open strSQL, con, adOpenDynamic, adLockOptimistic
If rs.RecordCount > 1 Then
Err.Raise 1001, "StoreBLOB", "Too many records returned from dataset. Check to make sure you have the right key value"
Else
Err.Raise 1002, "StoreBLOB", "No Records found that match the key"
End If
rs.Fields("BLOBFIELDNAME").Value = data
rs.Update 'store the contents to the database
rs.Close
con.Close
Set rs = Nothing
Set con = Nothing
Exit Sub
handler:
Err.Raise 1003, "StoreBLOB", "Unexpected Error in StoreBLOB. Check that server is running"
End Sub
Assuming you are using ADO to access mysql, there's a KB article on the subject.
I have some code, I replicated the mysql_real_escape_string_quote C function in VBA so that one can escape the necessary characters and build your SQL as you would for regular text:
Function mysql_real_escape_string_quote(toStr() As Byte, fromStr() As Byte, length As Long, quote As String) As Long
mysql_real_escape_string_quote = 0
Dim CharMap() As Byte: CharMap = StrConv(String(256, 0), vbFromUnicode)
CharMap(0) = Asc("0"): CharMap(39) = Asc("'"): CharMap(34) = Asc(""""): CharMap(8) = Asc("b"): CharMap(10) = Asc("n"): CharMap(13) = Asc("r"):
CharMap(9) = Asc("t"): CharMap(26) = Asc("z"): CharMap(92) = Asc("\"): CharMap(37) = Asc("%"): CharMap(95) = Asc("_"):
Dim i As Long: Dim n As Long: n = 0
If length > UBound(fromStr) + 1 Then Exit Function
For i = 0 To length - 1 '---count escapable chars before redim---
n = n + 1
If CharMap(fromStr(i)) <> 0 Then n = n + 1
Next i
ReDim toStr(n - 1) As Byte
n = 0
For i = 0 To length - 1 '---test chars---
If CharMap(fromStr(i)) = 0 Then
toStr(n) = fromStr(i)
Else '---escape char---
toStr(n) = Asc(quote): n = n + 1
toStr(n) = CharMap(fromStr(i))
End If
n = n + 1
Next i
mysql_real_escape_string_quote = n
End Function
Function mysql_real_escape_string(InputString As String) As String
mysql_real_escape_string = ""
Dim toStr() As Byte: Dim fromStr() As Byte
fromStr = StrToChar(InputString)
If mysql_real_escape_string_quote(toStr, fromStr, UBound(fromStr) + 1, "\") = 0 Then Exit Function
mysql_real_escape_string = StrConv(toStr(), vbUnicode)
End Function
Function StrToChar(str As String) As Byte()
Dim ans() As Byte
ans = StrConv(str, vbFromUnicode)
ReDim Preserve ans(Len(str)) As Byte
ans(Len(str)) = 0
StrToChar = ans
End Function
Sub testit()
Dim toStr() As Byte: Dim fromStr() As Byte
fromStr = StrToChar("hello world's")
MsgBox (mysql_real_escape_string_quote(toStr, fromStr, UBound(fromStr) + 1, "\"))
MsgBox (mysql_real_escape_string("hello world's"))
For i = 0 To UBound(toStr)
Debug.Print i & " " & toStr(i)
Next i
End Sub
It's been optimized for large amounts of data without a ridiculous amount of conditionals (ifs).