I am having a single ms access form with two unbound text boxes where I am showing two variants of PANTONE colors which are converted from Hex values to RGB (BGR) values in two public functions. I have about 2 thousand different colors.
The two Hex text boxes I have are named [tpx_hex] and [tcx_hex]. The two unbound text boxes are named [tpx_color] and [tcx_color].
My code (see below) works fine in a single form as shown below, but when I try to do the same in a continuous form then all the unbound textboxes turn black.
I would be grateful for some kind of guidance or a solution to my color issue.
Thanks in advance.
Private Sub Form_Current()
If IsNull(tpx_hex) Then
Exit Sub
Else
Me.tpx_color.BackColor = Color_tpx_Hex_To_Long([tpx_hex])
End If
If IsNull(tcx_hex) Then
Exit Sub
Else
Me.tcx_color.BackColor = Color_tcx_Hex_To_Long([tcx_hex])
End If
End Sub
Public Function Color_tpx_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_tpx_Hex_To_Long = RGB(iBlue, iGreen, iRed)
End Function
Public Function Color_tcx_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_tcx_Hex_To_Long = RGB(iBlue, iGreen, iRed)
End Function
In a continuos form, all unbound controls will share the same properties.
A workaround is to create a form with a bunch of colour boxes as in my example here:
VBA.ModernTheme
Another could be to create a tiny picture for each form (a few pixels, that you zoom), and then use a picture control. I used that method here:
VBA.PictureUrl
Looks like you have the tough work done already with your custom color functions.
I think you could easily solve this issue by adding the two color fields to your table - say TPX_COLOR and TCX_COLOR - defined as LONG
Then run an update query that sets those fields using your public functions.
I just set the null values to #000000 so it'll display a black box even if your Hex color is null
This should work using the field names matching your example
UPDATE [My-Color_Table_Name]
SET TPX_COLOR = Color_tpx_Hex_To_Long(NZ([tpx_hex],"#000000")),
TCX_COLOR = Color_tcx_Hex_To_Long(NZ([tcx_hex],"#000000"))
Make sure to bind your tpx_color and tcx_color form fields to the new ones in your table.
Then your Form_Current code could change to setting the Foreground and Background colors to the same value - effectively hiding the field's value:
Private Sub Form_Current()
Me.tpx_color.ForeColor = [TPX_COLOR]
Me.tpx_color.BackColor = [TPX_COLOR]
Me.tcx_color.ForeColor = [TCX_COLOR]
Me.tcx_color.BackColor = [TCX_COLOR]
End Sub
I am creating a third party add in for my CAD program that has a sub in it that goes through a drawing and finds all the parts lists (BOMS), if any items in the parts list are shared between the BOM (1 part being used in 2 weldments for example) then it changes the item number of the second instance to be that of the first instance. It does this by comparing full file names between the two values. When they match change the number to that of the matcher. I have got this to work but it runs a little slow because for a 100 item BOM each item is compared to 100 and thus that takes a little longer then I would like (about 60seconds to run). After thinking about it I realized I did not need to compare each item to all the items, I just needed to compare until it found a duplicate and then exit the search loop and go to the next value. Example being Item 1 does not need to compare to the rest of the 99 values because even if it does have a match in position 100 I do not want to change item 1s number to that of item 100. I want to change item 100 to that of 1(ie change the duplpicate to that of the first encountered double). For my code however I am having trouble exiting the comparison for loops which is causing me trouble. An example of the trouble is this:
I have 3 BOMs, each one shares Part X, and is numbered 1 in BOM 1, 4 in BOM 2, and 7 in BOM 3. when I run my button because I cannot get it to leave the comparison loop once it finds it first match all the Part X's ended up getting item number 7 from BOM 3 because it is the last instance. (I can get this to do what I want by stepping through my for loops backwards and thus everything ends up as the top most occurrence, but I would like to get my exit fors working because it saves me on unnecessary comparisons)
How do I go about breaking out of the nested for loops using an if conditional?
Here is my current code:
Public Sub MatchingNumberR1()
Debug.Print ThisApplication.Caption
'define active document as drawing doc. Will produce an error if its not a drawing doc
Dim oDrawDoc As DrawingDocument
Set oDrawDoc = ThisApplication.ActiveDocument
'Store all the sheets of drawing
Dim oSheets As Sheets
Set oSheets = oDrawDoc.Sheets
Dim oSheet As Sheet
'Loop through all the sheets
For Each oSheet In oSheets
Dim oPartsLists As PartsLists
Set oPartsLists = oSheet.PartsLists
'Loop through all the part lists on that sheet
Dim oPartList As PartsList
'For every parts list on the sheet
For Each oPartList In oPartsLists
For i3 = 1 To oPartList.PartsListRows.Count
'Store the Item number and file referenced in that row to compare
oItem = FindItem(oPartList)
oDescription = FindDescription(oPartList)
oDescripCheck = oPartList.PartsListRows.Item(i3).Item(oDescription).Value
oNumCheck = oPartList.PartsListRows.Item(i3).Item(oItem).Value
'Check to see if the BOM item is a virtual component if it is do not try and get the reference part
If oPartList.PartsListRows.Item(i3).ReferencedFiles.Count = 0 Then
oRefPart = " "
End If
'Check to see if the BOM item is a virtual component if it is try and get the reference part
If oPartList.PartsListRows.Item(i3).ReferencedFiles.Count > 0 Then
oRefPart = oPartList.PartsListRows.Item(i3).ReferencedFiles.Item(1).FullFileName
End If
MsgBox (" We are comparing " & oRefPart)
'''''Create a comparison loop to go through the drawing that checks the oRefPart against other BOM items and see if there is a match.'''''
'Store all the sheets of drawing
Dim oSheets2 As Sheets
Set oSheets2 = oDrawDoc.Sheets
Dim oSheet2 As Sheet
'For every sheet in the drawing
For Each oSheet2 In oSheets2
'Get all the parts list on a single sheet
Dim oPartsLists2 As PartsLists
Set oPartsLists2 = oSheet2.PartsLists
Dim oPartList2 As PartsList
'For every parts list on the sheet
For Each oPartList2 In oPartsLists2
oItem2 = FindItem(oPartList2)
oDescription2 = FindDescription(oPartList2)
'Go through all the rows of the part list
For i6 = 1 To oPartList2.PartsListRows.Count
'Check to see if the part is a not a virtual component, if not, get the relevent comparison values
If oPartList2.PartsListRows.Item(i6).ReferencedFiles.Count > 0 Then
oNumCheck2 = oPartList2.PartsListRows.Item(i6).Item(oItem2).Value
oRefPart2 = oPartList2.PartsListRows.Item(i6).ReferencedFiles.Item(1).FullFileName
'Compare the file names, if they match change the part list item number for the original to that of the match
If oRefPart = oRefPart2 Then
oPartList.PartsListRows.Item(i3).Item(1).Value = oNumCheck2
''''''''This is where I want it to exit the loop and grab the next original value'''''''
End If
'For virtual components get the following comparison values
ElseIf oPartList2.PartsListRows.Item(i6).ReferencedFiles.Count = 0 Then
oNumCheck2 = oPartList2.PartsListRows.Item(i6).Item(oItem2).Value
oDescripCheck2 = oPartList2.PartsListRows.Item(i6).Item(oDescription2).Value
'Compare the descriptions and if they match change the part list item number for the original to that of the match
If oDescripCheck = oDescripCheck2 Then
oPartList.PartsListRows.Item(i3).Item(1).Value = oNumCheck2
''''''''This is where I want it to exit the loop and grab the next original value'''''''
End If
Else
''''''''This is where if no matches were found I want it to continue going through the comparison loop'''''''
End If
Next
Next
Next
Next
Next
Next
'MsgBox ("Matching Numbers has been finished")
End Sub
For escape from nested for loop you can use GoTo and specify where.
Sub GoToTest()
Dim a, b, c As Integer
For a = 0 To 1000 Step 100
For b = 0 To 100 Step 10
For c = 0 To 10
Debug.Print vbTab & b + c
If b + c = 12 Then
GoTo nextValueForA
End If
Next
Next
nextValueForA:
Debug.Print a + b + c
Next
End Sub
Here are a few examples that demonstrate (1) breaking out of (exiting) a loop and (2) finding the values in arrays.
The intersection of 2 arrays example can be modified to meet your need to "Create a comparison loop to go through the drawing that checks the oRefPart against other BOM items and see if there is a match." Note, you may find multiple matches between 2 arrays.
Option Explicit
Option Base 0
' Example - break out of loop when condition met.
Public Sub ExitLoopExample()
Dim i As Integer, j As Integer
' let's loop 101 times
For i = 0 To 100:
j = i * 2
'Print the current loop number to the Immediate window
Debug.Print i, j
' Let's decide to break out of the loop is some
' condition is met. In this example, we exit
' the loop if j>=10. However, any condition can
' be used.
If j >= 10 Then Exit For
Next i
End Sub
' Example - break out of inner loop when condition met.
Public Sub ExitLoopExample2()
Dim i As Integer, j As Integer
For i = 1 To 5:
For j = 1 To 5
Debug.Print i, j
' if j >= 2 then, exit the inner loop.
If j >= 2 Then Exit For
Next j
Next i
End Sub
Public Sub FindItemInArrayExample():
' Find variable n in array arr.
Dim intToFind As Integer
Dim arrToSearch As Variant
Dim x, y
intToFind = 4
arrToSearch = Array(1, 2, 3, 4, 5, 6, 7, 8, 9)
x = FindItemInArray(FindMe:=intToFind, _
ArrayToSearch:=arrToSearch)
If IsEmpty(x) Then
Debug.Print intToFind; "not found in arrToSearch"
Else
Debug.Print "found "; x
End If
intToFind = 12
y = FindItemInArray(FindMe:=intToFind, _
ArrayToSearch:=arrToSearch)
If IsEmpty(y) Then
Debug.Print intToFind; "not found in arrToSearch"
Else
Debug.Print "found "; y
End If
End Sub
Public Function FindItemInArray(FindMe, ArrayToSearch As Variant):
Dim i As Integer
For i = LBound(ArrayToSearch) To UBound(ArrayToSearch)
If FindMe = ArrayToSearch(i) Then
FindItemInArray = ArrayToSearch(i)
Exit For
End If
Next i
End Function
' Create a comparison loop to go through the drawing that checks
' the oRefPart against other BOM items and see if there is a match.
Public Sub ArrayIntersectionExample():
Dim exampleArray1 As Variant, exampleArray2 As Variant
Dim arrIntersect As Variant
Dim i As Integer
' Create two sample arrays to compare
exampleArray1 = Array(1, 2, 3, 4, 5, 6, 7)
exampleArray2 = Array(2, 4, 6, 8, 10, 12, 14, 16)
' Call our ArrayIntersect function (defined below)
arrIntersect = ArrayIntersect(exampleArray1, exampleArray2)
' Print the results to the Immediate window
For i = LBound(arrIntersect) To UBound(arrIntersect)
Debug.Print "match " & i + 1, arrIntersect(i)
Next i
End Sub
Public Function ArrayIntersect(arr1 As Variant, arr2 As Variant) As Variant:
' Find items that exist in both arr1 and arr2 (intersection).
' Return the intersection as an array (Variant).
Dim arrOut() As Variant
Dim matchIndex As Long
Dim i As Long, j As Long
' no matches yet
matchIndex = -1
' begin looping through arr1
For i = LBound(arr1) To UBound(arr1)
' sub-loop for arr2 for each item in arr1
For j = LBound(arr2) To UBound(arr2)
' check for match
If arr1(i) = arr2(j) Then
' we found an item in both arrays
' increment match counter, which we'll
' use to size our output array
matchIndex = matchIndex + 1
' resize our output array to fit the
' new match
ReDim Preserve arrOut(matchIndex)
' now store the new match our output array
arrOut(matchIndex) = arr1(i)
End If
Next j
Next i
' Have the function return the output array.
ArrayIntersect = arrOut
End Function
I have a listbox on a form that contains 6 values. The user is allowed to select multiple values at once. For each value selected I want to assign this value to a variable.
My listbox is called: lstFilterUnits
The listbox contents are as follows:
Blue, Red, Green, Yellow, Orange, White
I understand that the following is associated with each colour:
Forms("Form1").lstFilterUnits.Selected(0) 'Blue Selected
Forms("Form1").lstFilterUnits.Selected(1) 'Red Selected
Forms("Form1").lstFilterUnits.Selected(2) 'Green Selected
Forms("Form1").lstFilterUnits.Selected(3) 'Yellow Selected
Forms("Form1").lstFilterUnits.Selected(4) 'Orange Selected
Forms("Form1").lstFilterUnits.Selected(5) 'White Selected
I have attempted to do this using the below code in the listbox on click event:
As you can see I had to hard code the value assigned to the vUnit variable as anytime I try get the value associated with the list box with either of the lines commented out it doesn't work.
Dim vUnit As String
If Forms("Form1").lstFilterUnits.Selected(0) = True Then
vUnit = "Blue
MsgBox (vUnit)
'MsgBox "You selected " & lstFilterUnits.Value 'Returns null value
'MsgBox "You selected " & lstFilterBusinessUnits.SelectedValue 'Returns Compile error
ElseIf Forms("Form1").lstFilterUnits.Selected(1) = True Then
vUnit = vUnit & ", Red'"
MsgBox (vUnit)
End If
So for the above code I can't seem to assign the value associated with the selected item to a variable. I also want to me able to display multiple values in the variable if they are selected, however if I select more than one value using the above method it will only go into the first if statement that is true, due to this I think I should be using some sort of a loop to assign the variable multiple values but I'm new to VBA and d not know how to do this.
Any help would be appreciated, I think this is probably a simple task that I am overthinking.
EDIT:
After searching online I finally found something that is kind of doing what I need. However the output is also outputting the index number of the listbox. The code I found is below. I've tried playing around with it but can't seem to achieve my desired output.
The below code will output the following:
'1 , 'Blue', '2 'Red', 3 ,'Green',
Whereas I want it to output:
'Blue','Red', 'Green',
Does anyone know how I can achieve this? I've tried changing the column to both only i and J and this didn't seem to work. I've never worked with arrays in VBA before so will admit I don't understand the code fully and the form I found it on didn't explain the code, it was just providing a solution for another user.
Dim i As Long
Dim J As Long
Dim Msg As String
Dim arrItems() As String
ReDim arrItems(0 To lstFilterUnits.ColumnCount - 1)
For J = 0 To lstFilterUnits.ListCount - 1
If lstFilterUnits.Selected(J) Then
For i = 0 To lstFilterUnits.ColumnCount - 1
arrItems(i) = lstFilterUnits.Column(i, J)
Next i
Msg = Msg & "'" & Join(arrItems, " , '") & "', "
End If
Next J
MsgBox Msg
Use the .ItemsSelected collection. It already has all the items.
EXAMPLE:
Sub Example()
dim ctl as Control
Set ctl = Forms("Form1").lstFilterUnits
Dim varItm As Variant
For Each varItm In ctl.ItemsSelected
Debug.Print ctl.ItemData(varItm)
Next varItm
End Sub
SOURCE: https://learn.microsoft.com/en-us/office/vba/api/access.listbox.itemsselected
Have a try on it.
Private Sub lstFilterUnits_Click()
Dim ctl As Control
Dim varItm As Variant
Dim SelectedColor As String
Set ctl = Forms!Form1!lstFilterUnits
For Each varItm In ctl.ItemsSelected
SelectedColor = SelectedColor & vbCrLf & ctl.ItemData(varItm) 'This for each color in each line
'SelectedColor = SelectedColor & "," & ctl.ItemData(varItm) ' This line for comma separated color
Next varItm
MsgBox SelectedColor
End Sub
I have custom that creates of map of the US in powerpoint.
Sub ArrayLoop(array1, array2, amountOfLine)
Dim i As Long
For i = 0 To amountOfLine
With ActivePresentation.Slides(1).Shapes.AddLine(BeginX:=array1(i), BeginY:=array2(i), EndX:=array1(i + 1), EndY:=array2(i + 1)).Line
.DashStyle = msoLineDashDotDot
.ForeColor.RGB = RGB(50, 0, 128)
End With
Next
End Sub
Sub TestArrayLoop()
Dim USA1, USA2
Dim amount As Integer
USA1 = Array(316.0954, 321.021, 332.9831, 337.205, 337.205, 346.4698,
351.3953, 354.9135, 361.9501, 367.5793, 370.394, 371.8012, 374.6158, 376.7268,
375.3195, 376.7268, 383.0596, 385.1706, 378.8377, 376.0232, 378.1341,
378.8377, 368.9866, 364.061, 366.172, 371.0976, 373.9122, 382.356, 388.6888,
393.6144, 397.1327, 394.318, 393.6144, _
384.4669, 384.4669, 376.7268, 374.6158, 369.6902, 368.2829, 366.172,
366.172,
361.9501, 358.4318, 354.9135, 350.6917, 347.8771, 347.8771, 347.8771,
347.1734, 346.4698, 350.6917, 343.6551, 345.0624, 342.2478, 339.4332,
337.9087,
330.8721, 317.5027, 314.6881, 312.5772, 310.4662, 316.0954, 319.6137,
323.132, 325.2429, 327.3539, 328.7612, 335.7977, 339.4332, 337.205,
338.7296,
335.7977, 331.5757, 330.1685, 325.9465, 324.5393, 322.4283, 319.6137,
318.2064, 315.3918, 313.9845, 309.7626, 306.2443, 306.2443, 311.1698,
311.8735,
308.3553, 306.2443, 303.4297, 302.0224, 297.0969, 290.0603, 285.8384, 279.5055, 280.2092, 280.9128, 278.8019, 275.2836, 267.5435, 264.0252, 265.4325,
260.5069, 254.8777, 247.1376, 242.212, 237.2865, 223.917, 220.3988, 214.7696, 211.2513, 206.9121, 206.9121, 214.0659, 219.6951, 227.4353, 232.3609,
231.6572, 233.7682, 239.3974, 247.1376, 247.8412, 309.0589, 316.0954)
USA2 = Array(247.1064, 248.5467, 254.3079, 263.6699, 267.9909, 265.1102, 260.7893, 260.0691, 258.6288, 251.4273, 252.1475, 259.349, 257.1885, 257.9087,
260.0691, 262.9498, 257.9087, 255.028, 254.3079, 249.987, 247.8265, 244.9459, 247.1064, 251.4273, 246.3862, 243.5056, 240.625, 241.3451, 240.625,
237.0242, 234.1435, 226.942, 223.3412, 218.3002, 215.4195, 200.2962, 206.7776, 208.218, 206.7776, 206.7776, 196.5754, 195.8553, 190.8142, 191.5343,
190.094, 190.8142, 194.415, 198.1357, 206.0575, 208.9381, 217.58, 224.0613, 234.8637, 237.0242, 235.5839, 222.621, 221.9009, 213.9792, 213.9792, 207.4978,
205.3373, 187.9335, 184.3327, 182.1723, 182.1723, 174.9708, 169.2095,
167.7692, _
164.8886, 158.4072, 154.0862, 150.4854, 149.7653, 156.9669, 163.4483, 155.5265, 152.6459, 156.2467, 152.6459, 147.6049, 141.1235, 133.9219, 144.0041,
147.6049, 151.9258, 156.2467, 159.8475, 158.4072, 158.4072, 162.0079, 160.5676, 160.5676, 157.687, 159.1273, 161.2878, 165.6087, 164.8886, 160.5676,
162.0079, 159.1273, 156.2467, 154.8064, 151.9258, 149.7653, 151.2056, 145.4444, 151.9258, 155.5265, 154.0862, 150.4854, 149.0452, 200.2962, 203.897,
201.0164, 215.4195, 219.0203, 224.7815, 229.1024, 237.0242, 242.0653, 245.6661, 245.6661, 247.1064)
amount = UBound(USA1) - LBound(USA2) + 1
amount = amount - 2
ArrayLoop USA1, USA2, amount
End Sub
This all works fine but the thing is that now I cant select the whole figure. So im looking for a way so I merge in it a figure which I can drag around the screen.
Any thoughts on how I can do this? Preferably in VBA
Your main issue is that you are adding many individual lines. For the code to work the way you envision, you somehow have to add your shape as a single line. To do this, change your sub from this:
Sub ArrayLoop(array1, array2, amountOfLine)
Dim i As Long
For i = 0 To amountOfLine
With ActivePresentation.Slides(1).Shapes.AddLine(BeginX:=array1(i), BeginY:=array2(i), EndX:=array1(i + 1), EndY:=array2(i + 1)).Line
.DashStyle = msoLineDashDotDot
.ForeColor.RGB = RGB(50, 0, 128)
End With
Next
End Sub
to this:
Sub ArrayLoop(array1, array2)
'you will need a single array of points for the call.
'whether you want to pass in 2 arrays and then merge them
'or pass in a single merged array is up to you
With ActivePresentation.Slides(1).Shapes.AddPolyline(<an array of points>).Line
.DashStyle = msoLineDashDotDot
.ForeColor.RGB = RGB(50, 0, 128)
End With
End Sub
You will need to tweak your array of points to get this to work.
I'm trying to get some data I input with another macro into a 2-dimensional array so I can then apply a function to that data, but no matter what I try I keep getting errors. The data includes strings and numbers. I could always just reference the cells and forget about the array, but that complicates the function. Here's my code:
(Declarations)
Dim nLiens As Byte, nCreditors As Byte
Dim SecurityV As Currency, ASecurityV As Currency
Const adjuster = 0.9
(Relevant subs)
Public Sub VariableDeclaration()
nLiens = InputBox("Enter number of liens in security")
nCreditors = InputBox("Enter number of creditors")
SecurityV = InputBox("Enter security full value")
ASecurityV = adjuster * SecurityV
Call ODebt
End Sub
Sub ODebt()
'
'(...)
'
Dim oDebt() As Variant
ReDim oDebt(1 To nCreditors + 1, 1 To nLiens + 1)
Dim rg As Range
Set rg = Range(Cells(1, 1), Cells(nCreditors + 1, nLiens + 1))
oDebt = rg.Value
MsgBox (oDebt)
'>>> ERROR: type mismatch
Call SAllocation
End Sub
I've tried other alternatives, such as setting the content cell by cell with two 'For' loops and LBound and UBound, but nothing seems to work.
You are getting your error not while filling, but at displaying the array.
It is not possible to just Msgbox an array, since Msgbox expects a String argument. You can, in the other hand, display specific positions (e.g. oDebt(1,1)).
If you want to have a look at all of its contents, either use debug mode and the Local window, or print it to some unused cells.
I would copy the values from the datasheet this way:
Dim oDebt As Variant
Dim rg As Range
Set rg = Range(Cells(1, 1), Cells(nCreditors + 1, nLiens + 1))
oDebt = rg ' get data from sheet
'... do calculations with oDebt array
rg = oDebt ' put data on sheet
In words: you dimension the array automatically by assigning the range. If you need the numeric boundaries, use
nrows = UBound(oDebt, 1)
ncols = UBound(oDebt, 2)
Here you see the meaning of the dimension as well, index 1 is rows, index 2 is columns.