Replace Module Text in MS Access using VBA - ms-access

How do I do a search and replace of text within a module in Access from another module in access? I could not find this on Google.
FYI, I figured out how to delete a module programatically:
Call DoCmd.DeleteObject(acModule, modBase64)

I assume you mean how to do this programatically (otherwise it's just ctrl-h). Unless this is being done in the context of a VBE Add-In, it is rarely (if ever) a good idea. Self modifying code is often flagged by AV software an although access will let you do it, it's not really robust enough to handle it, and can lead to corruption problems etc. In addition, if you go with self modifying code you are preventing yourself from ever being able to use an MDE or even a project password. In other words, you will never be able to protect your code. It might be better if you let us know what problem you are trying to solve with self modifying code and see if a more reliable solution could be found.

After a lot of searching I found this code:
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Function to Search for a String in a Code Module. It will return True if it is found and
'False if it is not. It has an optional parameter (NewString) that will allow you to
'replace the found text with the NewString. If NewString is not included in the call
'to the function, the function will only find the string not replace it.
'
'Created by Joe Kendall 02/07/2003
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function SearchOrReplace(ByVal ModuleName As String, ByVal StringToFind As String, _
Optional ByVal NewString, Optional ByVal FindWholeWord = False, _
Optional ByVal MatchCase = False, Optional ByVal PatternSearch = False) As Boolean
Dim mdl As Module
Dim lSLine As Long
Dim lELine As Long
Dim lSCol As Long
Dim lECol As Long
Dim sLine As String
Dim lLineLen As Long
Dim lBefore As Long
Dim lAfter As Long
Dim sLeft As String
Dim sRight As String
Dim sNewLine As String
Set mdl = Modules(ModuleName)
If mdl.Find(StringToFind, lSLine, lSCol, lELine, lECol, FindWholeWord, _
MatchCase, PatternSearch) = True Then
If IsMissing(NewString) = False Then
' Store text of line containing string.
sLine = mdl.Lines(lSLine, Abs(lELine - lSLine) + 1)
' Determine length of line.
lLineLen = Len(sLine)
' Determine number of characters preceding search text.
lBefore = lSCol - 1
' Determine number of characters following search text.
lAfter = lLineLen - CInt(lECol - 1)
' Store characters to left of search text.
sLeft = Left$(sLine, lBefore)
' Store characters to right of search text.
sRight = Right$(sLine, lAfter)
' Construct string with replacement text.
sNewLine = sLeft & NewString & sRight
' Replace original line.
mdl.ReplaceLine lSLine, sNewLine
End If
SearchOrReplace = True
Else
SearchOrReplace = False
End If
Set mdl = Nothing
End Function

Check out the VBA object browser for the Access library. Under the Module object you can search the Module text as well as make replacements. Here is an simple example:
In Module1
Sub MyFirstSub()
MsgBox "This is a test"
End Sub
In Module2
Sub ChangeTextSub()
Dim i As Integer
With Application.Modules("Module1")
For i = 1 To .CountOfLines
If InStr(.Lines(i, 1), "This is a Test") > 0 Then
.ReplaceLine i, "Msgbox ""It worked!"""
End If
Next i
End With
End Sub
After running ChangeTextSub, MyFirstSub should read
Sub MyFirstSub()
MsgBox "It worked!"
End Sub
It's a pretty simple search but hopefully that can get you going.

additional for the function (looping through all the lines)
Public Function ReplaceWithLine(modulename As String, StringToFind As String, NewString As String)
Dim mdl As Module
Set mdl = Modules(modulename)
For x = 0 To mdl.CountOfLines
Call SearchOrReplace(modulename, StringToFind, NewString)
Next x
Set mdl = Nothing
End Function
Enjoy ^^

Related

How do I parse html without creating an object of internet explorer in vba?

I don't have internet explorer on any of the computers at work, therefore creating a object of internet explorer and using ie.navigate to parse the html and search for the tags isn't possible. My question is, how can I pull certain data with a tag automatically from a frame source to my spreadsheet without using IE? Example of code in answers would be very useful :) Thanks
You could use XMLHTTP to retrieve the HTML source of a web page:
Function GetHTML(url As String) As String
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", url, False
.Send
GetHTML = .ResponseText
End With
End Function
I wouldn't suggest using this as a worksheet function, or else the site URL will be re-queried every time the worksheet recalculates. Some sites have logic in place to detect scraping via frequent, repeated calls, and your IP could become banned, temporarily or permanently, depending on the site.
Once you have the source HTML string (preferably stored in a variable to avoid unnecessary repeat calls), you can use basic text functions to parse the string to search for your tag.
This basic function will return the value between the <tag> and </tag>:
Public Function getTag(url As String, tag As String, Optional occurNum As Integer) As String
Dim html As String, pStart As Long, pEnd As Long, o As Integer
html = GetHTML(url)
'remove <> if they exist so we can add our own
If Left(tag, 1) = "<" And Right(tag, 1) = ">" Then
tag = Left(Right(tag, Len(tag) - 1), Len(Right(tag, Len(tag) - 1)) - 1)
End If
' default to Occurrence #1
If occurNum = 0 Then occurNum = 1
pEnd = 1
For o = 1 To occurNum
' find start <tag> beginning at 1 (or after previous Occurence)
pStart = InStr(pEnd, html, "<" & tag & ">", vbTextCompare)
If pStart = 0 Then
getTag = "{Not Found}"
Exit Function
End If
pStart = pStart + Len("<" & tag & ">")
' find first end </tag> after start <tag>
pEnd = InStr(pStart, html, "</" & tag & ">", vbTextCompare)
Next o
'return string between start <tag> & end </tag>
getTag = Mid(html, pStart, pEnd - pStart)
End Function
This will find only basic <tag>'s but you could add/remove/change the text functions to suit your needs.
Example Usage:
Sub findTagExample()
Const testURL = "https://en.wikipedia.org/wiki/Web_scraping"
'search for 2nd occurence of tag: <h2> which is "Contents" :
Debug.Print getTag(testURL, "<h2>", 2)
'...this returns the 8th occurence, "Navigation Menu" :
Debug.Print getTag(testURL, "<h2>", 8)
'...and this returns an HTML <span> containing a title for the 'Legal Issues' section:
Debug.Print getTag("https://en.wikipedia.org/wiki/Web_scraping", "<h2>", 4)
End Sub
Anyone who has done some web scraping will be familiar with creating an instance of Internet Explorer (IE) and the navigating to a web address and then once the page is ready start navigating the DOM using the 'Microsoft HTML Object Library' (MSHTML) type library. The question asks if IE is unavailable what to do. I am in the same situation for my box running Windows 10.
I had suspected it was possible to spin up an instance of MSHTML.HTMLDocument independent of IE but its creation is not obvious. Thanks to the questioner for asking this now. The answer lies in the MSHTML.IHTMLDocument4.createDocumentFromUrl method. One needs a local file to work (EDIT: actually one can put a webby url in as well!) with but we have a nice tidy Windows API function called URLDownloadToFile to download a file.
This codes runs on my Windows 10 box where Microsoft Edge is running and not Internet Explorer. This is an important find and thanks to the questioner for raising it.
Option Explicit
'* Tools->Refernces Microsoft HTML Object Library
'* MSDN - URLDownloadToFile function - https://msdn.microsoft.com/en-us/library/ms775123(v=vs.85).aspx
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
(ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, _
ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Sub Test()
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim sLocalFilename As String
sLocalFilename = Environ$("TMP") & "\urlmon.html"
Dim sURL As String
sURL = "https://stackoverflow.com/users/3607273/s-meaden"
Dim bOk As Boolean
bOk = (URLDownloadToFile(0, sURL, sLocalFilename, 0, 0) = 0)
If bOk Then
If fso.FileExists(sLocalFilename) Then
'* Tools->Refernces Microsoft HTML Object Library
Dim oHtml4 As MSHTML.IHTMLDocument4
Set oHtml4 = New MSHTML.HTMLDocument
Dim oHtml As MSHTML.HTMLDocument
Set oHtml = Nothing
'* IHTMLDocument4.createDocumentFromUrl
'* MSDN - IHTMLDocument4 createDocumentFromUrl method - https://msdn.microsoft.com/en-us/library/aa752523(v=vs.85).aspx
Set oHtml = oHtml4.createDocumentFromUrl(sLocalFilename, "")
'* need to wait a little whilst the document parses
'* because it is multithreaded
While oHtml.readyState <> "complete"
DoEvents '* do not comment this out it is required to break into the code if in infinite loop
Wend
Debug.Assert oHtml.readyState = "complete"
Dim sTest As String
sTest = Left$(oHtml.body.outerHTML, 100)
Debug.Assert Len(Trim(sTest)) > 50 '* just testing we got a substantial block of text, feel free to delete
'* page specific logic goes here
Dim htmlAnswers As Object 'MSHTML.DispHTMLElementCollection
Set htmlAnswers = oHtml.getElementsByClassName("answer-hyperlink")
Dim lAnswerLoop As Long
For lAnswerLoop = 0 To htmlAnswers.Length - 1
Dim vAnswerLoop
Set vAnswerLoop = htmlAnswers.Item(lAnswerLoop)
Debug.Print vAnswerLoop.outerText
Next
End If
End If
End Sub
Thanks for asking this.
P.S. I have used TaskList to verify that IExplore.exe is not created under the hoods when this code runs.
P.P.S If you liked this then see more at my Excel Development Platform blog

Parse JSON/XML parameters from web API

This is a quick and dirty POC I have so far from other helpful Stack posts:
Public Function WebRequest(url As String) As String
Dim http As MSXML2.xmlhttp
Set http = CreateObject("MSXML2.ServerXMLHTTP")
http.open "GET", url, False
http.send
WebRequest = http.responseText
Set http = Nothing
End Function
Private Sub Command1_Click()
Dim http As MSXML2.xmlhttp
Dim result As String
Dim url As String
Dim productId As String
productId = "2"
url = "http://localhost:1111/api/products/" & productId
result = WebRequest(url)
MsgBox result
End Sub
This calls a simple web API and returns as expected. The response reads as:
{"Id":2,"Name":"Yo-yo","Category":"Toys","Price":3.75}
What is the best way to assign the parameters to variables for use within the rest of the app?
There is no "best" way to parse JSON, but there are several existing VB6 classes for doing so. There is nothing built into VB6 or in Windows you can use though, so there isn't any obvious choice to reach for first.
If you don't want to use an existing VB6 class or a 3rd party library then you could just "manually" do the parsing with your own code. As long as the JSON you expect is pretty simple that might be all you need.
Many pitfalls here but it works for your very simple case as long as no other data types are used, the strings never have quotes or escaped symbols, etc.:
Option Explicit
Private Sub Main()
Const SIMPLE_JSON As String = _
"{""Id"":2,""Name"":""Yo-yo"",""Category"":""Toys"",""Price"":3.75}"
Dim JsonItems() As String
Dim Collection As Collection
Dim I As Long
Dim Parts() As String
Dim Value As Variant
JsonItems = Split(Mid$(SIMPLE_JSON, 2, Len(SIMPLE_JSON) - 2), ",")
Set Collection = New Collection
For I = 0 To UBound(JsonItems)
Parts = Split(JsonItems(I), ":")
Parts(0) = Mid$(Parts(0), 2, Len(Parts(0)) - 2)
If Left$(Parts(1), 1) = """" Then
Value = Mid$(Parts(1), 2, Len(Parts(1)) - 2)
Else
Value = Val(Parts(1))
End If
Collection.Add Array(Parts(0), Value), Parts(0)
Next
With Collection
For I = 1 To .Count
Debug.Print .Item(I)(0); "="; .Item(I)(1)
Next
End With
End Sub
Result:
Id= 2
Name=Yo-yo
Category=Toys
Price= 3.75
The Val() function is used for the non-String values because it is locale blind (always uses the invariant locale, which JSON numbers should always be formatted for).

Instr Access VBA - search for Numeric followed by Letter

Sorry if this has been posted elsewhere as I could not find the answer.
I'm trying to search for any number followed by the letter "m" using the InStr function. I've got the following code which I thought should have worked however it does not recognise "1m" 1.1m" or any variation and returns 0.
Public Function instrstring(strTest As String) As Long
Dim i As Long
PosOfFirstDigit = 0
For i = 1 To Len(strTest)
If Mid$(strTest, i, 1) Like "#" & "m" Then
PosOfFirstDigit = i
Exit For
End If
Next
End Function
I appreciate your help!
To return the position of the match something like this:
For
"a1.1m"
"testme 1m"
"testme 222"
Returns
2
8
not found
Sub Impeached()
Debug.Print StrOut("a1.1m")
Debug.Print StrOut("testme 1m")
Debug.Print StrOut("testme 222")
End Sub
code
Public Function StrOut(strIn As String) As String
Dim objRegex As Object
Set objRegex = CreateObject("vbscript.regexp")
With objRegex
.Pattern = "(\d*\.)?\dm"
If .Test(strIn) Then
StrOut = InStr(strIn, .Execute(strIn)(0))
Else
StrOut = "not found"
End If
End With
End Function
As #Tim Williams has mentioned, it's best using regular expressions (Regex) for this if you're having floats as well as integers.
You'll need to setup the reference to Regex to use it. Add VBA reference to "Microsoft VBScript Regular Expressions 5.5"
The regex you'll need is
Dim RE As New RegExp
With RE
.Global = True
.Pattern = "\d*?\.\dm"
End With
If RE.Test(strTest) Then
Msgbox("Found!")
'Insert the function you want to perform here
End If

database search via username

I'm developing a call log system, and for tracking purposes the manager wants each user to be logged in upon entry.
I have a module that displays the current logged on user with the code below. I would like for the system to search the table "TBL_Users" for the username and in the text boxes display all the information pertinent to that username. Should that user not be in the database i need to display an error and not allow the user to progress into the system. I'm aware i may need to use a Dlookup but I'm unsure how to code this.
Option Compare Database
Private Declare Function apiGetUserName Lib "advapi32.dll" Alias _
"GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Function fOSUserName() As String
' Returns the network login name
Dim lngLen As Long, lngX As Long
Dim strUserName As String
strUserName = String$(254, 0)
lngLen = 255
lngX = apiGetUserName(strUserName, lngLen)
If (lngX > 0) Then
fOSUserName = Left$(strUserName, lngLen - 1)
Else
fOSUserName = vbNullString
End If
End Function
After playing around with Dlookup for a while, I need the text-boxes to populate on form load. This is the Dlookup i used.
Private Sub Form_Load()
Windows_Logontxt = fOSUserName()
'agentname = DLookup("Agent_Name", "TBL_Users", "Windows_Logon=" & Windows_Logontxt)
End Sub
It seems Windows_Logon and Windows_Logontxt are text values, so enclose Windows_Logontxt in quotes when you create the string for the third argument to DLookup.
DLookup("Agent_Name", "TBL_Users", "Windows_Logon='" & Windows_Logontxt & "'")

access vba get cyrillic text from ini file into database

2012/08/31 : Updated my Post
searched all the web for it, found pieces but nothing really helped so i turn to you.
Information about environment:
Programming language is VBA / Access 2003
Data will be read from existing ".ini" File
Data should be inserted into Access Database
Now to my Problem:
I've got a ini file with information inside an ini file. The file looks something like this:
[product_details]
product_description=my product description
product_name=my product
product_price=11.0
product_sku=myproduct2012
these information are saved into "products.ini", when open in notepad or notepad++ it will be displayed correct and can be inserted into my access database and i can display these information in my form
but now someone wants to have something like this:
[product_details]
product_description=мое описание продукта
product_name=мой продукт
product_price=11.0
product_sku=произведение2012
when loading these information via GetINIValue the Value will be saved into Database as unreadable text.
edit: also in Notepad / Notepad++ it is displayed correct, so the cyrillic chars are transferred correct into the ini-file
I really tried many things (using UNICODE Version of GetINIValue, get Code of Char etc., check if Cyrillic text) nothing helped.
What it should do:
I need help to get the Value from this ini entry no matter what language (in this case, English, German, french, Russian are just enough)
Hope someone could help me.
Edit: I've tried Remou's Testing with this Peace of Code open it up by following:
Dim SQL As String
Dim strValue As String
strValue = GetValueOf("product_details","product_description","C:\cyrillic.txt")
SQL = "UPDATE [products] SET [product_description]='" & strValue & "' WHERE [product_id]=23;"
CurrentDb.Execute SQL,dbseechanges
Heres the Code of my Function to read out the Specific Line i need:
Public Function GetValueOf(ByVal Section As String, ByVal Entry As String, ByVal File As String)
Dim fs As New FileSystemObject
Dim ts As TextStream
Dim temp As String
Dim response As String
Dim intresponses As String
Dim SectionFoundBegin As Boolean
Dim SectionFoundEnd As Boolean
Dim DoNext As Boolean
Dim Parse() As String
Dim Finished As Boolean
SectionFoundBegin = False
SectionFoundEnd = False
Set ts = fs.OpenTextFile(File, ForReading, , TristateTrue)
response = ""
intresponses = 1
Finished = False
Do
DoNext = False
temp = ts.ReadLine
If (Not Finished) Then
If (temp = "[" & Section & "]") And Not DoNext Then
SectionFoundBegin = True
DoNext = True
End If
If ((InStr(1, temp, "[") > 0) And (SectionFoundBegin)) And Not DoNext Then
SectionFoundEnd = True
DoNext = True
End If
If (SectionFoundBegin And Not SectionFoundEnd) And Not DoNext Then
If (InStr(1, temp, "=") > 0) Then
Parse = Split(temp, "=")
If (Parse(0) = Entry) Then
While (intresponses <= UBound(Parse))
response = response + Parse(intresponses)
intresponses = intresponses + 1
Wend
DoNext = True
Else
DoNext = True
End If
Else
DoNext = True
End If
End If
End If
Loop Until ts.AtEndOfStream
GetValueOf = response
End Function
What i need:
Something like:
"UPDATE [products] SET [product_description]='мое описание продукта' WHERE [product_id]=23;"
What i get:
"UPDATE [products] SET [product_description]='??? ???????? ????????' WHERE [product_id]=23;"
UPDATE:
Well now i really your help:
I've inserted the following Code:
Public Function GetUnicodeValueOf(ByVal Section As String, ByVal Entry As String, ByVal File As String)
Dim fs As Object
Dim ts As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Dim temp As String
Dim strResponse As String
Dim intResponses As Integer
Dim SectionFoundBegin As Boolean
Dim SectionFoundEnd As Boolean
Dim DoNext As Boolean
Dim Parse() As String
Dim Finished As Boolean
On Error GoTo Error_GetUnicodeValueOf
SectionFoundBegin = False
SectionFoundEnd = False
Set ts = fs.OpenTextFile(File, ForReading, , TristateTrue)
strResponse = ""
intResponses = 1
Finished = False
Do
DoNext = False
temp = ts.ReadLine
If (Not Finished) Then
If (temp = "[" & Section & "]") And Not DoNext Then
SectionFoundBegin = True
DoNext = True
End If
If ((InStr(1, temp, "[") > 0) And (SectionFoundBegin)) And Not DoNext Then
SectionFoundEnd = True
DoNext = True
End If
If (SectionFoundBegin And Not SectionFoundEnd) And Not DoNext Then
If (InStr(1, temp, "=") > 0) Then
Parse = Split(temp, "=")
If (Parse(0) = Entry) Then
While (intResponses <= UBound(Parse))
strResponse = strResponse + Parse(intResponses)
intResponses = intResponses + 1
Finished = True
Wend
DoNext = True
Else
DoNext = True
End If
Else
DoNext = True
End If
End If
End If
Loop Until ts.AtEndOfStream
Exit_GetUnicodeValueOf:
GetUnicodeValueOf = strResponse
Exit Function
Error_GetUnicodeValueOf:
ActionLogging "Fehler beim Parsen der Datei '" & File & "'"
Resume Exit_GetUnicodeValueOf
End Function
by using this file (saved as UTF-8 without BOM) on my Harddisc:
[product_details]
manufacturer_name=
product_id=50
sku=BU-01722
set=4
type=simple
type_id=simple
color=11
ean=
name=Колесникова
description=[LANGTEXT] Колесникова Е.В Я считаю до двадцати [Рабочая тетрадь] 6-7л
short_description=[KURZTEXT] Колесникова Е.В
old_id=
weight=1.0000
news_from_date=
news_to_date=
status=1
url_key=kolesnikova
url_path=kolesnikova.html
visibility=4
gift_message_available=2
required_options=0
has_options=0
image_label=
small_image_label=
thumbnail_label=
created_at=2012-06-25 07:58:29
updated_at=2012-07-27 09:06:24
price=2.0000
special_price=
special_from_date=
special_to_date=
cost=
tax_class_id=2
minimal_price=
enable_googlecheckout=1
meta_title=
meta_keyword=
meta_description=
is_recurring=0
recurring_profile=
custom_design=
custom_design_from=
custom_design_to=
custom_layout_update=
page_layout=
options_container=container2
and i need to have:
[LANGTEXT] Колесникова Е.В Я считаю до двадцати [Рабочая тетрадь] 6-7л
from INI-Key: description
into my access database.
First it works as it should but now when i'm loading a file that is saved with "TriStateTrue"
everything ends up in : ?????????????????????????????????????????????
in one line.
With TriStateMixed, everything is parsed well except of the cyrillic text which comes like
КолеÑникова Е.Ð’ Я Ñчитаю до двадцати [Ð Ð°Ð±Ð¾Ñ‡Ð°Ñ Ñ‚ÐµÑ‚Ñ€Ð°Ð´ÑŒ] 6-7л
i searched the sourcecode and didn't found the error.
FILE is UTF-8 without BOM (coming from selfwritten Web API for Magento)
Using Access 2003
Need to get Cyrillic Text into my Database where also German / English Texts could be inside the File
Long time ago, i asked this Question and finally got the answer, but because of the lack of time i didn't managed to "Answer myself" here and for other who might have these problems.
First of all, about the Read-Problem:
The Edit from my Question with TryStateTrue was the Right answer, this was the correct line which was needed to load
But now there's the Catch:
The Rules in VBA(6 or lower) are simple:
What will be saved in an String will be stored as ASCII Value. So every Char which is not an ASCII Code will be thrown away and saved as "?"
How did i managed to save those Data?
I Managed to save those Data by using an selfwritten Tool in C# (.NET) which can Handle UTF-8 Strings and can Connect to the Database.
Save Section + Key in List or set as Executable Parameters and where you will "UPDATE" the Value
e.g.:
[product_details]\name;productsTableName;productsNameField;IdentKeyField;IdentKeyValue
open Executable with Arguments or without and load the List
Connect to the desired Access-Database
Read the Section\Key-Value and Send to the Database directly by UPDATE-STATEMENT
e.g:
"UPDATE [productsTableName] SET [productsNameField]='" + ValueFromSectionKey + "' WHERE [IdentKeyField]=IdentKeyValue
Disconnect Database
Close Program
The Result:
a little bit slower at first because writing down what Huge List of Informations
also Writing down everything inside the Database, also with Errors (?????? instead of считаю) secures that if your file is ASCII-"readable" you didn't forget anything
beautiful UTF-8-Encoded and Readable Text inside an Access 2003 Database
The Pros about this Method
outsourced and expendable Tool, when written correctly it can be used for other projects too
understanable Code in Access (you write down informations, and after everything was listed you open up a Program which process these)
very fast when optimized (read the Length and split the list into multiple workers which update the database simultanously)
The Cons about this Method
outsourced
no possibility to save directly into a variable inside VBA(6 or lower)
external tool could be blocked by firewall
before "updating" Database there is unreadable Text inside the Database
more Update-Calls on Database as directly
user-typos inside list or Text containing the delimiter may let the UPDATE statement fail.
Hope i could help.