I have a situation at work where people have to manually introduce pictures in a certain page of excel and resize it also manually. As a complete very beginner I've managed to find some VBA code to help introduce the picture by clicking a button and inserting it in a certain range of cells. The problem that I have is that I cannot figure out (after searching many posts) how to correctly introduce the function to save the image without making a link to it so others can see the report without getting an error that the picture doesn't exist.
Can you kindly help me and complete where the function should be introduced?
Private Sub CommandButton3_Click()
Dim strFileName As String
Dim objPic As Picture
Dim rngDest As Range
strFileName = Application.GetOpenFilename( _
FileFilter:="Images (*.jpg;*.gif;*.png),*.jpg;*.gif;*.png", _
Title:="Please select an image...")
If strFileName = "False" Then Exit Sub
Set rngDest = Me.Range("B24:C26")
Set objPic = Me.Pictures.Insert(strFileName)
With objPic
.ShapeRange.LockAspectRatio = msoFalse
.Left = rngDest.Left
.Top = rngDest.Top
.Width = rngDest.Width
.Height = rngDest.Height
End With
End Sub
Thanks in advance!
Try this:
Private Sub CommandButton3_Click()
Dim strFileName As String
Dim objPic As Shape '<<<
Dim rngDest As Range
strFileName = Application.GetOpenFilename( _
FileFilter:="Images (*.jpg;*.gif;*.png),*.jpg;*.gif;*.png", _
Title:="Please select an image...")
If strFileName = "False" Then Exit Sub
Set rngDest = Me.Range("B24:C26")
Set objPic = Me.Shapes.AddPicture(Filename:=strFileName, _
linktofile:=msoFalse, _
savewithdocument:=msoCTrue, _
Left:=rngDest.Left, Top:=rngDest.Top, _
Width:=rngDest.Width, Height:=rngDest.Height)
End Sub
Related
Hi there I have the code below which calls "Delete_Image_Click" and deletes the shape in a specified cell range and then inserts a new image from a selected filepath into the same cell range.
I need to then delete images in other ranges (on the same worksheet and other worksheets) and then add the same image into the other cell ranges on the same worksheet and then go into another named worksheet and insert the same image into two more ranges.
Could anyone help me with how I go about this?
Sub RectangleRoundedCorners6_Click()
Call Delete_Image_Click
Dim sPicture As String, pic As Picture
sPicture = Application.GetOpenFilename _
("Pictures (*.gif; *.jpg; *.bmp; *.tif; *.png), *.gif;*.png; *.jpg; *.bmp; *.tif", _
, "Select Picture to Import")
If sPicture = "False" Then Exit Sub
Set pic = ActiveSheet.Pictures.Insert(sPicture)
With pic
.ShapeRange.LockAspectRatio = msoTrue
.Height = Range("Q36:W41").Height
.Top = Range("Q36:W41").Top
.Left = Range("Q36:W41").Left
.Placement = xlMoveAndSize
End With
Set pic = Nothing
End Sub
Sub Delete_Image_Click()
Dim xPicRg As Range
Dim xPic As Picture
Dim xRg As Range
Application.ScreenUpdating = False
Set xRg = Range("Q36:W41")
For Each xPic In ActiveSheet.Pictures
Set xPicRg = Range(xPic.TopLeftCell.Address & ":" & xPic.BottomRightCell.Address)
If Not Intersect(xRg, xPicRg) Is Nothing Then xPic.Delete
Next
Application.ScreenUpdating = True
End Sub
I have been using an Excel VBA macro to add images to my spreadsheet lists from a folder on our office server. The list exports from my database software with the containing folder and image name in Column A (e.g. 038/19761809.jpg). I now need to send these documents to persons outside of my office without access to our server so I am trying to switch from using ActiveSheet.Pictures.Insert to using the more correct ActiveSheet.Shapes.AddPicture. The goal is to have the image files embed in the document rather than just linking to the files on our office server.
This code (using Pictures.Insert) inserts the images as links. When I email the spreadsheet to off-site users, the linked images "break" as recipient's computer cannot find them (because their computer is not on our local network).
Sub InsertPictures()
Dim MyRange As String
Dim picname As String
Dim mySelectRange As String
Dim rcell As Range
Dim IntInstr As Integer
Dim Mypath As String
Mypath = "S:\pp4\images\"
MyRange = "A2:A275"
Range(MyRange).Select
For Each rcell In Selection.Cells
If Len(rcell.Value) > 0 Then
picname = Mypath & rcell.Value
mySelectRange = Replace(MyRange, "B", "A")
IntInstr = InStr(mySelectRange, ":")
mySelectRange = Left(mySelectRange, IntInstr - 1)
do_insertPic picname, mySelectRange, rcell.Left, rcell.Top
End If
Next
Application.ScreenUpdating = True
End Sub
Sub do_insertPic(ByRef picname As String, ByRef MyRange As String, myleft As Integer, mytop As Integer)
Dim rcell As Range
Range(MyRange).Select
On Error GoTo ErrNoPhoto
ActiveSheet.Pictures.Insert(picname).Select
On Error GoTo 0
With Selection
.Left = myleft + 4
.Top = mytop + 4
.ShapeRange.LockAspectRatio = msoTrue
.ShapeRange.Height = 115#
.ShapeRange.Rotation = 0#
End With
Exit Sub
ErrNoPhoto:
MsgBox "Unable to Find Photo" 'Shows message box if picture not found
End Sub
I have modified my code to use the formatting for Shapes.AddPicture. Here is the new code:
Sub InsertPictures()
Dim MyRange As String
Dim picname As String
Dim mySelectRange As String
Dim rcell As Range
Dim IntInstr As Integer
Dim Mypath As String
Mypath = "S:\pp4\images\"
MyRange = "A2:A275"
Range(MyRange).Select
For Each rcell In Selection.Cells
If Len(rcell.Value) > 0 Then
picname = Mypath & rcell.Value
mySelectRange = Replace(MyRange, "B", "A")
IntInstr = InStr(mySelectRange, ":")
mySelectRange = Left(mySelectRange, IntInstr - 1)
do_insertPic picname, mySelectRange, rcell.Left, rcell.Top
End If
Next
Application.ScreenUpdating = True
End Sub
Sub do_insertPic(ByRef picname As String, ByRef MyRange As String, myleft As Integer, mytop As Integer)
Dim rcell As Range
Range(MyRange).Select
On Error GoTo ErrNoPhoto
ActiveSheet.Shapes.AddPicture(Filename:=picname, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=myleft + 4, Top:=mytop + 4, LockAspectRatio:=msoTrue, Height:=115#, Rotation:=0#).Select
On Error GoTo 0
Exit Sub
ErrNoPhoto:
MsgBox "Unable to Find Photo" 'Shows message box if picture not found
End Sub
When I try to run the new macro Excel just puts up my "Unable to Find Photo" error message. Can you help me find what I did wrong? Thanks for any help!
You have 2 extra arguments in Shapes.AddPicture (LockAspectRatio, Rotation), and a missing one (Width).
See more details about Shapes.AddPicture, and your corrected code below:
Sub do_insertPic(ByRef picname As String, ByRef MyRange As String, myleft As Integer, mytop As Integer)
Dim sht As Worksheet: Set sht = ActiveSheet
Dim rcell As Range
Range(MyRange).Select
On Error GoTo ErrNoPhoto
With sht.Shapes
.AddPicture _
Filename:=picname, _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=myleft + 4, _
Top:=mytop + 4, _
Width:=-1, _
Height:=115
End With
On Error GoTo 0
Exit Sub
ErrNoPhoto:
Debug.Print "Unable to Find Photo" 'Shows message box if picture not found
End Sub
PS: I recommend you to read about avoiding to use .Select in everything...
I am trying to Create a New ActiveX Control CommandButton with Excel VBA. I have a loop VBA which has worked in the past, theFile1.1.xlsm has the master list of the workbooks. I need to add a CommandButton to ~3200 workbooks, so I will be using the Do-Loop macro. Here is the Loop code for reference.
Sub Macro2()
Application.ScreenUpdating = False
Dim sFile As String
Dim wb As Workbook
Dim FileName1 As String
Dim FileName2 As String
Dim wksSource As Worksheet
Const scWkbSourceName As String = "theFILE 1.1.xlsm"
Set wkbSource = Workbooks(scWkbSourceName)
Set wksSource = wkbSource.Sheets("Sheet1") ' Replace 'Sheet1' w/ sheet name of SourceSheet
Const wsOriginalBook As String = "theFILE 1.1.xlsm"
Const sPath As String = "E:\ExampleFolder\"
SourceRow = 5
Do While Cells(SourceRow, "D").Value <> ""
Sheets("Sheet1").Select
FileName1 = wksSource.Range("A" & SourceRow).Value
FileName2 = wksSource.Range("K" & SourceRow).Value
sFile = sPath & FileName1 & "\" & FileName2 & ".xlsm"
Set wb = Workbooks.Open(sFile)
''insert code for loop operation
'''CLOSE WORKBOOK W/O BEFORE SAVE
Application.EnableEvents = False
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.EnableEvents = True
SourceRow = SourceRow + 1
Loop
End Sub
I would like to have the button set as a Variable (i think), so I can edit the formatting/properties and hopefully add a macro to the button later.
Dim buttonControl As MSForms.CommandButton
Set buttonControl = _
ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", _
Link:=False, _
DisplayAsIcon:=False, _
Left:=1464, Top:=310, Width:=107.25, Height:=30)
With buttonControl.Opject
.Caption = "OPEN FOLDER"
.Name = "cmd_OPEN_FOLDER"
End With
I have a 'Run-time error 13: Type Mismatch' error. I am unsure why, because a 'CommandButton1' is created in the correct place.
OLEObjects.Add creates an OLEObject and adds it to the OLEObjects collection; the object returned by the Add function is OLEObject, not MSForm.CommandButton. That's the underlying type of OLEObject.Object - so, set your buttonControl to the .Object property of the returned object:
Set buttonControl = _
ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", _
Link:=False, _
DisplayAsIcon:=False, _
Left:=1464, Top:=310, Width:=107.25, Height:=30).Object
The button is created in the correct place, because the Add function works and returns - what's failing with a type mismatch is the assignment of the returned OLEObject into a CommandButton variable, immediately after that operation.
The subsequent With block can then be just With buttonControl.
I am trying to save a range as a picture file. The code below (scraped from another post) works, but I don't want to create a chart page which I then need to delete. Any suggestions?
Sub savedeal()
Dim sSheetName As String
Dim oRangeToCopy As Range
Dim oCht As Chart
Dim myFileName As String, myPath As String
myFileName = Format(Now(), "dd-mmm-yy") & "-" & "DEAL.PNG"
myPath = "D:\Hughs Files\Google Drive\Work Folder\Polaris\Blog\"
Worksheets("BOOK").Range("B15:M45").CopyPicture xlScreen, xlBitmap
Set oCht = Charts.Add
With oCht
.Export Filename:=myPath & "\" & myFileName, Filtername:="PNG"
End With
End Sub
This has been discussed for years, if you want it saved as an image you will have to add a chart, even add-ins use a chart.
One thing you can do though is save the desired range as a PDF for example.
Sub RngToPDF()
Dim sh As Worksheet, rng As Range, Fnm As String
Set sh = Sheets("Book")
Set rng = sh.Range("B15:M45")
Fnm = "C:\Users\Dave\Downloads\TestMe.pdf"
With sh.PageSetup
.PrintArea = rng.Address
.PrintGridlines = True
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
sh.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Fnm
End Sub
I have a csv file always named the same, called SO2PO.csv. It has data that I import into an excell sheet called PO Data, in a workbook called Open Order. I need to find a way to import all the data from SO2PO.csv to Open Order.xlsm sheet PO Data.
I know it's possible, but how? Can someone point me in the right direction?
Or is there a way to make it so that I can import any .csv file that in placed into a specific folder?
Add this code to create a QueryTable in the PO Data sheet to your data source
Once you have created the QueryTable you can then just right click Refresh the data (or refresh on open)
Sub CSV_Import()
Dim ws As Worksheet, strFile As String
Set ws = ActiveWorkbook.Sheets("PO Data") 'set to current worksheet name
strFile = Application.GetOpenFilename("Text Files (*.csv),*.csv", , "Please select text file...")
With ws.QueryTables.Add(Connection:="TEXT;" & strFile, Destination:=ws.Range("A1"))
.TextFileParseType = xlDelimited
.TextFileCommaDelimiter = True
.Refresh
End With
End Sub
If you're going to use querytables make sure you clean up after, leftover query tables caused me a few headaches in a downstream process.
' get the file to the data sheet
Set ws = ActiveWorkbook.Sheets("Data")
With ws.QueryTables.Add(Connection:="TEXT;" & "mydata.csv", Destination:=ws.Range("A1"))
.TextFileParseType = xlDelimited
.TextFileCommaDelimiter = True
.Refresh
End With
' delete the querytable if there is one
On Error GoTo nothingtodelete
Sheets("Data").QueryTables(1).SaveData = False
Sheets("Data").QueryTables.Item(1).Delete
nothingtodelete:
There are lots of ways to get data into Excel. Querytables (as demonstrated by The_Barman), SQL, Import Wizard etc.
Usually the method depends on how clean the data is presented on the files you need to import and if you know exactly how it's laid out. Eg if there are empty rows, mixed data types, merged cells etc then it can be a nightmare.
Below is a slower 'brute-force' method which will usually get all data by opening the file in Excel first. It's often the last thing to do when other methods fail.
Option Explicit
Public Sub ImportData()
Dim CSVFilename As String
Dim writeToFilename As String
Dim writeToSheet As String
Dim readXL As Workbook
Dim readWS As Worksheet
Dim writeXL As Workbook
Dim writeWS As Worksheet
Dim UsedRng As Range
CSVFilename = Environ$("USERPROFILE") & "\Desktop" & "\SO2PO.csv"
writeToFilename = Environ$("USERPROFILE") & "\Desktop" & "\Open Order.xlsx"
writeToSheet = "PO Data"
Set writeXL = GetObject(writeToFilename)
Set writeWS = writeXL.Sheets(writeToSheet)
'writeWS.Parent.Windows(1).Visible = True
Set readXL = GetObject(CSVFilename)
With readXL
Set readWS = readXL.Sheets(1)
Set UsedRng = RealUsedRange(readWS)
writeWS.Range(UsedRng.Address).Value = UsedRng.Value
End With
'close CSV without saving
readXL.Close SaveChanges:=False
Set readWS = Nothing
Set readXL = Nothing
'close template with save
writeXL.Close SaveChanges:=True
Set writeWS = Nothing
Set writeXL = Nothing
End Sub
Public Function RealUsedRange(ByVal WS As Worksheet) As Range
'Find used range
Dim FirstRow As Long
Dim LastRow As Long
Dim FirstColumn As Integer
Dim LastColumn As Integer
On Error Resume Next
With WS
FirstRow = .Cells.Find(What:="*", After:=.Cells(.Rows.Count, .Columns.Count), LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext).Row
FirstColumn = .Cells.Find(What:="*", After:=.Cells(.Rows.Count, .Columns.Count), LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext).Column
LastRow = .Cells.Find(What:="*", After:=.Range("A1"), LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastColumn = .Cells.Find(What:="*", After:=.Range("A1"), LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Set RealUsedRange = .Range(.Cells(FirstRow, FirstColumn), .Cells(LastRow, LastColumn))
End With
On Error GoTo 0
End Function
it is possible.
Without vba you would use the DATA-Tab and import from text source.
With vba you could open the csv as a new Workbook:
Public Function openSource(fileToOpen As String) As Excel.Workbook
On Error GoTo err_exit
Dim f As Object
Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Set openSource = Nothing
If fs.fileexists(fileToOpen) Then
Set f = fs.GetFile(fileToOpen)
Set openSource = ThisWorkbook.Application.Workbooks.Open( _
FileName:=f.path, _
UpdateLinks:=2, _
ReadOnly:=True, _
AddToMRu:=False, _
Notify:=False)
Windows(openSource.Name).Visible = False
End If
Exit Function
err_exit:
'throwErrMsg "Failed to read File!", "openSource"
If Not openSource Is Nothing Then
openSource.Close SaveChanges:=False, RouteWorkbook:=False
End If
End Function
Dim CSVWorkbook As New Excel.Workbook
Set CSVWorkbook = openSource(c:\SO2PO.csv)
Now you can navigate through this workbook like any other and copy rows, cols or a whole worksheet ;) hope this helps.
Another way would be to use the import from text in vba version, but i don't have an example right away.
Sub demo()
Dim FilePath As String
FilePath = "C:\Users\Tamil\Desktop\padding_values.csv"
Open "C:\Users\Tamil\Desktop\padding_values.csv" For Input As #1
row_number = 0
Do Until EOF(1)
Line Input #1, LineFromFile
LineItems = Split(LineFromFile, ",")
ActiveCell.Offset(row_number, 0).Value = LineItems(2)
ActiveCell.Offset(row_number, 1).Value = LineItems(1)
ActiveCell.Offset(row_number, 2).Value = LineItems(0)
row_number = row_number + 1
Loop
Close #1
End Sub