I want to insert files when this function is called.
I want the input file to be shown with a specific width, height, and have the icon of the file.
I also want to have the input be in a specific cell.
Is there a better way to define what cell I want the input to be in? I want the input to be in cell 'I5' but I am not sure how to go out doing this with the top and left parameters in OLEObjects.Add.
Sub FileToLink()
Dim strFileName As String
Dim strShortName As String
Dim f As OLEObject
strFileName = Application.GetOpenFileName("All Documents (*.*), *.*")
If strFileName = "False" Then
Exit Sub ' user cancelled
End If
strShortName = InputBox("What do you want to call this link?", "Short Text", strFileName)
Set f = ActiveSheet.OLEObjects.Add( _
Filename:=strFileName, _
Link:=False, _
DisplayIcon:=False, _
IconFileName:=strFileName, _
IconIndex:=0, _
IconLabel:=strShortName, _
Top:=Range("I5").Top, _
Left:=Range("I5").Left, _
Width:=10, _
Height:=10)
End Sub
Thanks to an answer I changed the Top and Left to make the input in the correct cell, however I am still unsure on how to change the width and height.I Keep getting an input box that is longer than it is tall.
Related
I have code to insert pdf invoice copies in customer's account statement. The code is working fine. Just the custom icon size is not as per the defined 15x51 (HxW). Please suggest how the code can resize the icon file to fit in this 15x51 box (the size of cells in column M as in below picture)? I am using a 16x16 icon file.
Here is the current result.
Sub Insert_PDF_File()
Application.ScreenUpdating = False
Dim cell As Range
' loop each cell in column A
For Each cell In Range("A10:A" & Range("A" & Rows.Count).End(xlUp).Row)
' make sure the cell is NOT empty before doing any work
If Not IsEmpty(cell) Then
' create and insert a new OleObject based on the path
Dim ol As OLEObject
' ActiveWorkbook.path & "\" & cell & ".pdf" will make the filename
Set ol = ActiveSheet.OLEObjects.Add( _
Filename:="C:\Invoices\Renamed" & "\" & cell & ".pdf", _
Link:=False, _
DisplayAsIcon:=True, _
IconFileName:="C:\Users\pvishwas\Documents\WORK\Macros\PDF.ico", _
IconIndex:=0, _
Height:=15, Width:=51, IconLabel:="Open")
' align the OleObject with Column D - (0 rows, 3 columns to the right from column A)
With ol
.Top = cell.Offset(0, 12).Top
.Left = cell.Offset(0, 12).Left
End With
End If
Next
Application.ScreenUpdating = True
End Sub
According to me, it's due to icon size.
Please check below the code I created. It takes given size for object.
Sub AddPDF()
Dim ws As Worksheet
Dim FilePath As String
Dim x As OLEObject
Set ws = ThisWorkbook.Worksheets(1)
FilePath = "D:\certificate-of-earnings.pdf"
ws.Range("A1").Select
ws.OLEObjects.Add Filename:=FilePath, Link:=False, DisplayAsIcon:=True, Height:=15, Width:=51, IconLabel:="PDF"
End Sub
So I have this code below that currently works. All of the data is on a tab called "Table" and feed into a tab called "Att A" that gets produced into 100+ pdf files and named based on the value that is in column A in the "Table" tab.
I would like to add a conditional statement to the following code that checks the value in column CH in the "Table" tab and if it is greater than 0 save in one location, if it equals 0 then save in another location. Since there are 100+ lines of data, the value in column A needs to check the value in the same row for column CH.
So the logic goes to column A (Uses this value as the file name), creates a file, and checks column CH to determine which folder to save the file in. How do I add this condition to the following code?
Sub Generate_PDF_Files()
Application.ScreenUpdating = False
Sheets("Table").Activate
Range("A7").Activate
Do Until ActiveCell.Value = "STOP"
X = ActiveCell.Value
Range("DLR_NUM") = "'" & X
Sheets("Att A").Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"L:\Mike89\Sales" & X & ".pdf", Quality:=xlQualityStandard, _IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
Sheets("Table").Activate
ActiveCell.Offset(1, 0).Activate
Loop
End Sub
Since your code works, we would typically suggest you post it on Code Review, however you're also looking for some help on a conditional statement.
So a few quick things...
Avoid Select and Activate
Use Descriptive Variable Naming
Always Define and Set References to Worksheets and Workbooks
Never Assume the Worksheet
The conditional itself is very straightforward as shown in the example below, which also incorporates the ideas shared in the links above:
Option Explicit
Sub Generate_PDF_Files()
Dim tableWS As Worksheet
Dim attaWS As Worksheet
Dim filename As Range
Dim checkValue As Range
Dim filepath As String
Const ROOT_FOLDER1 = "L:\Mike89\Sales"
Const ROOT_FOLDER2 = "L:\Mike99\Sales"
Set tableWS = ThisWorkbook.Sheets("Table")
Set attaWS = ThisWorkbook.Sheets("Att A")
Set filename = tableWS.Range("A7")
Set checkValue = tableWS.Range("CH7")
Application.ScreenUpdating = False
Dim dlrNum as Range
set dlrNum = tableWS.Range("DLR_NUM")
Do Until filename = "STOP"
dlrNum = "'" & filename
If checkValue > 0 Then
filepath = ROOT_FOLDER1 & filename
Else
filepath = ROOT_FOLDER2 & filename
End If
attaWS.ExportAsFixedFormat Type:=xlTypePDF, _
filename:=filepath, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Set filename = filename.Offset(1, 0)
Set checkValue = checkValue.Offset(1, 0)
Loop
Application.ScreenUpdating = True
End Sub
I like to import a picture into Word using VBA. The picture need to be imported to a bookmark and then scaled.
I have tried with below code but have a few issues with the code. The picture is not imported to the bookmark and I haven't been able to scale the picture. Any suggestions what I'm doing wrong?
Sub ImportReport()
ActiveDocument.GoTo What:=wdGoToBookmark, Name:="bm1"
Selection.InlineShapes.AddPicture FileName:= _
"File_path_to_the_PNG_file", _
LinkToFile:=False, _
SaveWithDocument:=True
', _
'ScaleWidth:=100, _
'ScaleHeight:=100
InlineShapes.Item(1).ScaleHeight = 100
Shapes.Item(1).ScaleWidth = 100
End Sub
This is what I did in the end. I had 18 pictures to import. I had already created the bookmarks in the word file.
Sub ImportScaleWrap()
Dim ImagePath As String
Dim FileName As String
Dim i As Integer
ImagePath = "IMAGE_PATH"
FileName = "GENERIC_PART_OF_FILE_NAME"
Dim RiskPic As InlineShape
For i = 1 To 18
Set RiskPic = ActiveDocument.Bookmarks("bm" & i).Range.InlineShapes.AddPicture(FileName:=ImagePath & FileName & i & ".png", LinkToFile:=False, SaveWithDocument:=True)
RiskPic.ScaleHeight = 100
RiskPic.ScaleWidth = 100
Dim RiskPicType As Shape
Set RiskPicType = RiskPic.ConvertToShape
RiskPicType.WrapFormat.Type = wdTopBottom
Next i
End Sub
I am trying to use VBA to open hyperlinks from my excel using the following code:
numRow = 1
Do While WorksheetFunction.IsText(Range("E" & numRow))
ActiveSheet.Range("E" & numRow).Hyperlinks(1).Follow
numRow = numRow + 1
Loop
However, I keep getting Runtime Error 9: Subscript out of range at the point in the code where I follow the hyperlinks.
I'm pretty new to VBA Macro-making (as in-'never done it before'), so help would be appreciated. (And if there's a better way to open a link from each cell in a single column, I'd appreciate learning about that too)
EDIT (To add more Info)
The hyperlink in question has been created using HYPERLINK Worksheet function and the text does not display the link URL. Sample of worksheet data is something like this:
What It Looks Like
Case ------ Link
Case1----- Summary
Case2----- Summary
Case3----- Summary
The Cells showing the text "Summary", however, contain a formula
=HYPERLINK("whateverthebaseurlis/"&[#[Case]]&"/Summary", "Summary")
And this is the link that has to be followed. The link works, it can be followed manually. But I need to do it via macro
Thanks
Probably, you are getting error because you have some cells with text but no link!
Check for link instead of whether or not cell is text:
numRow = 1
Do While ActiveSheet.Range("E" & numRow).Hyperlinks.Count > 0
ActiveSheet.Range("E" & numRow).Hyperlinks(1).Follow
numRow = numRow + 1
Loop
If it is throwing the error where you try to open hyperlinks, try and explictly open it using explorer.exe
Shell "explorer.exe " & Range("E" & numRow).Text
the reason Hyperlinks(1).Follow not working is that is no conventional hyperlink in the cell so it will return out of range
numRow = 1
Do While WorksheetFunction.IsText(Range("E" & numRow))
URL = Range("E" & numRow).Text
Shell "C:\Program Files\Internet Explorer\iexplore.exe " & URL, vbNormalNoFocus
numRow = numRow + 1
Loop
Check this post for a similar problem:
http://www.mrexcel.com/forum/excel-questions/381291-activating-hyperlinks-via-visual-basic-applications.html
TRIED AND TESTED
Assumptions
I am covering 3 scenarios here as shown in the Excel file.
=HYPERLINK("www."&"Google"&".Com","Google"). This hyperlink has a friendly name
www.Google.com Normal hyperlink
=HYPERLINK("www."&"Google"&".Com") This hyperlink doesn't have a friendly name
Screenshot:
Logic:
Check what kind of hyperlink is it. If it is other than which has a friendly name then the code is pretty straightforward
If the hyperlink has a friendly name then what the code tries to do is extract the text "www."&"Google"&".Com" from =HYPERLINK("www."&"Google"&".Com","Google") and then store it as a formula in that cell
Once the formula converts the above text to a normal hyperlink i.e without the friendly name then we open it using ShellExecute
Reset the cell's original formula
Code:
Private Declare Function ShellExecute _
Lib "shell32.dll" Alias "ShellExecuteA" ( _
ByVal hWnd As Long, ByVal Operation As String, _
ByVal Filename As String, Optional ByVal Parameters As String, _
Optional ByVal Directory As String, _
Optional ByVal WindowStyle As Long = vbMinimizedFocus _
) As Long
Sub Sample()
Dim sFormula As String
Dim sTmp1 As String, sTmp2 As String
Dim i As Long
Dim ws As Worksheet
'~~> Set this to the relevant worksheet
Set ws = ThisWorkbook.Sheets(1)
i = 1
With ActiveSheet
Do While WorksheetFunction.IsText(.Range("E" & i))
With .Range("E" & i)
'~~> Store the cells formula in a variable for future use
sFormula = .Formula
'~~> Check if cell has a normal hyperlink like as shown in E2
If .Hyperlinks.Count > 0 Then
.Hyperlinks(1).Follow
'~~> Check if the cell has a hyperlink created using =HYPERLINK()
ElseIf InStr(1, sFormula, "=HYPERLINK(") Then
'~~> Check if it has a friendly name
If InStr(1, sFormula, ",") Then
'
' The idea here is to retrieve "www."&"Google"&".Com"
' from =HYPERLINK("www."&"Google"&".Com","Google")
' and then store it as a formula in that cell
'
sTmp1 = Split(sFormula, ",")(0)
sTmp2 = "=" & Split(sTmp1, "HYPERLINK(")(1)
.Formula = sTmp2
ShellExecute 0, "Open", .Text
'~~> Reset the formula
.Formula = sFormula
'~~> If it doesn't have a friendly name
Else
ShellExecute 0, "Open", .Text
End If
End If
End With
i = i + 1
Loop
End With
End Sub
A cleaner way of getting cells hyperlinks:
Using Range.Value(xlRangeValueXMLSpreadsheet), one can get cell hyperlink in XML. As so, we only have to parse XML.
'Add reference to Microsoft XML (MSXML#.DLL)
Function GetHyperlinks(ByVal Range As Range) As Collection
Dim ret As New Collection, h As IXMLDOMAttribute
Set GetHyperlinks = ret
With New DOMDocument
.async = False
Call .LoadXML(Range.Value(xlRangeValueXMLSpreadsheet))
For Each h In .SelectNodes("//#ss:HRef")
ret.Add h.Value
Next
End With
End Function
So you can use this function in your code as this:
numRow = 1
Do While WorksheetFunction.IsText(Range("E" & numRow))
FollowHyperlink GetHyperlinks(ActiveSheet.Range("E" & numRow))
numRow = numRow + 1
Loop
If you don't need numRow, you can just:
Dim h as String
For Each h In GetHyperlinks(ActiveSheet.Range("E:E"))
FollowHyperlink h
Next
For FollowHyperlink, I suggest below code - you have other options from another answers:
Sub FollowHyperlink(ByVal URL As String)
Shell Shell "CMD.EXE /C START """" """ & URL & """"
End Sub
I'm using vba in PowerPoint. I'm trying to compress orginal picture files from a specified folder to a smaller size. I was able to achieve that. However, I want to save the new compressed picture into a destination folder.
The following code will save the presenation or slide with the picture. But I only want the picture. I'm pretty sure I have to use ActivePresentation.SaveAs. But it will only let me save the slide. How can I save the pic alone & not the slide?
Also, I seem to have another problem when I try to save the modified pic. It saves the presentation into a folder in the destination with a filename of "Slide1.bmp". Any idea why & how can I change this?
Dim strSrcPath As String, strDestPath As String
Dim strSrcPic As String
Dim objPic As Shape
Dim x as Integer
strSrcPath = "C:\Temp\Pics\In\"
strDestPath = "C:\Temp\Pics\Out\"
strSrcPic = Dir(strSrcPath)
Do While strSrcPic <> ""
x = x + 1
Set objPic = ActiveWindow.Selection.SlideRange.Shapes.AddPicture(FileName:=strSrcPath & strSrcPic, _
LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=0, Top:=0, Width:=100, _
Height:=100)
With objPic
.ScaleHeight 1, msoTrue
.ScaleWidth 1, msoTrue
End With
objPic.Select
ActivePresentation.SaveAs _
FileName:=strDestPath & "ModPicture(" & x & ").bmp", _
FileFormat:=ppSaveAsBMP, EmbedTrueTypeFonts:=msoFalse
objPic.Delete
strSrcPic = Dir 'Get next entry.
Loop
Thanks #JSRWilson for the following response:
"You do have to right click in View >Object Browser >> Show Hidden Members
Assuming objPic is still a reference to the compressed pic
objPic.Export(strDestPath & "& "ModPicture(" & x & ").bmp", ppSaveAsBMP)"