I would like to make a relocation (cut & paste) for quite a few images.
The Shape ID changes 1 by one, the same as the Selection. name value
The target cells also change by 1 value, as you can see.
My code looks as follows:
Private Sub ChamberImage_Click()
ActiveSheet.Shapes("Textbox_Chamber1").Cut
ActiveSheet.Range("AA70").PasteSpecial
Selection.Name = "Textbox_Chamber1"
ActiveSheet.Shapes("Textbox_Chamber2").Cut
ActiveSheet.Range("AA71").PasteSpecial
Selection.Name = "Textbox_Chamber2"
ActiveSheet.Shapes("Textbox_Chamber3").Cut
ActiveSheet.Range("AA72").PasteSpecial
Selection.Name = "Textbox_Chamber3"
ActiveSheet.Shapes("Textbox_Chamber4").Cut
ActiveSheet.Range("AA73").PasteSpecial
Selection.Name = "Textbox_Chamber4"
ActiveSheet.Shapes("Textbox_Chamber5").Cut
ActiveSheet.Range("AA74").PasteSpecial
Selection.Name = "Textbox_Chamber5"
ActiveSheet.Shapes("Textbox_Chamber6").Cut
ActiveSheet.Range("AA75").PasteSpecial
Selection.Name = "Textbox_Chamber6"
ActiveSheet.Shapes("Textbox_Chamber7").Cut
ActiveSheet.Range("AA76").PasteSpecial
Selection.Name = "Textbox_Chamber7"
ActiveSheet.Shapes("Textbox_Chamber8").Cut
ActiveSheet.Range("AA77").PasteSpecial
Selection.Name = "Textbox_Chamber8"
ActiveSheet.Shapes("Textbox_Chamber9").Cut
ActiveSheet.Range("AA78").PasteSpecial
Selection.Name = "Textbox_Chamber9"
End Sub
How can I write it much smarter? Is it some loop on it?
Without the cut/paste:
Private Sub ChamberImage_Click()
Dim i as long , shp, ws as worksheet
set ws = activesheet
For i = 1 to 9
set shp = ws.Shapes("Textbox_Chamber" & i)
with ws.Range("AA70").Offset(i - 1 , 0)
shp.top = .Top
shp.left = .Left
end with
Nexti
End Sub
Related
I have an array of shapes created in a for loop and want to assign simple code to each of them as "yes/no" buttons.
The code that creates the array of buttons is as follows:
Dim i As Integer
Dim j As Integer
Dim k As Integer
For i = 1 To 3
For j = 2 To 17
ActiveSheet.Shapes.addshape(msoShapeRectangle, Cells(j, i).Left + 0, _
Cells(j, i).Top + 0, Cells(j, i).Width, Cells(j, i).Height).Select
Next j
Next i
I would like to be able to assign code to each of the shapes as they are created but do not know how. What I want the code to do for each shape looks like the below. I want the shapes to react when clicked and cycle through yes/no/blank text in each of the shapes. The general logic of the code is below
value = value +1
if value = 1, then "yes" and green
if value = 2, then "no" and red
if value = 3, then value = 0 and blank and grey
Thank you in advance for your help
You can do something like this:
Option Explicit
Sub Tester()
Dim i As Long, j As Long, k As Long
Dim addr As String, shp As Shape
For i = 1 To 3
For j = 2 To 17
With ActiveSheet.Cells(j, i)
Set shp = .Parent.Shapes.AddShape(msoShapeRectangle, .Left + 0, _
.Top + 0, .Width, .Height)
With shp.TextFrame2
.VerticalAnchor = msoAnchorMiddle
.TextRange.ParagraphFormat.Alignment = msoAlignCenter
End With
shp.Name = "Button_" & .Address(False, False)
End With
shp.Fill.ForeColor.RGB = RGB(200, 200, 200)
shp.OnAction = "ButtonClick"
Next j
Next i
End Sub
'called from a click on a shape
Sub ButtonClick()
Dim shp As Shape, capt As String, tr As TextRange2
'get a reference to the clicked-on shape
Set shp = ActiveSheet.Shapes(Application.Caller)
Set tr = shp.TextFrame2.TextRange
Select Case tr.Text 'decide based on current button text
Case "Yes"
tr.Text = ""
shp.Fill.ForeColor.RGB = RGB(200, 200, 200)
Case "No"
tr.Text = "Yes"
shp.Fill.ForeColor.RGB = vbGreen
Case ""
tr.Text = "No"
shp.Fill.ForeColor.RGB = vbRed
End Select
End Sub
Just to visualize my idea regarding using the selection change event instead of buttons:
The area that should be the clickable range is named clickArea - in this case B2:D17.
Then you put this code in the according sheet module
Option explicit
Private Const nameClickArea As String = "clickArea"
Private Enum bgValueColor
neutral = 15921906 'gray
yes = 11854022 'green
no = 11389944 'red
End Enum
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'whenever user clicks in the "clickArea" the changeValueAndColor macro is triggered
If Not Intersect(Target.Cells(1, 1), Application.Range(nameClickArea)) Is Nothing Then
changeValueAndColor Target.Cells(1, 1)
End If
End Sub
Private Sub changeValueAndColor(c As Range)
'this is to deselect the current cell so that user can select it again
Application.EnableEvents = False: Application.ScreenUpdating = False
With Application.Range(nameClickArea).Offset(50).Resize(1, 1)
.Select
End With
'this part changes the value and color according to the current value
With c
Select Case .Value
Case vbNullString
.Value = "yes"
.Interior.Color = yes
Case "yes"
.Value = "no"
.Interior.Color = no
Case "no"
.Value = vbNullString
.Interior.Color = neutral
End Select
End With
Application.EnableEvents = True: Application.ScreenUpdating = True
End Sub
And this is how it works - with each click on one of the cells value and background color are changed. You have to click on the image to start anmimation.
To reset everything I added a hyperlink that calls the reset action (and refers to itself)
Add this code to the sheets module
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
clearAll
End Sub
Private Sub clearAll()
With Application.Range(nameClickArea)
.ClearContents
.Interior.Color = neutral
End With
End Sub
I was trying to insert some pictures that are saved on my desktop to an excel file.
I found that some online codes worked well. But it seemed that those inserted pictures were not saved with the documents - the inserted pictures won't be displayed when I opened the file on another computer. I am wondering how I should tweak the codes so it can save the inserted pictures within the excel? If possible with VBA, how to adjust the inserted pictures to their 50% dimensions? I am completely new to VBA. Sorry for this basic question.
Sub add_pictures_R2()
Dim i%, ppath$
For i = 2 To 145
' file name at column A
ppath = "C:\Users\myname\output\" & CStr(Cells(i, 1).Value) & ".png"
If Len(Dir(ppath)) Then
With ActiveSheet.Pictures.Insert(ppath)
With .ShapeRange
.LockAspectRatio = msoTrue
.Width = 75
.Height = 300
End With
.Left = ActiveSheet.Cells(i, 10).Left
.Top = ActiveSheet.Cells(i, 10).Top
.Placement = 1
.PrintObject = True
End With
End If
Next
End Sub
You can do either, edit the path of the file to go along with your excel file or you could embed it. For embedding I would look at this.
https://danny.fyi/embedding-and-accessing-a-file-in-excel-with-vba-and-ole-objects-4d4e7863cfff
Its a bit messy but you would achieve what you want to do with at least the file being in the document and not trying to transfer everything with it.
Try this (using Shapes.AddPicture)
Sub add_pictures_R2()
'Note - type identifiers such as `S`, `%` are very outdated...
Dim i As Long, ppath As String, ws As Worksheet, c As Range
Set ws = ActiveSheet 'use a specific/explicit sheet reference
For i = 2 To 145
ppath = "C:\Users\myname\output\" & CStr(ws.Cells(i, 1).Value) & ".png"
Set c = ws.Cells(i, 10) 'insertion point
'passing -1 to Width/Height preserves original size
With ws.Shapes.AddPicture(Filename:=ppath, linktofile:=msoFalse, _
savewithdocument:=msoTrue, _
Left:=c.Left, Top:=c.Top, Width:=-1, Height:=-1)
.LockAspectRatio = msoTrue
.Placement = xlMove
.Height = .Height / 2 'size to 50%
End With
Next i
End Sub
I got the answer from Jimmypop at mrexcel. It worked.
Sub add_pictures_R2()
Const folderPath As String = "C:\Users\YANG\output\"
Dim r As Long
Application.ScreenUpdating = False
With ActiveSheet
For r = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
If Dir(folderPath & .Cells(r, "A").Value & ".png") <> vbNullString Then
.Shapes.AddPicture Filename:=folderPath & .Cells(r, "A").Value & ".png", _
LinkToFile:=False, SaveWithDocument:=True, _
Left:=ActiveSheet.Cells(r, 10).Left, Top:=ActiveSheet.Cells(r, 10).Top, Width:=.Cells(r, "C").Width, Height:=.Cells(r, "C").Height
Else
.Cells(r, "B").Value = "Not found"
End If
DoEvents
Next
End With
Set myDocument = Worksheets(1)
For Each s In myDocument.Shapes
Select Case s.Type
Case msoLinkedPicture, msoPicture
s.ScaleHeight 0.5, msoTrue
s.ScaleWidth 0.5, msoTrue
Case Else
' Do Nothing
End Select
Next
Application.ScreenUpdating = True
MsgBox "Done"
End Sub
I am trying to get rid of the horizontal scroll bar in my listbox--which appears when a user clicks in certain cells and is then consequently "deleted" each time the user clicks out of that cell (so I can't change it manually, I must change it with code)--but the .ColumnWidths property does not seem to function.
It seems the ColumnWidths is default set at 74--this based on the fact that if I set my Width at 74 or greater there is no horizontal scroll bar.
If when clicking a cell, I go into design mode, open properties, I can manually set the ColumnWidths to 35. That is not a solution since my listbox is created and deleted depending on the user's active cell. Nonetheless this confirmed that it is something about how my code is written.
Option Explicit
Private WithEvents Lbx As MSForms.ListBox
Private oTarget As Range
Private ListBoxName As String
Private Const Cell_A1 As String = "B1:B20" 'change addr as required.
Private Sub Lbx_Change()
Dim k As Long
oTarget.ClearContents
For k = 0 To Lbx.ListCount - 1
If Lbx.Selected(k) Then
If Len(oTarget) = 0 Then
oTarget = Lbx.List(k)
Else
oTarget = _
Trim(oTarget & vbNewLine & Lbx.List(k))
End If
End If
Next
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim oListBox As OLEObject
On Error Resume Next
Me.OLEObjects(1).Delete
Range(Cell_A1).Interior.ColorIndex = 0
If Target.Column = 2 And (Target.Row >= 1 And Target.Row <= 20) Then
'UCase(Target.Address(0, 0)) = UCase(Cell_A1)
Application.DisplayFormulaBar = False
Set oListBox = _
Me.OLEObjects.Add(ClassType:="Forms.ListBox.1")
With oListBox
Names.Add "ListBoxName", .Name
.Left = Target.Offset(0,1).Left
.Top = Target.Offset(0, 0).Top
.ColumnCount = 1
.ColumnWidths = "35"
.Width = 54
.Height = Me.StandardHeight * 16
.Object.ListStyle = fmListStylePlain
.ListFillRange = "A1:A20"
.Placement = xlFreeFloating
.Object.MultiSelect = fmMultiSelectMulti
.Object.SpecialEffect = fmSpecialEffectFlat
.Object.BorderStyle = fmBorderStyleSingle
With Application
.OnTime Now + _
TimeSerial(0, 0, 0.01), Me.CodeName & ".Hooklistbox"
.CommandBars.FindControl(ID:=1605).Execute
End With
End With
Else
Application.DisplayFormulaBar = True
Names("ListBoxName").Delete
Range(Cell_A1).Interior.ColorIndex = 0
End If
End Sub
Private Sub Hooklistbox()
Application.CommandBars.FindControl(ID:=1605).Reset
Set oTarget = ActiveCell
ActiveCell.Interior.Color = vbGreen
'display the listbox and hook it.
With Me.OLEObjects(Evaluate("ListBoxName"))
.Visible = True
Set Lbx = .Object
End With
End Sub
Type
.Object.
Before .ColumnCount and .ColumnWidths
And get rid of the on error resume next, which brought you to this "hidden" error in the first place
Use a on error goto 0 afterwards when it's not needed anymore
++
instead of:
On Error Resume Next
Me.OLEObjects(1).Delete
you could use:
If Me.OLEObjects.Count > 0 Then Me.OLEObjects(1).Delete
and delete this line (because Names will be overwritten, so no need to delete:
Names("ListBoxName").Delete
I have a code here that will generate pages depends on what value is on the textbox.
'Button accepting how many number of pages
Private Sub CommandButton1_Click()
RowChar = 70
MultiPage1.Pages.Clear
For i = 0 To TextBox1.Value - 1
MultiPage1.Pages.Add
MultiPage1.Pages(i).Caption = "Variable" & i + 1
Call LabelPerPage
Set txtbx = UserForm1.MultiPage1.Pages(i).Controls.Add("Forms.TextBox.1", "NameBox")
With txtbx
.Top = 20
.Left = 100
End With
Set txtbx = UserForm1.MultiPage1.Pages(i).Controls.Add("Forms.TextBox.1", "MinBox")
With txtbx
.Top = 50
.Left = 100
End With
Set txtbx = UserForm1.MultiPage1.Pages(i).Controls.Add("Forms.TextBox.1", "LsbBox")
With txtbx
.Top = 20
.Left = 300
End With
Set txtbx = UserForm1.MultiPage1.Pages(i).Controls.Add("Forms.TextBox.1", "Mataas")
With txtbx
.Top = 50
.Left = 300
End With
If i = 0 Then
FormulaString = "= C15"
Else
FormulaString = FormulaString & " " & Chr(RowChar) & "15"
RowChar = RowChar + 3
End If
Next i
TextBox2.Value = FormulaString
End Sub
Problem: I want to disable commandbutton2(button for computation of MINbox and MAxbox) if all the textboxes inside each pages are empty. Do you have any IDEA how can I do that? Thank you.
Though best way and easiest way is to validate on click in CommandButton2_Click as answered by #Excelosaurus, i just offering slightly modified way of TextBox change event trapping by #Mathieu Guindon's answer in the post Implementing a change event to check for changes to textbox values and enabling the “apply” button. The full credit of this technique of encapsulating a WithEvents MSForms control goes to #Mathieu Guindon
in the Userform1 code module may be modified as below
Public handlers As VBA.Collection ' added
Private Sub CommandButton1_Click()
RowChar = 70
MultiPage1.Pages.Clear
For i = 0 To TextBox1.Value - 1
MultiPage1.Pages.Add
MultiPage1.Pages(i).Caption = "Variable" & i + 1
'Call LabelPerPage
Set txtbx = UserForm1.MultiPage1.Pages(i).Controls.Add("Forms.TextBox.1", "NameBox")
With txtbx
.Top = 20
.Left = 100
End With
Set txtbx = UserForm1.MultiPage1.Pages(i).Controls.Add("Forms.TextBox.1", "MinBox")
With txtbx
.Top = 50
.Left = 100
End With
Set txtbx = UserForm1.MultiPage1.Pages(i).Controls.Add("Forms.TextBox.1", "LsbBox")
With txtbx
.Top = 20
.Left = 300
End With
Set txtbx = UserForm1.MultiPage1.Pages(i).Controls.Add("Forms.TextBox.1", "Mataas")
With txtbx
.Top = 50
.Left = 300
End With
If i = 0 Then
FormulaString = "= C15"
Else
FormulaString = FormulaString & " " & Chr(RowChar) & "15"
RowChar = RowChar + 3
End If
Next i
TextBox2.Value = FormulaString
CommandButton2.Enabled = False ' added
makeEvents ' added
End Sub
Sub makeEvents() ' added
Set handlers = New VBA.Collection
Dim cnt As MSForms.Control
For i = 0 To UserForm1.MultiPage1.Pages.Count - 1
For Each cnt In UserForm1.MultiPage1.Pages(i).Controls
If TypeOf cnt Is MSForms.TextBox Then
Dim textBoxHandler As DynamicTextBox
Set textBoxHandler = New DynamicTextBox
textBoxHandler.Initialize cnt
handlers.Add textBoxHandler
'Debug.Print cnt.Name & i & "Inited"
End If
Next cnt
Next i
End Sub
Then Add a new class module to your project, call it DynamicTextBox
Option Explicit
Private WithEvents encapsulated As MSForms.TextBox
Public Sub Initialize(ByVal ctrl As MSForms.TextBox)
Set encapsulated = ctrl
End Sub
Private Sub encapsulated_Change()
Dim TextEmpty As Boolean
Dim cnt As Control
Dim i As Integer
For i = 0 To UserForm1.MultiPage1.Pages.Count - 1
For Each cnt In UserForm1.MultiPage1.Pages(i).Controls
If TypeOf cnt Is MSForms.TextBox Then
'Debug.Print cnt.Name & i & "checked"
If cnt.Value = "" Then
TextEmpty = True
Exit For
End If
End If
Next cnt
If TextEmpty = True Then
Exit For
End If
Next i
If TextEmpty Then
UserForm1.CommandButton2.Enabled = False
Else
UserForm1.CommandButton2.Enabled = True
End If
End Sub
Tried and found working
The easier way is to validate on click: in CommandButton2_Click, scan your dynamically created textboxes, and either proceed or notify the user about any validation error.
A more complicated way is to create a class that will monitor the events of a TextBox. You will create one instance of this class per TextBox you want to monitor, keeping those instances in e.g. an array. See How to add events to Controls created at runtime in Excel with VBA.
You can loop through each worksheet in your workbook, and for each worksheet - loop through all the OLEObjects. You will check the typename of the .Object, and perform your final tests there.
I would create a function that you can easily call to perform this check and return a Boolean True/False.
Function allTextboxEmpty() As Boolean
Dim oleObj As OLEObject, ws As Worksheet
allTextboxEmpty = True
For Each ws In ThisWorkbook.Worksheets
For Each oleObj In ws.OLEObjects
If TypeName(oleObj.Object) = "TextBox" Then
If oleObj.Object.Value <> vbNullString Then
allTextboxEmpty = False
Exit Function
End If
End If
Next oleObj
Next ws
End Function
If the above function returns True, then you know that all of your textboxes in the workbook are empty. You can use this function as shown in the below example:
If allTextboxEmpty Then
Worksheets("Sheet1").CommandButton2.Enabled = False
Else
Worksheets("Sheet1").CommandButton2.Enabled = True
End If
I'm trying to help out a coworker with her VBA in Excel 2013. It looks like the macro is successfully pulling in the images from the designated path, but it dumps every single photo into cell A1.
Any thoughts?
Sub DeleteAllPictures()
Dim S As Shape
For Each S In ActiveSheet.Shapes
Select Case S.Type
Case msoLinkedPicture, msoPicture
S.Delete
End Select
Next
End Sub
Sub UpdatePictures()
Dim R As Range
Dim S As Shape
Dim Path As String, FName As String
'Setup the path
Path = "G:\In Transit\Carlos\BC Website images"
'You can read this value also from a cell, e.g.:
'Path = Worksheets("Setup").Range("B1")
'Be sure the path has a trailing backslash
If Right(Path, 1) <> "\" Then Path = Path & "\"
'Visit each used cell in column A
For Each R In Range("B1", Range("B" & Rows.Count).End(xlUp))
'Try to get the shape
Set S = GetShapeByName(R)
'Found?
If S Is Nothing Then
'Find the picture e.g. "C:\temp\F500.*"
FName = Dir(Path & R & ".*")
'Found?
If FName <> "" Then
Set S = InsertPicturePrim(Path & FName, R)
End If
End If
If Not S Is Nothing Then
'Show the error if the name did not match the cell
If S.Name <> R Then R.Interior.Color = vbRed
With R.Offset(0, 1)
'Move the picture to the cell on the right side
S.Top = .Top
S.Left = .Left
'Resize it
S.Width = .Width
'Remove the aspect ratio by default if necessary
'S.LockAspectRatio = False
If S.LockAspectRatio Then
'Make it smaller to fit the cell if necessary
If S.Height > .Height Then S.Height = .Height
Else
'Stretch the picture
S.Height = .Height
End If
End With
'Move it behind anything else
S.ZOrder msoSendToBack
Else
R.Offset(0, 1) = "No picture available"
End If
Next
End Sub
Private Function GetShapeByName(ByVal SName As String) As Shape
'Return the shape with SName, Nothing if not exists
On Error Resume Next
Set GetShapeByName = ActiveSheet.Shapes(SName)
End Function
Private Function InsertPicturePrim(ByVal FName As String, ByVal SName As String) As Shape
'Inserts the picture, return the shape, Nothing if failed
Dim P As Picture
On Error Resume Next
'Insert the picture
Set P = ActiveSheet.Pictures.Insert(FName)
'code to resize
With P
.ShapeRange.LockAspectRatio = msoFalse
.Height = ActiveCell.Height
.Width = ActiveCell.Width
.Top = ActiveCell.Top
.Left = ActiveCell.Left
.Placement = xlMoveAndSize
End With
Set P = Nothing
'code to resize
'Success?
If Not P Is Nothing Then
'Return the shape
Set InsertPicturePrim = P.ShapeRange(1)
'Rename it, so we can easily find it later
P.Name = SName
End If
End Function
The short answer is: your macro is inserting the picture at the selected cell. Change the selection before the insert line, and you should get it inserted at each row.
Here in this example, I am selecting the cell to the left of the cell you are pulling the name value from.
If FName <> "" Then
'select the cell 1 to the left of the cell containing the image name
R.Offset(0,-1).select
Set S = InsertPicturePrim(Path & FName, R)
End If