I am looking for a way to insert text into the background of a cell, so that I can still enter numbers on top of that text - similar to a watermark except for an individual cell. Any ways to do this, preferably without using a macro (but open to these solutions as well)?
Similar to Andrews post, this is the VBA version which formats the shape correctly and also allows direct selecting of cells.
Code MODULE:
Sub watermarkShape()
Const watermark As String = "watermark"
Dim cll As Range
Dim rng As Range
Dim ws As Worksheet
Dim shp As Shape
Set ws = Sheet1
Set rng = ws.Range("A1:F10") 'Set range to fill with watermark
Application.ScreenUpdating = False
For Each shp In ws.Shapes
shp.Delete
Next shp
For Each cll In rng
Set shp = ws.Shapes.AddShape(msoShapeRectangle, 5, 5, 5, 5)
With shp
.Left = cll.Left
.Top = cll.Top
.Height = cll.Height
.Width = cll.Width
.Name = cll.address
.TextFrame2.TextRange.Characters.Text = watermark
.TextFrame2.TextRange.Font.Name = "Tahoma"
.TextFrame2.TextRange.Font.Size = 8
.TextFrame2.VerticalAnchor = msoAnchorMiddle
.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
.TextFrame2.WordWrap = msoFalse
.TextFrame.Characters.Font.ColorIndex = 15
.TextFrame2.TextRange.Font.Fill.Transparency = 0.35
.Line.Visible = msoFalse
' Debug.Print "'SelectCell (""" & ws.Name & """,""" & cll.address & """)'"
.OnAction = "'SelectCell """ & ws.Name & """,""" & cll.address & """'"
With .Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorBackground1
.Transparency = 1
.Solid
End With
End With
Next cll
Application.ScreenUpdating = True
End Sub
Sub SelectCell(ws, address)
Worksheets(ws).Range(address).Select
End Sub
UPDATE:
the example below assigns a watermark of the cell address to odd rows and leaves the even rows as the constant watermark. This is an exaple based on my comment that any cell can be assigned any watermark text based on whatever conditons you want.
Option Explicit
Sub watermarkShape()
Const watermark As String = "watermark"
Dim cll As Range
Dim rng As Range
Dim ws As Worksheet
Dim shp As Shape
Set ws = Sheet1
Set rng = ws.Range("A1:F10") 'Set range to fill with watermark
Application.ScreenUpdating = False
For Each shp In ws.Shapes
shp.Delete
Next shp
For Each cll In rng
Set shp = ws.Shapes.AddShape(msoShapeRectangle, 5, 5, 5, 5)
With shp
.Left = cll.Left
.Top = cll.Top
.Height = cll.Height
.Width = cll.Width
.Name = cll.address
If cll.Row Mod 2 = 1 Then
.TextFrame2.TextRange.Characters.Text = cll.address
Else
.TextFrame2.TextRange.Characters.Text = watermark
End If
.TextFrame2.TextRange.Font.Name = "Tahoma"
.TextFrame2.TextRange.Font.Size = 8
.TextFrame2.VerticalAnchor = msoAnchorMiddle
.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
.TextFrame2.WordWrap = msoFalse
.TextFrame.Characters.Font.ColorIndex = 15
.TextFrame2.TextRange.Font.Fill.Transparency = 0.35
.Line.Visible = msoFalse
' Debug.Print "'SelectCell (""" & ws.Name & """,""" & cll.address & """)'"
.OnAction = "'SelectCell """ & ws.Name & """,""" & cll.address & """'"
With .Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorBackground1
.Transparency = 1
.Solid
End With
End With
Next cll
Application.ScreenUpdating = True
End Sub
Sub SelectCell(ws, address)
Worksheets(ws).Range(address).Select
End Sub
You can use a custom number format (select the cell(s), hit Ctrl+1, number formats, custom) to specify a light-grey text to display when the cell value is 0 - Color15 makes a nice watermark color:
[Black]000000;;[Color15]"(order number)";#
No messy shapes, no VBA, and the watermark disappears when the value is actually filled up.
And if you absolutely need to do it in VBA, then you can easily write a function that builds the format string based on some parameters:
Public Function BuildWatermarkFormat(ByVal watermarkText As String, Optional ByVal positiveFormat As String = "General", Optional ByVal negativeFormat As String = "General", Optional ByVal textFormat As String = "General") As String
BuildWatermarkFormat = positiveFormat & ";" & negativeFormat & ";[Color15]" & Chr(34) & watermarkText & Chr(34) & ";" & textFormat
End Function
And then you can do:
myCell.NumberFormat = BuildWatermarkFormat("Please enter a value")
myCell.Value = 0
And you can still supply custom formats for positive/negative values as per your needs; the only thing is that 0 is reserved for "no value" and triggers the watermark.
myCell.NumberFormat = BuildWatermarkFormat("Please enter a value", "[Blue]#,##0.00_)", "[Red](#,##0.00)")
myCell.Value = -25
Select the Cell where you want to make the Background.
Click "Insert" and insert a rectangular Shape in that location.
Right click on the shape - select "Format Shape"
Goto "Fill" and select "Picture or texture fill"
Goto “Insert from File” option
Select the picture you want to make water-mark
Picture will appear at the place of rectangular shape
Now click on the picture “right click” and select Format Picture
Goto “Fill” and increase the transparency as required to look it like a “Water Mark” or light beckground
This will get printed also.
taken from here
Type your text in a cell anywhere.
Copy it and it will be saved on the clipboard.
Insert a rectangular shape anywhere.
Right click and choose "Send to back".
This will make sure it will be at the background.
Right click and "Format Shape".
Do to tab "Fill" and click on "picture or texture fill".
At the "insert from" choose "clipboard".
Now whatever text you have copied onto your clipboard will be in the rectangular shape.
Resize the shape to fit the cell(s) you desired.
Adjust however you like for example remove the rectangular lines, add shadow, change font, remove background etc.
Related
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 adding the contents of cells to a shape object. The contents are all text, but each cell may have different formatting. I would like to be able to preserve this formatting when adding the content of the cells to the shape, so that a bold cell will appear as such and so on.
I have been trying to take the current Shape.TextFrame.Characters object and add the new Range("TargetCell").Characters object to it, for each target cell in my source range.
Is there a simple way to force two .Characters objects together, so the text concatenates and the formatting changes to reflect the source at the boundary of the new text - I see the .Characters.Insert(string) method, but that only inserts the text, not the formatting. Every time I add a new cell to the output list, I need to recalculate where each portion of text has what formatting, which is proving to be difficult.
I was trying along these lines, but keep coming into difficulties trying to get or set the .Characters(n).Font.Bold property.
Private Sub buildMainText(Target As Range, oSh As Shape)
On Error GoTo 0
Dim chrExistingText As Characters
Dim chrTextToAdd As Characters
Dim chrNewText As Characters
Dim o As Characters
Dim i As Integer
Dim isBold As Boolean
Dim startOfNew As Integer
i = 0
With oSh.TextFrame
Set chrExistingText = .Characters
Set chrTextToAdd = Target.Characters
Set chrNewText = chrTextToAdd
chrNewText.Text = chrExistingText.Text & chrTextToAdd.Text
startOfNew = Len(chrExistingText.Text) + 1
.Characters.Text = chrNewText.Text
For i = 1 To Len(chrNewText.Text)
If i < startOfNew Then
If chrExistingText(i, 1).Font.Bold Then
.Characters(i, 1).Font.Bold = True
Else
.Characters(i, 1).Font.Bold = False
End If
Else
If chrNewText(i - startOfNew + 1, 1).Font.Bold Then
.Characters(i, 1).Font.Bold = True
Else
.Characters(i, 1).Font.Bold = False
End If
End If
Next i
End With
End Sub
Here is an example which takes a single cell and appends it to a shape; preserving, shape's and range's formattings. In the example below, we will preserve BOLD (B), ITALICS (I) and UNDERLINE (U). Feel free to modify the code to store more formatting attributes.
LOGIC:
The maximum length of characters you can have in a shape's textframe is 32767. So we will create an array (as #SJR mentioned in the comments above) say, TextAr(1 To 32767, 1 To 3), to store the formatting options. The 3 columns are for B,U and I. If you want to add more attributes then change it to the relevant number.
Store the shape's formatting in an array.
Store the cells's formatting in an array.
Append the cell's text to the shape.
Loop through the array and re-apply the formatting.
CODE:
I have commented the code but if you have a problem understanding it then simply ask. I quickly wrote this so I must confess that I have not done extensive testing of this code. I am assuming that the cell/shape doesn't have any other formatting other than B, I and U(msoUnderlineSingleLine). If it does, then you will have to amend the code accordingly.
Option Explicit
Sub Sample()
Dim ws As Worksheet
'~~> Change this to the relevant sheet
Set ws = Sheet1
AddTextToShape ws.Range("F3"), ws.Shapes("MyShape")
End Sub
'~~> Proc to add cell range to shape
Sub AddTextToShape(rng As Range, shp As Shape)
'~~> Check for single cell
If rng.Cells.Count > 1 Then
MsgBox "Select a single cell and try again"
Exit Sub
End If
Dim rngTextLength As Long
Dim shpTextLength As Long
'~~> Get the length of the text in the supplied range
rngTextLength = Len(rng.Value)
'~~> Get the length of the text in the supplied shape
shpTextLength = Len(shp.TextFrame.Characters.Text)
'~~> Check if the shape can hold the extra text
If rngTextLength + shpTextLength > 32767 Then
MsgBox "Cell text will not fit in Shape. Choose another cell with maximum " & _
(32767 - shpTextLength) & " characters"
Exit Sub
End If
Dim TextAr(1 To 32767, 1 To 3) As String
Dim i As Long
'~~> Store the value and formatting from the shape in the array
For i = 1 To shpTextLength
With shp.TextFrame.Characters(i, 1)
With .Font
If .Bold = True Then TextAr(i, 1) = "T" Else TextAr(i, 1) = "F"
If .Italic = True Then TextAr(i, 2) = "T" Else TextAr(i, 2) = "F"
If .Underline = xlUnderlineStyleSingle Then TextAr(i, 3) = "T" Else TextAr(i, 3) = "F"
End With
End With
Next i
'~~> Store the value and formatting from the range in the array
Dim j As Long: j = shpTextLength + 2
For i = 1 To rngTextLength
With rng.Characters(Start:=i, Length:=1)
With .Font
If .Bold = True Then TextAr(j, 1) = "T" Else TextAr(j, 1) = "F"
If .Italic = True Then TextAr(j, 2) = "T" Else TextAr(j, 2) = "F"
If .Underline = xlUnderlineStyleSingle Then TextAr(j, 3) = "T" Else TextAr(j, 3) = "F"
j = j + 1
End With
End With
Next i
'~~> Add the cell text to shape
shp.TextFrame.Characters.Text = shp.TextFrame.Characters.Text & " " & rng.Value2
'~~> Get the new text length of the shape
shpTextLength = Len(shp.TextFrame.Characters.Text)
'~~> Apply the formatting
With shp
For i = 1 To shpTextLength
With .TextFrame2.TextRange.Characters(i, 1).Font
If TextAr(i, 1) = "T" Then .Bold = msoTrue Else .Bold = msoFalse
If TextAr(i, 2) = "T" Then .Italic = msoTrue Else .Italic = msoFalse
If TextAr(i, 3) = "T" Then .UnderlineStyle = msoUnderlineSingleLine _
Else .UnderlineStyle = msoNoUnderline
End With
Next i
End With
End Sub
IN ACTION
Good afternoon to all.
I now need be able to send the formatted textbox back to the originating active cell.
This code was copy format from cell to textbox, I now need to reverse this process
Sub passCharToTextbox()
CopycellFormat ActiveCell
End Sub
Private Sub CopycellFormat(cell As Range)
If Trim(cell(1, 1).Value) = vbNullString Then MsgBox ("select only cell / not emptycell"): Exit Sub
Dim textrange As TextRange2, tbox1 As Shape, fontType As Font2
With ActiveSheet
On Error Resume Next: Err.Clear 'check if Textbox 2 exist
Set tbox1 = .Shapes("Textbox 2"): Set textrange = tbox1.TextFrame2.textrange
textrange.Characters.Text = cell.Value
If Err.Number > 0 Then MsgBox ("Not found Textbox 2")
For i = 1 To Len(cell.Value)
Set fontType = textrange.Characters(i, 1).Font
With cell.Characters(i, 1)
fontType.Bold = IIf(.Font.Bold, True, 0) 'add bold/
fontType.Italic = IIf(.Font.Italic, True, 0) 'add italic/
fontType.UnderlineStyle = IIf(.Font.Underline > 0, msoUnderlineSingleLine, msoNoUnderline) 'add underline/
textrange.Characters(i, 1).Font.Fill.ForeColor.RGB = .Font.Color 'add Font color
End With
Next i
tbox1.Fill.ForeColor.RGB = cell.Interior.Color 'add background color
End With
End Sub
Many thanks for taking the time to read, and please everyone, stay well.
focus on your problem:
First, make sure "textbox 2" exists
Then, Select the cell need to copy format and run the code CopyFormat_fromTextbox_toCell
Here's following code:
Sub CopyFormat_fromTextbox_toCell()
CopycellFormat1 activecell
End Sub
Private Sub CopycellFormat1(cell As Range)
Dim textrange As TextRange2, tbox1 As Shape, fontType As Font2, cellfont As Font
With ActiveSheet
Set tbox1 = .Shapes("Textbox 2"): Set textrange = tbox1.TextFrame2.textrange
cell.Value = textrange.Characters.Text
For i = 1 To Len(cell.Value)
Set fontType = textrange.Characters(i, 1).Font
Set cellfont = cell.Characters(i, 1).Font
With fontType
cellfont.Bold = IIf(.Bold, True, 0) 'add bold/
cellfont.Italic = IIf(.Italic, True, 0) 'add italic/
cellfont.Underline = IIf(.UnderlineStyle > 0, 2, -4142) 'add underline/
cellfont.Color = textrange.Characters(i, 1).Font.Fill.ForeColor.RGB 'add Font color
End With
Next i
cell.Interior.Color = tbox1.Fill.ForeColor.RGB 'add background color
End With
End Sub
I would like to set the formula for a picture using VBA.
This is a portion of the simplified version of the VBA used to insert and modify a shape/picture from a given URL.
Dim theShape As Shape
Filename = cell
' Use Shapes instead so that we can force it to save with the document
Set theShape = ActiveSheet.Shapes.AddPicture( _
Filename:=Filename, linktofile:=msoFalse, _
savewithdocument:=msoCTrue, _
Left:=cell.Left, Top:=cell.Top, Width:=60, Height:=60)
With theShape
.LockAspectRatio = msoTrue
' Shape position and sizes stuck to cell shape
.Top = cell.Top + 1
.Left = cell.Left + 1
.Height = cell.Height - 2
.Width = cell.Width - 2
' Move with the cell (and size, though that is likely buggy)
.Placement = xlMoveAndSize
.Name = "Item" & cell.Row
'******What to enter here to set the "Formula" for the picture?
'Trying to set the formula to an existing named range, such as "FQPic3"
'Something like: .formula = FQPic3
End With
However, I don't see a picture property to set the formula.
Thank you.
This would allow you to set the formula:
Dim theShape As Shape
Filename = cell
' Use Shapes instead so that we can force it to save with the document
Set theShape = ActiveSheet.Shapes.AddPicture( _
Filename:=Filename, linktofile:=msoFalse, _
savewithdocument:=msoCTrue, _
Left:=cell.Left, Top:=cell.Top, Width:=60, Height:=60)
With theShape
.LockAspectRatio = msoTrue
' Shape position and sizes stuck to cell shape
.Top = cell.Top + 1
.Left = cell.Left + 1
.Height = cell.Height - 2
.Width = cell.Width - 2
' Move with the cell (and size, though that is likely buggy)
.Placement = xlMoveAndSize
.Name = "Item" & cell.Row
'******What to enter here to set the "Formula" for the picture?
'Trying to set the formula to an existing named range, such as "FQPic3"
'Something like: .formula = FQPic3
theShape.OLEFormat.Object.Formula = "=FQPic3"
End With
Side note: didn't check the rest of your code
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