I want to add a file to Excel, mostly Outlook mail, but I want to limit their size of the icon.
If created from file (Outlook mail), the file is large due to the length of the file name.
If displayed as icon only it is ok, but when I save the document, the file resumes its original appearance (icon and name).
Satisfactory solutions:
importing the file and displaying it as an icon only, but so that it doesn't change after saving;
removal of the title - the icon itself would remain;
inserting another icon (shape) that would be a link to the inserted file
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim FileToOpen As Variant
Dim OtherFormat As String
Dim objInserted As Object
Dim rngSize As Range
Dim sh As Worksheet
OtherFormat = "packager.dll"
Set sh = ThisWorkbook.Sheets("Szacowania")
If Not Intersect(Target, Range("G16:G100")) Is Nothing Then
Dim cel As Range
For Each cel In Target
With cel
'kolumna H - Analiza
If Target.Column = 7 Then
FileToOpen = Application.GetOpenFilename(Title:="Browse for your File & Import Range", FileFilter:="All Files (*.*),*.*")
sh.Range("G" & Target.row).Select
If FileToOpen <> False Then
activesheet.OLEObjects.Add( _
Filename:=FileToOpen, _
Link:=False, _
IconFileName:=OtherFormat, _
DisplayAsIcon:=True, _
IconIndex:=0, _
IconLabel:=FileToOpen). _
Select
End If
End If
End With
Next
End If
End Sub
Related
I've developed a small ticketing system on excel VBA
The Save button will take all data from textboxes and radio button and add it to the row number 7 (in this case)
But when I press upload I can't add the link to the label of attachments
How to add link to the attachment label using (upload file ) button
And also save the Link value stored in upload file button to use it later in clear button and save button?
I'm confused to work with private sub and private dim variables.
I'm newbie in VBA please help
User Form of the System
Save Button Code
Upload button code
Public Sub btnAttachment_Click()
'To upload file link format is png, jpeg, PDF or All files'
Dim wks As Worksheet
Dim LinksList As Range
Dim lastRowLink As Long
Dim LinkAttached As Long
Set wks = ActiveSheet
Set LinksList = Range("N1")
'declare last row to insert link to
lastRowLink = WorksheetFunction.CountA(Sheets("Tickets").Range("A:A"))
Sheets("Tickets").Cells(lastRow + 1, 11).Value = LinkAttached
ChDrive "C:\"
ChDir "C:\"
Filt = "PNG Files(*.png),*.png ," & _
"Jpeg Files(*.jpeg),*.jpg ," & _
"PDF Files (*.pdf),*.pdf ," & _
"All Files (*.*),*.*"
FilterIndex = 1
Title = "Select a File to Hyperlink"
Filename = Application.GetOpenFilename _
(FileFilter:=Filt, _
FilterIndex:=FilterIndex, _
Title:=Title)
If Filename <> False Then
wks.Hyperlinks.Add Anchor:=LinksList, _
Address:=Filename, _
TextToDisplay:=Filename
Else
MsgBox "No file was selected.", vbCritical, "Loading Error"
Exit Sub
End If
End Sub
Attachment PDF file link contains the code and photo too
Buttons Code link
I have a macro that, upon clicking a button, will generate a barcode image (the image is composed of nothing but shapes), and after that, will export 3 sheets to a pdf. The problem I'm having is that doing this will generate the barcode image, but when exporting as a PDF the shapes that were used to generate to barcode don't show up. They will show up if I print or print to pdf without using the export to pdf macro, but that defeats the point of the macro.
An even bigger headache is that this code is on a different version (spreadsheet is a template) of the spreadsheet, but the macro process is working just fine on that spreadsheet. I copy/pasted the working code to the spreadsheet that's giving me trouble and the trouble maker is still not working. Below is the related code. Why are the shapes not being included on the exported PDF?
Sub BevelPrint_Click()
' DisplayBarcode generates a code128 scannable barcode. Max of 14 characters for the selected line width and max width
Call DisplayBarcode
Sheets(Array("(Cal Cert) Page 1 of 3", "(Cal Cert) Page 2 of 3", "(Cal Cert) Page 3 of 3")).Select
' If Application.Dialogs(xlDialogPrinterSetup).Show = True Then
Dim varResult As Variant
Dim ActBook As Workbook
Dim defaultPath As String
Dim WorkbookName As String
'Dim fso As New Scripting.FileSystemObject
' WorkbookName = fso.GetBaseName(ThisWorkbook.Name)
WorkbookName = ThisWorkbook.Sheets("(0) Calibration System QC").Range("B2").Value
WorkbookName = WorkbookName & " Cert"
defaultPath = "\\TSISVFP01\MANUFACTURING\W405 - Particle\"
defaultPath = defaultPath & WorkbookName
'displays the save file dialog
varResult = Application.GetSaveAsFilename(FileFilter:= _
"PDF File (*.pdf), *.pdf, Excel Files (*.xlsx), *.xlsx", Title:="Save Cert as PDF", _
InitialFileName:=defaultPath)
If varResult <> False Then
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
varResult, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
True
End If
' End If
Sheets("(0) Calibration System QC").Select
End Sub
Sub DisplayBarcode()
Dim s As Shape
ThisWorkbook.Worksheets("(Cal Cert) Page 1 of 3").Activate
For Each s In ThisWorkbook.Worksheets("(Cal Cert) Page 1 of 3").Shapes
If s.Name Like "*Straight*" Then
ThisWorkbook.Worksheets("(Cal Cert) Page 1 of 3").Shapes(s.Name).Select
Selection.Delete
End If
Next s
Code128Generate_v2 184, 72, 9, 1.5, Worksheets("(Cal Cert) Page 1 of 3"), ThisWorkbook.Sheets("(0) Calibration System QC").Range("B2"), 40
Dim t As Shape
For Each t In ThisWorkbook.Worksheets("(Cal Cert) Page 1 of 3").Shapes
t.ControlFormat.PrintObject = True
Next t
End Sub
I wonder whether someone can help me please.
I wanting to use this solution in a script I'm trying to put together, but I'm a little unsure about how to make a change which needs to be made.
You'll see in the solution that the file type which is opened is a Excel and indeed it's saved as such. But I the files I'd like to open and save are a mixture of .docx and .dat (Used by Dragon software) files.
Could someone possible tell me please is there a way by which I can amend the code so it opens and saves the files in file types other than Excel workbooks.
The reason behind this question because I'm currently using a script which creates a list of files in a Excel spreadsheet from a given folder. For each file that is retrieved there is a hyperlink, which I'd like to add fucntionality to which enables the user to copy the file and save it to a location of their choice.
To help this is the code which I use to create the list of files.
Public Sub ListFilesInFolder(SourceFolder As Scripting.folder, IncludeSubfolders As Boolean)
Dim LastRow As Long
Dim fName As String
On Error Resume Next
For Each FileItem In SourceFolder.Files
' display file properties
Cells(iRow, 3).Formula = iRow - 12
Cells(iRow, 4).Formula = FileItem.Name
Cells(iRow, 5).Formula = FileItem.Path
Cells(iRow, 6).Select
Selection.Hyperlinks.Add Anchor:=Selection, Address:= _
FileItem.Path, TextToDisplay:="Click Here to Open"
iRow = iRow + 1 ' next row number
With ActiveSheet
LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
End With
For Each Cell In Range("C13:F" & LastRow) ''change range accordingly
If Cell.Row Mod 2 = 1 Then ''highlights row 2,4,6 etc|= 0 highlights 1,3,5
Cell.Interior.Color = RGB(232, 232, 232) ''color to preference
Else
Cell.Interior.Color = RGB(141, 180, 226) 'color to preference or remove
End If
Next Cell
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder, True
Next SubFolder
End If
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
Many thanks and kind regards
Chris
Miguel provided a fantastic solution which on initial testing appeared to work 100%. But as you will see from the comments at the end of the post there were some issues when the user cancelled the operation, so I made another post at this link where the problems were ironed out. Many thanks and kind regards. Chris
The code below shows how to retrieve the extension of a file, define an array with “allowed” extensions, and match the extension of the file to the array.
This is the outline for file manipulation, you'll just need to tailor it to you needs
Dim MinExtensionX
Dim Arr() As Variant
Dim lngLoc As Variant
'Retrieve extension of file
MinExtensionX = Mid(MyFile.Name, InStrRev(MyFile.Name, ".") + 1)
Arr = Array("xls", "xlsx", "docx", "dat") 'define which extensions you want to allow
On Error Resume Next
lngLoc = Application.WorksheetFunction.Match(MinExtensionX, Arr(), 0)
If Not IsEmpty(lngLoc) Then '
'check which kind of extension you are working with and create proper obj manipulation
If MinExtensionX = "docx" then
Set wApp = CreateObject("Word.Application")
wApp.DisplayAlerts = False
Set wDoc = wApp.Documents.Open (Filename:="C:\Documents\SomeWordTemplate.docx", ReadOnly:=True)
'DO STUFF if it's an authorized file. Then Save file.
With wDoc
.ActiveDocument.SaveAs Filename:="C:\Documents\NewWordDocumentFromTemplate.docx"
End With
wApp.DisplayAlerts = True
End if
End If
For files .Dat its a bit more complex, specially if you need to open/process data from the file, but this might help you out.
Edit:
2: Comments added
Hi IRHM,
I think you want something like this:
'Worksheet_FollowHyperlink' is an on click event that occurs every time you click on an Hyperlink within a Worksheet, You can find more here
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
'disable events so the user doesn't see the codes selection
Application.EnableEvents = False
Dim FSO
Dim sFile As String
Dim sDFolder As String
Dim thiswb As Workbook ', wb As Workbook
'Define workbooks so we don't lose scope while selecting sFile(thisworkbook = workbook were the code is located).
Set thiswb = thisworkbook
'Set wb = ActiveWorkbook ' This line was commented out because we no longer need to cope with 2 excel workbooks open at the same time.
'Target.Range.Value is the selection of the Hyperlink Path. Due to the address of the Hyperlink being "" we just assign the value to a
'temporary variable which is not used so the Click on event is still triggers
temp = Target.Range.Value
'Activate the wb, and attribute the File.Path located 1 column left of the Hyperlink/ActiveCell
thiswb.Activate
sFile = Cells(ActiveCell.Row, ActiveCell.Column - 1).Value
'Declare a variable as a FileDialog Object
Dim fldr As FileDialog
'Create a FileDialog object as a File Picker dialog box.
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
'Allow only single selection on Folders
fldr.AllowMultiSelect = False
'Show Folder picker dialog box to user and wait for user action
fldr.Show
'add the end slash of the path selected in the dialog box for the copy operation
sDFolder = fldr.SelectedItems(1) & "\"
'FSO System object to copy the file
Set FSO = CreateObject("Scripting.FileSystemObject")
' Copy File from (source = sFile), destination , (Overwrite True = replace file with the same name)
FSO.CopyFile (sFile), sDFolder, True
' check if there's multiple excel workbooks open and close workbook that is not needed
' section commented out because the Hyperlinks no longer Open the selected file
' If Not thiswb.Name = wb.Name Then
' wb.Close
' End If
Application.EnableEvents = True
End Sub
The above code Triggers when you click the Hyperlink and it promps a folder selection window.
You just need to paste the code into the Worksheet code. And you should be good to go.
So i have searched for hours now and did not find a solution.
I am trying to export sheets that have a print area to PDF but the PDF layout is different than what i see when i check the print preview.
i am using excel 2010.
Does anyone know why this happens.
code i use to export
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
filename:=filename, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Finally found a solution. apparently its something with the settings.
In Excel, go to File > Options > Advanced. Under General section,
uncheck ‘Scale content for A4 or 8.5 x 11” paper size’ and click OK.
Instead of exporting the document, why dont you print the sheet and set the printer to PDF printer something like.
Sub PrintTest() ' This will print multiple sheets based on a certain criteria
Dim sh As Worksheet
Dim arr() As String
Dim i As Long: i = 0
For Each sh In ThisWorkbook.Worksheets
If Mid(sh.Name, 1, 4) = "Test" Then ' Change the conditional statement
sh.PageSetup.Orientation = xlLandscape
ReDim Preserve arr(i)
arr(i) = sh.Name
i = i + 1
End If
Next sh
Dim printSheets As Variant
printSheets = arr
Worksheets(printSheets).PrintOut Preview:=False, ActivePrinter:="Adobe PDF", PrintToFile:=True, PrToFileName:=PSFileName
End Sub
I am trying to create a button which prompts the user for a file then creates a hyperlink in the active spreadsheet.
Goal: after the file is uploaded subsequent users can click on the hyperlink to view the file.
What I have tried, create an ActiveX control in Excel, but representing the input as a hyperlink output in a cell is the problem.
Private Sub CommandButton1_Click()
Dim sFullName As String
Application.FileDialog(msoFileDialogOpen).Show
sFullName = Application.FileDialog(msoFileDialogOpen).SelectedItems(1)
End Sub
Insert reference to pdfs
Sub InsertObjectAsIcon()
'lets user browse for a file to insert into the
'current active worksheet.
'all are inserted as icons, not "visible" objects, so
'to view they will need an appropriate viewer/reader
'at the recipient end.
'
'This one shows how you could set up to use
'several different icons depending on the type of file
'inserted. You'll have to experiment by recording
'macros while inserting various file types to build
'up a list to use, just add new Case Is = statements
'do deal with the file types. Be sure to enter the
'file type in all UPPERCASE.
'
Dim iconToUse As String
Dim fullFileName As String
Dim FNExtension As String
fullFileName = Application.GetOpenFilename("*.*, All Files", , , , False)
If fullFileName = "False" Then
Exit Sub ' user cancelled
End If
'choose an icon based on filename extension
'get all after last "." in filename
FNExtension = Right(fullFileName, Len(fullFileName) - _
InStrRev(fullFileName, "."))
'select icon based on filename extension
Select Case UCase(FNExtension)
Case Is = "TXT"
iconToUse = "C:\Windows\system32\packager.dll"
Case Is = "XLS", "XLSM", "XLSX"
iconToUse = "C:\Windows\Installer\{91140000-0011-0000-0000-0000000FF1CE}\xlicons.exe"
Case Is = "PDF"
iconToUse = "C:\Windows\Installer\{AC76BA86-1033-F400-7761-000000000004}\_PDFFile.ico"
Case Else
'this is a generic icon
iconToUse = "C:\Windows\system32\packager.dll"
End Select
ActiveSheet.OLEObjects.Add(Filename:=fullFileName, Link:=False, DisplayAsIcon:=True, IconFileName:=iconToUse, IconIndex:=0, IconLabel:=fullFileName).Select3
End Sub
Private Sub CommandButton1_Click()
InsertObjectAsIcon
End Sub
This code opens the common file dialog, filtered to show .xslx files. It picks up the path to the file, then inserts it into the activecell. There's also an inputbox asking for a short text name, if you don't want to see the full path.
Sub FileToLink()
Dim strFileName As String
Dim strShortName As String
strFileName = Application.GetOpenFilename("Excel Documents (*.xlsx), *.xlsx")
If strFileName = "False" Then
Exit Sub ' user cancelled
End If
strShortName = InputBox("What do you want to call this link?", "Short Text", strFileName)
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=strFileName, TextToDisplay:=strShortName
End Sub
You can substitute strFileName = Application.GetOpenFilename("All Documents (*.*), *.*") to show all files. It doesn't matter to the link what file it is, as clicking on the link will invoke the application linked with that file type.