I am using the script listed below (I honestly stole this probably from this very site) for a browse button on a form. The task is simply to start up MS File Dialog box so that a file (in this case an image file) can be selected. Once you select the record and click ok it then pastes the file name and location into a field.
Viewing the table the file name and location is pasted just as it should be. The problem comes in with a report I built. I have an image set to display with the control source linked back to that file address field. It will not display the image though.
However, if I manually type the same address character for character or even “copy”, delete, and then “paste” the same exact entry into the field the image then displays just fine on the report.
I have checked to make sure there are no spaces or characters anywhere there shouldn’t be. I am at a loss here.
Any help would be greatly appreciated and I will gladly give you my first born. Ok maybe not the first I like him but you can have the second one, she’s hell.
Private Sub Command67_Click()
On Error GoTo SubError
'Add "Microsoft Office 14.0 Object Library" in references
Const msoFileDialogFilePicker As Long = 3
'Dim FD As Office.FileDialog
Dim FDialog As Object
Dim varfile As Variant
Set FDialog = Application.FileDialog(msoFileDialogFilePicker)
EmployeePicture = ""
' Set up the File Dialog
Set FDialog = Application.FileDialog(msoFileDialogFilePicker)
With FDialog
.Title = "Choose the spreadsheet you would like to import"
.AllowMultiSelect = False
.InitialFileName = "C:\Users\" 'Folder picker needs trailing slash
.Filters.Clear
.Filters.Add "All", "*.*"
If .Show = True Then
If .SelectedItems.Count = 0 Then
'User clicked open but didn't select a file
GoTo SubExit
End If
'An option for MultiSelect = False
'varFile = .SelectedItems(1)
'EmployeePicture = varFile
'Needed when MultiSelect = True
For Each varfile In .SelectedItems
EmployeePicture = EmployeePicture & varfile & vbCrLf
Next
Else
'user cancelled dialog without choosing!
'Do you need to react?
End If
End With
SubExit:
On Error Resume Next
Set FDialog = Nothing
Exit Sub
SubError:
MsgBox "Error Number: " & Err.Number & " = " & Err.Description, vbCritical + vbOKOnly, _
"An error occurred"
GoTo SubExit
End Sub
Related
This question already has answers here:
VBScript to send email without running Outlook
(2 answers)
Closed 3 years ago.
I want to select files within Windows Explorer and then by pressing a shortcut (assigned to a VBS-script) to send these files with Outlook (2010).
I found two working code snippets:
Code snippet1 (Creating Email):
Dim objOutl
Set objOutl = CreateObject("Outlook.Application")
Set objMailItem = objOutl.CreateItem(olMailItem)
'comment the next line if you do not want to see the outlook window
objMailItem.Display
strEmailAddr = "test#test.com"
objMailItem.Recipients.Add strEmailAddr
objMailItem.Body = "Hi, this is the body.."
objMailItem.Attachments.Add "C:\test.txt"
'objMailItem.Send
Set objMailItem = nothing
Set objOutl = nothing
Code snippet2 (returning paths of the selected files in Windows Explorer):
Function GetSelectedFiles() 'Returns paths as array of strings
Dim FileList, Window, SelectedItem
'avoid duplicates by storing paths in dictionary keys
Set FileList = CreateObject("Scripting.Dictionary")
With CreateObject("Shell.Application")
For Each Window In .Windows
'skip IE Windows
If InStr(1, Window.FullName, "iexplore.exe", vbTextCompare) = 0 Then
For Each SelectedItem In Window.Document.SelectedItems
FileList(SelectedItem.Path) = Null
'MsgBox SelectedItem.Path
Next
End If
Next
End With
GetSelectedFiles = FileList.Keys 'array of paths
End Function
MsgBox "Click OK after selecting the items", vbOKOnly Or vbInformation, "Select a few items"
Dim SelectedFiles
SelectedFiles = GetSelectedFiles
MsgBox "You selected: " & vbNewLine & vbNewLine & Join(SelectedFiles, vbNewLine), vbOKOnly Or vbInformation, "Selected Items"
How to combine these code snippets to achieve my purpose? I tried to give the SelectedItem.Path a variable to add it to the objMailItem.Attachments.Add but it is not working.
I tried the cdo approach but this issue seems to be more complex. I have an office365-account and the configuration settings seems to differ from VBScript to send email without running Outlook.
Yesss I got it working and it is very cool, I love it :-)
Dim x ,objOutl ,objMailItem ,strEmailAddr
Set objOutl = CreateObject("Outlook.Application")
Set objMailItem = objOutl.CreateItem(olMailItem)
'comment the next line if you do not want to see the outlook window
objMailItem.Display
strEmailAddr = "test#test.com"
objMailItem.Recipients.Add strEmailAddr
objMailItem.Subject = "Test"
objMailItem.Body = "Hi, this is the body.."
'in the next line it will jump in to function "GetSelectedFiles"
x=GetSelectedFiles
'comment out the next three lines for sending directly..
'objMailItem.Send
'Set objMailItem = nothing
'Set objOutl = nothing
Function GetSelectedFiles() 'Returns paths as array of strings
Dim FileList, Window, SelectedItem
'avoid duplicates by storing paths in dictionary keys
Set FileList = CreateObject("Scripting.Dictionary")
With CreateObject("Shell.Application")
For Each Window In .Windows
'skip IE Windows
If InStr(1, Window.FullName, "iexplore.exe", vbTextCompare) = 0 Then
For Each SelectedItem In Window.Document.SelectedItems
FileList(SelectedItem.Path) = Null
x = SelectedItem.Path
'next line is just for debugging..
'msgBox x
'The next line was the solution
objMailItem.Attachments.Add x
Next
End If
Next
End With
GetSelectedFiles = x 'array of paths
End Function
I'm facing a serious problem while importing my script into UFT for more than 2 weeks, I tried everything. As a worarround, I'm cpying the workbook and then I import the new on but this sometimes doesn't work too.
this is my code:
DataTable.ImportSheet workbook1,"name1","sheet1"
this is my workarround:
On error resume next
DataTable.ImportSheet workbook_path,"name1","sheet1"
MsgBox "Error: " & Err.Number & " (" & Err.Source & ") - " & Err.Description
If Err.Number <> 0 Then
If err.number = 20012 Then
Set objExcel1 = CreateObject("Excel.Application")
objExcel1.Visible = False
objExcel1.DisplayAlerts=False
Dim RelativePath
RelativePath = "C:\xyz\new_workbook.xls"
Dim objSheet1
Set objWorkbook1= objExcel1.Workbooks.Open("workbook.xls")
Set filesys = CreateObject("Scripting.FileSystemObject")
If filesys.FileExists(RelativePath) Then
filesys.DeleteFile RelativePath
End If
Set objWorkbook2=objExcel1.Workbooks.Add
objWorkbook2.saveAs RelativePath
For each objsheet1 in objworkbook1
objworkbook2.AddSheet objsheet1.Name
objsheet1.copy objworkbook2.sheets(1)
Next
objWorkbook2.save
objworkbook1.close
objworkbook2.close
objExcel1.Quit
Set objSheet1 = Nothing
Set objWorkbook1 = Nothing
Set objWorkbook2 = Nothing
Set objExcel1 = Nothing
On error resume next
DataTable.ImportSheet RelativePath,"name1","sheet1"
MsgBox "Error: " & Err.Number & " (" & Err.Source & ") - " & Err.Description
End if
End If
I want to try looping all the rows of the sheets and copying them into the new ones instead of copying them directly. Any help please ? if anyone has other solution to solve this issue, pleeeeeeease help
Why loop through the rows if you want them all? Just copy the sheet. IF you need the code for that, fire up the macro recorder, copy the sheet and stop the macro recorder.
Change your DataTable.ImportSheet workbook1,"name1","sheet1" call to DataTable.ImportSheet workbook1,"name1","Action1" or to DataTable.ImportSheet workbook1,"name1","Global". Make sure that your path is correct for the workbook and name1 sheet exists in your workbook
Are you able to import manually into DataTable? Sometimes, the special characters from the spreadsheet throw error.
If you are receiving "Invalid file error", follow the steps.
1. Open UFT and Activate Data Table and Perform the below action
Perform
Choose the appropriate sheet to be imported.
Check if any "Invalid File Error Dialog". If yes Goto Step 5 else GoTo Step 2
Go back to actual spreadsheet and replace all of the special characters including spaces and clear all the Formatting of the cells
I'm trying to select around 17k files in a specific folder containing around 22k from a list in excel. The list has the name and extension of all files and nothing more.
I've tried this code but no luck.
Sub DeletePics()
Dim picRNG As Range, pic As Range, picPATH As String
picPATH = "path"
Set picRNG = Sheets("Sheet1").Range("A1:A17108").SpecialCells(xlConstants)
On Error Resume Next
For Each pic In picRNG
If pic.Offset(, 1) = "Delete" Then
If Len(Dir(picPATH & pic.Value)) > 0 Then
Kill picPATH & pic.Value
pic.Offset(, 2).Value = "Deleted"
Else
pic.Offset(, 2).Value = "Not Found"
End If
End If
Next pic
End Sub
I have a text file with some numbers, like so:
123456789
987654321
The file is called numbers.txt
I am trying to open the file and read it line by line and compare it another separate number
'Create the file system object
Set fso = CreateObject("Scripting.FileSystemObject")
identify = "123456789"
WScript.Echo identify
numfile = fso.OpenTextFile("C:\numbers.txt", ForReading)
WScript.Echo numfile.ReadLine
WScript.Echo "test2"
Do Until numfile.AtEndOfStream
cell = numfile.ReadLine
WScript.Echo cell
If identify = cell Then
count = 1
End If
Loop
WScript.Echo "end of loop"
However my code is getting stuck in an infinite loop with the AtEndOfStream loop. Furthermore,
WScript.Echo cell
is always an empty dialog box, and
WScript.Echo numfile.ReadLine
doesn't Echo anything, it just skips right to echo-ing "test 2". Where am I going wrong? The directory of the file is right, and it exists with the numbers
Edit: I tried
WScript.Echo numfile.ReadAll
and was just greeted with an empty dialog box
I also tried to open it as Unicode, but it didn't make any difference
Define ForReading:
Const ForReading = 1
, get rid of any "On Error Resume Next", and try again.
If you'd disabled the the evil OERN, you'd have seen an error message for
numfile = fso.OpenTextFile("C:\numbers.txt", ForReading)
which should be
Set numfile = fso.OpenTextFile("C:\numbers.txt", ForReading)
I need a method to check the contents of the text entered to make sure they are correctly entering a folder path. So it needs to be in the format of:
Drive Letter :\ Folder
e.g. C:\My Documents
If they haven't typed in that format I need to stop and show a message telling them to double check.
I have tried the Filter function but I haven't quite got it to work. Any help would be awesome. I don't have any code to show because I am nto sure where to start.
I also tried the common dialog, but the user jsut needs the type the path, not select the file. All I want to check is if the text type is within that format DRIVE:\FOLDER, that is it. So if the type "BLAH" in the text bax a message says Hey you type a correct path.
In VB6, to test whether your text contains a valid folder:
If Len(Dir("c:\My Documents", vbDirectory))>0 Then
'it's a folder
End If
Have you thought of implemeting the common dialog control to allow the selection of a correct folder instead - it'll be much more likely to be accurate.
Some example code of folder browsing from here:
Private Sub Command1_Click()
On Error Resume Next
Const WINDOW_HANDLE = 0
Const NO_OPTIONS = 0
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(WINDOW_HANDLE, "select folder:", NO_OPTIONS, "C:Scripts")
Set objFolderItem = objFolder.Self
objPath = objFolderItem.Path
objPath = Replace(objPath, "", "\")
Print objPath
End Sub
Alternatively you could validate the folder first you could check for ":\" using eith instr or mid
then you could validate the folder and even include an option to create it if not present with the filesystemobject (needs a reference set) here it is in function form, you can pass the contents of the textbox for validation.
Function DirExists(pFile As String, Optional pCreate As Boolean = False)
'
Dim fso As New FileSystemObject
Dim vPath As Variant
Dim sPath As String
Dim y As Variant
DirExists = False
If fso.FolderExists(pFile) Then
DirExists = True
Else
If pCreate Then
vPath = Split(pFile, "\")
For Each y In vPath
sPath = sPath & y & "\"
If Not fso.FolderExists(sPath) Then
fso.CreateFolder (sPath)
If fso.FolderExists(pFile) Then
DirExists = True
Exit Function
End If
End If
Next
End If
End If
End Function