So I'm trying to change the backcolor of a rectangle within Access. I know you can easily do this Box1.BackColor = RGB(0, 0, 0), however I want to enter a value into a textbox and then display that color value as soon as you update the textbox.
I thought the following would work, but it doesn't.
Textbox1 = 0, 0, 0
Dim P1 as String
P1 = "RGB(" + Textbox1.text + ")"
Box1.Backcolor = P1
How can I go about changing the backcolor on the fly?
You could split the text, run the entries though int and feed it to RGB:
Dim A As Variant
A = Split(Textbox1.text,",")
Box1.BackColor = RGB(Int(A(0)),Int(A(1)), Int(A(2)))
Based on your code, Eval() should work for you. The function evaluates a string as if were code. Backcolor is a long, btw so I adjusted your code accordingly.
Dim P1 as Long
P1 = eval("RGB(" + Textbox1.text + ")")
Box1.Backcolor = P1
Or you can ditch P1 and do this:
Box1.Backcolor = eval("RGB(" + Textbox1.text + ")")
Depending on what you are doing, you might just want to use the built in color dialog instead of entering text in a textbox.
Here's the API declaration and re-usable function
Declare Sub wlib_AccColorDialog Lib "msaccess.exe" Alias "#53" (ByVal Hwnd As Long, lngRGB As Long)
Function ChooseColor(nDefColor As Variant) As Long
Dim lngColor As Long
wlib_AccColorDialog Screen.ActiveForm.Hwnd, nDefColor
ChooseColor = nDefColor
End Function
And here would be your box call to these functions; it's passing the default color of the box so that will be chosen when the dialog is open.
Box1.BackColor = ChooseColor(Me.Box1.BackColor)
Related
It seems this problem should have a rather simplistic solution. When trying to run the dlookup for ID, I return a null value when using the RequestNum string. RequestNum is simply an AutoNumber. RequestNum does write to the popup form that is opening up on its own. Also, if i replace RequestNum with the actual number in the field I get the desired returned result. The only help I've been able to find online is that most people did not use '" & stringhere & "' though I obviously am. Any ideas? I'll be happy to supply any additional details if needed. Thanks in advance!
Private Sub lst_AdminDate1_DblClick(Cancel As Integer)
Dim IDx As String
Dim RequestNum As String
DoCmd.OpenForm "Administrative_LeaveCalendar_Detail"
RequestNum = Me.lst_AdminDate1.Column(2)
IDx = DLookup("[ID]", "TimeOffCalendar", "[RequestNumber] = '" & RequestNum & "'")
[Forms]![Administrative_LeaveCalendar_Detail]![txtAdminDateDetail_RN] = RequestNum
[Forms]![Administrative_LeaveCalendar_Detail]![txtAdminDateDetail_ID] = IDx
End Sub
What may confuse you is, that a listbox always returns strings even if the value was a number and is supposed to be used as such. Also, DLookup may return Null.
Thus, if [RequestNumber] is a Long (which is should be):
Private Sub lst_AdminDate1_DblClick(Cancel As Integer)
Dim IDx As Variant
Dim RequestNum As String
DoCmd.OpenForm "Administrative_LeaveCalendar_Detail"
RequestNum = Me.lst_AdminDate1.Column(2)
IDx = DLookup("[ID]", "TimeOffCalendar", "[RequestNumber] = " & RequestNum & "")
[Forms]![Administrative_LeaveCalendar_Detail]![txtAdminDateDetail_RN] = RequestNum
[Forms]![Administrative_LeaveCalendar_Detail]![txtAdminDateDetail_ID] = IDx
End Sub
I have some issues downloading an image (or zip sometimes) from a webpage.
I've checked a few forums about the topic where most of the time they suggest using the URLDownloadToFile function.
I tried to apply it but it doesn't seem to work.
Here's an example of the type of webpage I'm dealing with :
The type here is jpg but sometimes it can be a zip.
For the jpg case, I have two ways to do it:
Click on the View button, which will open a new webpage containing 1 image only, selecting that webpage and somehow dowloading the image, which I don't manage to do.
(There is a "Save Picture As" when you rigth click a picture manually, but how to access to this with VBA ? ) :
objIE.document.frames(1).frames(1).document.getElementById("notPrintable").document.getElementsByName("view")(0).Click 'This clicks on the View Button
attachment_url = "https://pumapgf-row.bmwgroup.net/puma/case/showfile.do?selectedIndex=" & elem_id & "&filename=" & elem_name & "%20%7C%20jpg%20%7C%20" & end_url ' this is the url of the new webpage which is opened when I click the view button
Set objIE = IEWindowFromLocation(attachment_url) ' I select the new webpage
Set IEDoc = objIE.document ' set document on it
The html from this new webpage in the case it's a jpg of course) looks like this:
What I tried to do then but unsuccessfully is to use the URLDownloadToFile function this way
Dim myImages As IHTMLElementCollection
Set myImages = IEDoc.getElementsByTagName("img")
returnValue = URLDownloadToFile(0, myImages(0).href, "P:\Alex\ABC.img", 0, 0)
Whether I create or not a such called file before I run the code, it doesn't make any difference. I also tried with .jpg, .img, .png.
myImages(0).href ends like this :
So I don't know if the fact that .href doesn't end with something like .jpg or .img is an issue.
Click on the Save As button : valid for both jpg and zip files, so would be a better solution. I manage to click on it of course, but the issue comes from the fact that Internet displays this and I have no idea how to deal with it.
Any idea how to do this ?
EDIT : Here is the properties window of the image
Assuming that you have a valid download URL (which I can't test based on the site in your question), all you should need to do to test if a file is a jpg is to download it and check for the presence of the JPEG file header:
Public Function FileIsJpg(filepath As String) As Boolean
Dim handle As Long
handle = FreeFile
Open filepath For Binary As #handle
Dim header As Integer
Get #handle, , header
'Note the byte order.
If header = &HD8FF Then
Get #handle, , header
If header = &HE0FF Or header = &H1FF Then
FileIsJpg = True
End If
End If
Close #handle
End Function
Note that for your usage, this will need error handling because of the possibility that URLDownloadToFile still has the file open. I'm assuming that you have some sort of wait mechanism in place (it's a non-blocking function). If not, you need to either use the native callback mechanisms or take a guess and used Application.Wait or something similar.
Example usage:
Private Declare 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
Private Const S_OK As Long = 0
Sub Examples()
Const TestJpgUrl As String = "https://www.gstatic.com/webp/gallery/1.jpg"
Const TestPngUrl As String = "https://www.gstatic.com/webp/gallery3/1.png"
Dim target As String
target = Environ$("TEMP") & "\test.png"
If URLDownloadToFile(0, TestPngUrl, target, 0, 0) = S_OK Then
'Wait for download to complete - a callback function would be better.
Application.Wait Now + TimeSerial(0, 0, 1)
MsgBox target & ": " & FileIsJpg(target)
End If
Kill target
target = Environ$("TEMP") & "\test.jpg"
If URLDownloadToFile(0, TestJpgUrl, target, 0, 0) = S_OK Then
Application.Wait Now + TimeSerial(0, 0, 1)
MsgBox target & ": " & FileIsJpg(target)
End If
Kill target
End Sub
Note that you can also explicitly test for zip files in a similar way, but I'll leave that as an exercise for the reader.
I'm having trouble setting the back ground colour of a textbox in my Access database. I want to change the colour to red when certain conditions are met.
In design view I've set the textbox's back color property to red and it is shown as '#ED1C24'. When I view the form in Form view the control is correctly shown in the red colour I've chosen.
But when I put this value into my VBA code (Text1.Backcolor = "#ED1C24") I get a type mismatch error.
I've tried changing it to a Hex number (Text1.Backcolor = &HED1C24) but then the control turns blue.
Any help would be appreciated. Thanks.
I wrote a blog about this very problem a while ago which should answer your question.
http://www.jht.co.uk/access-colour-color-codes/
Here's the code:
Public Function HTMLColour(HTMLCode As String, Optional Red As Variant, _
Optional Green As Variant, Optional Blue As Variant) As Long
On Error GoTo HTMLColour_Error
'Converts an HTML colour code number to a long interger
'Also returns the constituent R,G & B components through supplied parameters
Dim intR As Integer, intG As Integer, intB As Integer
Dim strHTML As String
'Strip # prefix if supplied
If Len(HTMLCode) < 6 Then Exit Function
strHTML = Right(HTMLCode, 6)
'Extract R, G, B values
intR = CInt("&H" & Mid(strHTML, 1, 2))
intG = CInt("&H" & Mid(strHTML, 3, 2))
intB = CInt("&H" & Mid(strHTML, 5, 2))
'Return optional parameters
If Not IsMissing(Red) Then Red = intR
If Not IsMissing(Green) Then Green = intG
If Not IsMissing(Blue) Then Blue = intB
'Convert RGB to Long integer
HTMLColour = RGB(intR, intG, intB)
HTMLColour_Exit:
Exit Function
HTMLColour_Error:
MsgBox Err.Description, vbExclamation, "Function HTMLColour"
Resume HTMLColour_Exit
End Function
Hope this helps.
The color code format in VBA is RGB or Long, and not HEX
In your case the easiest way is to call a function that will convert from HEX to Long:
Public Function Color_Hex_To_Long(strColor As String) As Long
Dim iRed As Integer
Dim iGreen As Integer
Dim iBlue As Integer
strColor = Replace(strColor, "#", "")
strColor = Right("000000" & strColor, 6)
iBlue = Val("&H" & Mid(strColor, 1, 2))
iGreen = Val("&H" & Mid(strColor, 3, 2))
iRed = Val("&H" & Mid(strColor, 5, 2))
Color_Hex_To_Long = RGB(iRed, iGreen, iBlue)
End Function
Use it like this :
Text1.BackColor = Color_Hex_To_Long("#ED1C24")
Simply use OnCurrent properties to set your font properties or other properties.
Instead of entering the Hex color codes, easier to use MS Access proprietary codes that are entirely in numbers. Do the easy way. Cheers! Mikey
For MS_ACCESS 2016 the long value seems to be just the .backcolor value, converting the HEX using the functions above won't work.
I'd just create a text box and a label, colour the label as you wish in design view and set the textbox value to txtBlue = lblBlue.backcolour in VBA.
I'm not sure if this is the case in other versions of excel but it seems to be the case in Office 2016.
I'm trying to make a button in an Access form which will run a couple queries and then take the resultant recordsets and put them into reports. I have gotten to the point where the button will call the module, it creates the proper recordsets, and then it creates the reports. However, the reports are blank, they don't have the data in them from the recordsets. I think my problem is that I haven't properly assigned the data source of the reports but I can't figure out how to if that is the issue.
Private Function showReport(sectionHeading As String, SQL As String, recordset As ADODB.Recordset)
Dim textBox As Access.textBox ' textbox control
Dim label As Access.label ' label control
Dim report As report ' hold report object
Dim controlTop As Long ' holds top value of control position
Dim controlLeft As Long ' holds left value of control position
Dim title As String 'holds title of report
Dim i As Integer 'iterator
i = 0
title = sectionHeading
controlLeft = 0
controlTop = 0
Set report = CreateReport
report.Width = 8500
report.Caption = title
Set label = CreateReportControl(report.Name, acLabel, _
acPageHeader, , "Title", 0, 0)
label.FontBold = True
label.FontSize = 12
label.SizeToFit
For Each fld In recordset.fields
Set textBox = CreateReportControl(report.Name, acTextBox, _
acDetail, , fld.Name, controlLeft + 1500, controlTop)
textBox.SizeToFit
Set label = CreateReportControl(report.Name, acLabel, acDetail, _
textBox.Name, fld.Name, controlLeft, controlTop, 1400, textBox.Height)
label.SizeToFit
controlTop = controlTop + textBox.Height + 25
i = i + 1
Next
Set label = CreateReportControl(report.Name, acLabel, _
acPageFooter, , Now(), 0, 0)
Set textBox = CreateReportControl(report.Name, acTextBox, _
acPageFooter, , "='Page ' & [Page] & ' of ' & [Pages]", report.Width - 1000, 0)
textBox.SizeToFit
report.RecordSource = SQL
DoCmd.OpenReport report.Name, acViewPreview
recordset.Close
Set recordset = Nothing
Set report = Nothing
End Function
I'd say you are missing a line like
report.RecordSource = "the query that fills <recordset>"
But I'm pretty sure that there must be a better way to achieve your goal than creating a new report from scratch.
And it's error-prone to name your variables like their data types (label, report, ...)
Edit
Are you sure your SQL is valid? Alternatively, you can try saving it as query and pass the query name.
I did a little test, it should work principally. r_tbProduct has an empty recordsource when I run this:
Dim rep As Report
DoCmd.OpenReport "r_tbProduct", acViewDesign
Set rep = Reports!r_tbProduct
rep.RecordSource = "SELECT * FROM tbProduct WHERE ID >= 6"
DoCmd.OpenReport "r_tbProduct", acViewPreview
It shows the correct data.
Again, I strongly suggest you rename your variables.
Dim report As report
is just asking for problems.
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 ^^