I have a procedure that should check the background colour of a selection of cells, and depending on the colour output a value and then colour the text to match the background.
However, every time this procedure is run, I get the following error. This also causes Excel to freeze, meaning that I have to close and reopen it (simply ending the macro doesn't stop that behavior) -
Run-time error '-2147417847 (80010108)':
Method 'ThemeColor' of object 'Font' failed
Can anyone help me find what I am doing wrong? Thanks.
Private Sub AssignBackgroundValue(ByVal Target As Range)
Dim val As Integer
Dim c As Range
For Each c In Target.Cells
With c.Interior
Select Case Target.Interior.ThemeColor
Case xlThemeColorAccent6
val = 1
Case xlThemeColorAccent5
val = 2
Case xlThemeColorAccent4
val = 3
Case xlThemeColorAccent3
val = 4
Case xlThemeColorAccent2
val = 5
Case xlThemeColorDark1
val = 6
Case xlThemeColorLight1
val = 7
End Select
c.Font.ThemeColor = IIf(VarType(.ThemeColor) = vbLong, .ThemeColor, 0)
c.Font.TintAndShade = IIf(VarType(.TintAndShade) = vbDouble, .TintAndShade, 0)
End With
c.value = val
Next
End Sub
You need to consider cases when you are using standard colors and no fill so:
Private Sub AssignBackgroundValue(ByVal Target As Range)
Dim val As Integer
Dim c As Range
For Each c In Target.Cells
With c.Interior
If IsError(Target.Interior.ThemeColor) Then
c.Font.PatternTintAndShade = 0
Else
Select Case Target.Interior.ThemeColor
Case xlThemeColorAccent6
val = 1
Case xlThemeColorAccent5
val = 2
Case xlThemeColorAccent4
val = 3
Case xlThemeColorAccent3
val = 4
Case xlThemeColorAccent2
val = 5
Case xlThemeColorDark1
val = 6
Case xlThemeColorLight1
val = 7
Case 0
val = 0
End Select
If val <> 0 Then
c.Font.ThemeColor = IIf(VarType(.ThemeColor) = vbLong, .ThemeColor, 0)
Else
c.Font.Color = IIf(VarType(.ThemeColor) = vbLong, .Color, 0)
End If
c.Font.TintAndShade = IIf(VarType(.TintAndShade) = vbDouble, .TintAndShade, 0)
End If
End With
c.Value = val
Next
End Sub
Related
I'm trying to add Items to my item list then load images in the inventory but keep ending up with this error and I'm not sure why. I'm making a game which uses visual basic and forms.
Public Class InvInterface
Public ItemMax As Integer = 9 'Number of inventory slots
Public Items As New List(Of Items)
Public Sub Add(Newitem As Items)
If Items.Count <= ItemMax Then
For Each I As Items In Items
If I.Name = Newitem.Name Then
If I.IsStackable = True And I.ItemCount < 16 Then
I.ItemCount += 1
Exit Sub
Else
Items.Add(Newitem)
Exit Sub
End If
End If
Next
Items.Add(Newitem)
End If
End Sub
Public Sub Remove(ItemID As Items)
If Items.Item(Items.IndexOf(ItemID)).ItemCount > 0 Then
Items.Item(Items.IndexOf(ItemID)).ItemCount -= 1
Else
Items.RemoveAt(Items.IndexOf(ItemID))
End If
End Sub
Public Sub UpdateInv()
For i = 1 To ItemMax
If 0 < Items.Count Then
Select Case i
Case 1
Inv11.Image = Items(i).ImageAsset
Case 2
Inv12.Image = Items(i).ImageAsset
Case 3
Inv13.Image = Items(i).ImageAsset
Case 4
Inv21.Image = Items(i).ImageAsset
Case 5
Inv22.Image = Items(i).ImageAsset
Case 6
Inv23.Image = Items(i).ImageAsset
Case 7
Inv31.Image = Items(i).ImageAsset
Case 8
Inv32.Image = Items(i).ImageAsset
Case 9
Inv33.Image = Items(i).ImageAsset
End Select
End If
Next
End Sub
Dim Cobblestone As New Items
Dim WoodPlank As New Items
Dim currancy As New Items
Dim Flower As New Items
Dim CactusPlant As New Items
Public Sub initialiseItems()
With cobblestone
.Item = ItemClass.Blocks
.Name = "Stone"
.Description = "Comes from the ground made from rock"
.IsStackable = True
.ImageAsset = My.Resources.Stone
End With
With WoodPlank
.Item = ItemClass.Blocks
.Name = "Wood"
.Description = "Wood planks can be used to create structures"
.IsStackable = True
.ImageAsset = My.Resources.Wood
End With
With Flower
.Item = ItemClass.Usable
.Name = "Flowers"
.Description = "Gives small health boost"
.IsStackable = True
.ImageAsset = My.Resources.HumanBrainIcon
End With
With currancy
.Item = ItemClass.Specials
.Name = "Gold Coin"
.Description = "These can be used at a merchant shop or casino"
.IsStackable = True
.ImageAsset = My.Resources.Coin
End With
With CactusPlant
.Item = ItemClass.Usable
.Name = "Cactus"
.Description = "Gives a substantial health boost"
.IsStackable = True
.ImageAsset = My.Resources.Florance
End With
End Sub
Lists Indexes goes from 0 to Lenght -1 so in
Public Sub UpdateInv()
you need to change the for loop to:
For i = 0 To ItemMax -1
and in the selectCase
Select Case (i-1)
or each case to 0 based index (start in 0 and go to 8)
With the following global variables:
Dim SpilleBræt(8, 8) As PictureBox
Dim Position(8, 8) As String
Dim MarkeretFelt(8, 8) As String
Dim FeltFarve As String
Dim x As Integer
Dim y As Integer
Dim AktivMarkering As Boolean = 0
Dim SpilleBrik As String
And this code:
Private Sub PictureBox_Click(ByVal sender As Object, ByVal e As EventArgs)
Dim FeltValg As PictureBox = CType(sender, PictureBox)
If AktivMarkering = 1 Then
x = Mid(sender.name, sender.name.Length - 1, 1)
y = Mid(sender.name, sender.name.Length, 1)
Select Case Position(y, x)
Case "LightTileMarked"
Me.SpilleBræt(y, x).BackgroundImage = My.Resources.ResourceManager.GetObject(SpilleBrik & "LightTile")
Case "DarkTileMarked"
Me.SpilleBræt(y, x).BackgroundImage = My.Resources.ResourceManager.GetObject(SpilleBrik & "DarkTile")
Case Else
'fjerner markerede
Select Case Position(y, x)
Case "BlackTower", "WhiteTower"
MsgBox("Tårn")
Case "BlackHorse", "WhiteHorse"
MsgBox("Hest")
Case "BlackBishop", "WhiteBishop"
MsgBox("Løber")
Case "WhiteKing", "BlackKing"
MsgBox("Konge")
Case "WhiteQueen", "BlackQueen"
MsgBox("Dronning")
Case "WhitePawn", "BlackPawn"
For k As Integer = y To 1 Step -1
If Position(k, x) = "" Then
If (k + x) Mod 2 = 1 Then
FeltFarve = "DarkTile"
Else
FeltFarve = "LightTile"
End If
Me.SpilleBræt(x, k).BackgroundImage = My.Resources.ResourceManager.GetObject(FeltFarve)
ElseIf Position(k, x) = "WhitePawn" Or Position(k, x) = "BlackPawn" Then
'background død brik
Else
k = 1
End If
Next
End Select
End Select
Else
'indsætter markering
'x,y i picturebox'ens navn fx ->(SpilBrik44) hvor x=4 og y=4
x = Mid(sender.name, sender.name.Length - 1, 1)
y = Mid(sender.name, sender.name.Length, 1)
Select Case Position(y, x)
Case "BlackTower", "WhiteTower"
MsgBox("Tårn")
Case "BlackHorse", "WhiteHorse"
MsgBox("Hest")
Case "BlackBishop", "WhiteBishop"
MsgBox("Løber")
Case "WhiteKing", "BlackKing"
MsgBox("Konge")
Case "WhiteQueen", "BlackQueen"
MsgBox("Dronning")
Case "WhitePawn", "BlackPawn"
For k As Integer = y To 1 Step -1
If Position(k, x) = "" Then
If (k + x) Mod 2 = 1 Then
FeltFarve = "DarkTileMarked"
Else
FeltFarve = "LightTileMarked"
End If
Me.SpilleBræt(x, k).BackgroundImage = My.Resources.ResourceManager.GetObject(FeltFarve)
MarkeretFelt(x, k) = FeltFarve
AktivMarkering = 1
ElseIf Position(k, x) = "WhitePawn" Or Position(k, x) = "BlackPawn" Then
'background død brik
Else
k = 1
End If
Next
End Select
End If
End Sub
I have a problem with the first If statement aktivmarkering=1, goes directly to the 'Else' even though if statements is true.
First time code is run, aktivmarkering is = 0, and therefore it obviously goes to 'Else', but after that one has ben run AktivMarkering is = 1, and first if should be executed. I don't see why not - anyone whos able to help?
Thanks.
I'm trying to check if the column headers are in their right positions ( I have declared the actual column headers as constant values) and if they are not move them around to their right positions.
I'm new to VBA and when I tried it out with the basic For loop and Select Case, I realised the code was too long. I was thinking if there is another perhaps a simpler way to do it.
Below is a sample of the code I tried:
Sheet4_Last_RowNum = WorkingSheet.Cells(Rows.Count, 1).End(xlUp).Row
Sheet4_Last_ColNum = WorkingSheet.Cells(Label_RowNum, Columns.Count).End(xlToLeft).Column
For icol = 1 To Sheet4_Last_ColNum
Select Case WorkingSheet.Cells(Label_RowNum, icol).Value
Case "WkVersion"
Sheet4_WkCol = icol
If Sheet4_WkCol <> Sheet4_ActualWk Then
Sheet4_WkValue = WorkingSheet.Range(Cells(headerRow, Sheet4_WkCol), Cells(Sheet4_Last_RowNum, Sheet4_WkCol))
End If
Case "MPA"
Sheet4_MPACol = icol
If Sheet4_MPACol <> Sheet4_ActualMPA Then
Sheet4_MPAValue = WorkingSheet.Range(Cells(headerRow, Sheet4_MPACol), Cells(Sheet4_Last_RowNum, Sheet4_MPACol))
End If
Case "Location"
Sheet4_LocCol = icol
If Sheet4_LocCol <> Sheet4_ActualLoc Then
Sheet4_LocValue = WorkingSheet.Range(Cells(headerRow, Sheet4_LocCol), Cells(Sheet4_Last_RowNum, Sheet4_LocCol))
End If
End Select
Next icol
With WorkingSheet
If IsEmpty(Sheet4_WkValue) = True Then
Else
.Range(Cells(headerRow, Sheet4_ActualWk), Cells(Sheet4_Last_RowNum, Sheet4_ActualWk)) = Sheet4_WkValue
End If
If IsEmpty(Sheet4_MPAValue) = True Then
Else
.Range(Cells(headerRow, Sheet4_ActualMPA), Cells(Sheet4_Last_RowNum, Sheet4_ActualMPA)) = Sheet4_MPAValue
End If
If IsEmpty(Sheet4_LocValue) = True Then
Else
.Range(Cells(headerRow, Sheet4_ActualLoc), Cells(Sheet4_Last_RowNum, Sheet4_ActualLoc)) = Sheet4_LocValue
End If
End With
How to use roscolor() but to ignore value (like empty cell) ?
I color row if value is upper than 5 but when there is nothing in the cell, i want to ignore the roscolor() apply, how?
Public Sub RosColor()
For i As Integer = 0 To QuoteDataGridView1.Rows.Count() - 1 Step +1
Dim val As Integer
val = QuoteDataGridView1.Rows(i).Cells(3).Value
If val = vbEmpty Then
QuoteDataGridView1.Rows(i).DefaultCellStyle.BackColor = Color.White
ElseIf val < 5 Then
QuoteDataGridView1.Rows(i).DefaultCellStyle.BackColor = Color.Red
ElseIf val > 5 And val < 10 Then
QuoteDataGridView1.Rows(i).DefaultCellStyle.BackColor = Color.LightYellow
End If
Next
End Sub
you can check for the empty value as following
Public Sub RosColor()
For i As Integer = 0 To QuoteDataGridView1.Rows.Count() - 1 Step +1
Dim val = QuoteDataGridView1.Rows(i).Cells(3).Value
If IsDBNull(val) or val Is Nothing Then
QuoteDataGridView1.Rows(i).DefaultCellStyle.BackColor = Color.White
ElseIf CInt(val) < 5 Then
QuoteDataGridView1.Rows(i).DefaultCellStyle.BackColor = Color.Red
ElseIf CInt(val) > 5 And CInt(val) < 10 Then
QuoteDataGridView1.Rows(i).DefaultCellStyle.BackColor = Color.LightYellow
End If
The code is successfully removing table borders and is fine on screen.
While printing or print previewing, its showing some table border. How to fix it?
Sub Tableformatting ()
Dim r As Long, c As Long
Dim t As Table
Set t = ActiveWindow.Selection.ShapeRange.Table
For r = 1 To t.Rows.Count
For c = 1 To t.Columns.Count
With t.Cell(r, c)
.Borders(ppBorderTop).Transparency = 0
.Borders(ppBorderTop).Weight = 0
.Borders(ppBorderBottom).Transparency = 0
.Borders(ppBorderBottom).Weight = 0
.Borders(ppBorderLeft).Transparency = 0
.Borders(ppBorderLeft).Weight = 0
.Borders(ppBorderRight).Transparency = 0
.Borders(ppBorderRight).Weight = 0
End With
Next c
Next r
End Sub
Try using
Sub Tableformatting()
Dim r As Long, c As Long
Dim t As Table
Set t = ActiveWindow.Selection.ShapeRange.Table
For r = 1 To t.Rows.Count
For c = 1 To t.Columns.Count
With t.Cell(r, c)
.Borders(ppBorderTop).Transparency = 1
.Borders(ppBorderBottom).Transparency = 1
.Borders(ppBorderLeft).Transparency = 1
.Borders(ppBorderRight).Transparency = 1
End With
Next c
Next r
End Sub
For some reason .Transparency = 0 only works for what is actively seen, but .Transparency = 1 works for everything you asked for. It might be a bug on Microsoft's end because I don't see why this method or .Borders.Visible = msoFalse wouldn't work just for print/print preview.
Either way I hope this helped!