function readFromRegistry (strRegistryKey, strDefault)
Dim WSHShell, value
On Error Resume Next
Set WSHShell = CreateObject ("WScript.Shell")
value = WSHShell.RegRead (strRegistryKey)
if err.number <> 0 then
readFromRegistry= strDefault
else
readFromRegistry=value
end if
set WSHShell = nothing
end function
function OpenWithChrome(sPage)
Dim strChrome
Dim WShellChrome
strChrome = readFromRegistry ( "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\chrome.exe\Path", "")
if (strChrome = "") then
strChrome = "chrome.exe"
else
strChrome = strChrome & "\chrome.exe"
end if
Set WShellChrome = CreateObject("WScript.Shell")
strChrome = """" & strChrome & """" & " " & sPage
WShellChrome.Run strChrome, 1, false
end function
OpenWithChrome "auto slides.html"
At last line i'm calling function OpenWithChrome with argument containing spaces. But it unable to open that file in my browser.
You just need to encode your space so Chrome can understand it. Change that line to:
OpenWithChrome "auto%20slides.html"
More information on encoding html files that use spaces can be found here:
HTML: href syntax : is it okay to have space in file name
Related
I have a table that contains a paths of multi pdfs file...now I need a VBA code to merge all these files to a single pdf file.
Notice:-the number of pdfs files to be merged varies from time to time.
Sub Combine_PDFs_Demo()
Dim i As Integer 'counter for records
Dim x As Integer
Dim strNPDF As String
Dim bSuccess As Boolean
Dim DB As Database
Dim RS As Recordset
Set DB = CurrentDb
Set RS = DB.OpenRecordset("SELECT[paths] from scantemp ")
strNPDF = CurrentProject.Path & "\request_pic\" & (request_no) & ".pdf"
RS.MoveLast
DB.Recordsets.Refresh
i = RS.RecordCount
RS.MoveFirst
Dim strPDFs() As String
ReDim strPDFs(0 To i)
strPDFs(0) = RS![paths]
RS.MoveNext
For i = 1 To i - 1
strPDFs(i) = RS![paths]
bSuccess = MergePDFs(strPDFs, strNPDF)
Next i
If bSuccess = False Then MsgBox "Failed to combine all PDFs", vbCritical, "Failed to Merge PDFs"
DoCmd.SetWarnings False
DoCmd.RunSQL "delete from scantemp" 'delete all paths from table scantemp after converted it to pdf
DoCmd.SetWarnings True
RS.Close
Set RS = Nothing`enter code here`
public Function MergePDFs(arrFiles() As String, strSaveAs As String) As Boolean
Dim objCAcroPDDocDestination As Acrobat.CAcroPDDoc
Dim objCAcroPDDocSource As Acrobat.CAcroPDDoc
Dim i As Integer
Dim iFailed As Integer
On Error GoTo NoAcrobat:
'Initialize the Acrobat objects
Set objCAcroPDDocDestination = CreateObject("AcroExch.PDDoc")
Set objCAcroPDDocSource = CreateObject("AcroExch.PDDoc")
'Open Destination, all other documents will be added to this and saved with
'a new filename
objCAcroPDDocDestination.Open (arrFiles(LBound(arrFiles))) 'open the first file
'Open each subsequent PDF that you want to add to the original
'Open the source document that will be added to the destination
For i = LBound(arrFiles) + 1 To UBound(arrFiles)
objCAcroPDDocSource.Open (arrFiles(i))
If objCAcroPDDocDestination.InsertPages(objCAcroPDDocDestination.GetNumPages - 1, objCAcroPDDocSource, 0, objCAcroPDDocSource.GetNumPages, 0) Then
MergePDFs = True
Else
'failed to merge one of the PDFs
iFailed = iFailed + 1
End If
objCAcroPDDocSource.Close
Next i
objCAcroPDDocDestination.save 1, strSaveAs 'Save it as a new name
objCAcroPDDocDestination.Close
Set objCAcroPDDocSource = Nothing
Set objCAcroPDDocDestination = Nothing
NoAcrobat:
If iFailed <> 0 Then
MergePDFs = False
End If
On Error GoTo 0
End Function
This uses a list of PDF or PS files to create one PDF. Sorry it's in VB.net and I don't really have time to convert. But it illustrates the concept if you can wade through it. Basically you write the options and file names to a text file then use that file as an argument to Ghostscript.
Private Shared Sub ConvertToPDF(ByVal PSPathFileList As List(Of String), _
ByVal PDFPathName As String, _
ByVal WaitForExit As Boolean, ByVal DeletePS As Boolean)
'check that all files exist
PSPathFileList.ForEach(AddressOf CheckFiles)
'check old pdf file
If IO.File.Exists(PDFPathName) Then
Throw New ApplicationException( _
"PDF cannot be created. File already exists: " & PDFPathName)
End If
'convert engine
Dim myProcInfo As New ProcessStartInfo
myProcInfo.FileName = DanBSolutionsLocation & "Misc\GhostScript\GSWIN32C.EXE"
Debug.Print(myProcInfo.FileName)
'write file names to text file as the list can be very long
Dim tempPath As String = IO.Path.GetDirectoryName(PSPathFileList.Item(0))
Dim fiName2 As String = tempPath & IO.Path.GetFileNameWithoutExtension(PDFPathName) & ".txt"
Dim ft As New StreamWriter(fiName2)
ft.WriteLine("-sDEVICE=pdfwrite -q -dSAFER -dNOPAUSE -sOUTPUTFILE=""" & PDFPathName & """ -dBATCH ")
For i As Long = 0 To PSPathFileList.Count - 1
ft.WriteLine(Chr(34) & PSPathFileList.Item(i) & Chr(34))
Next
ft.Close()
'set args to text file
myProcInfo.Arguments = """#" & fiName2 & """"
'set up for output and errors
myProcInfo.UseShellExecute = False
myProcInfo.RedirectStandardOutput = True
myProcInfo.RedirectStandardError = True
Debug.Print(myProcInfo.Arguments)
'do the conversion
Dim myProc As Process = Process.Start(myProcInfo)
Debug.Print(myProc.StandardOutput.ReadToEnd)
Debug.Print(myProc.StandardError.ReadToEnd)
If WaitForExit Then
'wait for finish; (no more than 60 seconds)
myProc.WaitForExit(60000)
'delete PS
If DeletePS Then
PSPathFileList.ForEach(AddressOf DeleteFiles)
End If
End If
End Sub
Here's VBA code for a single PS to PDF. So between the VB.net above and this below hopefully you can salvage something useful.
Private Sub printToPdfDemo()
'verify printer setup
'be sure to install the PsPrinterInstall module
Call PSPrinterSetup
Dim svPsFileName As String
Dim svPDFName As String
'define names
svPsFileName = "C:\Temp\Input 1.ps"
svPDFName = "C:\Temp\Output 1.PDF"
'save current printer
Dim PrinterInUse As String
PrinterInUse = Application.ActivePrinter
'print to PS
'If Fso.FileExists(svPsFileName) Then Call Fso.DeleteFile(svPsFileName)
Worksheets(1).PrintOut ActivePrinter:=PSPrinterName, PrintToFile:=True, _
PrToFileName:=svPsFileName
'revert to saved printer name
Application.ActivePrinter = PrinterInUse
'convert
Call ConvertToPDF(svPsFileName, svPDFName)
End Sub
Sub ConvertToPDF(ByVal svPsFileName As String, ByVal svPDFName As String)
Dim fso As New FileSystemObject
'Dim Fso: Set Fso = CreateObject("Scripting.FileSystemObject")
Dim folGS As Folder
Dim lcCmd As String
'check inputs
If svPsFileName = "" Or svPDFName = "" Then
Call MsgBox("PS file name or PDF file name is blank in ""ConvertToPDF"" macro", vbExclamation, "Error! Missing Inputs")
Exit Sub
End If
'check file
If Not fso.FileExists(svPsFileName) Then
Call MsgBox(svPsFileName & " file is not found", vbExclamation, "Error! Missing File")
Exit Sub
End If
'check variable
If DanBSolutionsLocation = "" Then DanBSolutionsLocation = GetDanBSolutionsLocation
'delete old file
If fso.FileExists(svPDFName) Then Call fso.DeleteFile(svPDFName)
'get files
Set folGS = fso.GetFolder(DanBSolutionsLocation & "Misc\GhostScript\") 'S:\DanB Solutions\Misc\GhostScript\GSWIN32C.EXE
'GS command
lcCmd = folGS.ShortPath & "\GSWIN32C.EXE " & _
"-q -dNOPAUSE -I" & folGS.ShortPath & "\lib;./fonts " & _
"-sFONTPATH=./fonts -sFONTMAP=" & folGS.ShortPath & "\lib\FONTMAP.GS " & _
"-sDEVICE=pdfwrite -sOUTPUTFILE=" & """" & svPDFName & """" _
& " -dBATCH " & """" & svPsFileName & """"
'convert
Debug.Print lcCmd
Call ShellWait(lcCmd)
'delete PS
If fso.FileExists(svPDFName) Then fso.DeleteFile (svPsFileName)
End Sub
I have data from a query name "GrabInfoOfMostRecent" and I am using it as a source for Word to fill in a document with bookmarks. However, once I get to any non-text data, I get error 438 "Object doesn't support this property or method".
Specifically:
For "MRN"I have tried all variations of .Range.Text/Value/Value2 and cannot get the number MRN to fill into the appropriate Bookmark.
For "Diagnosis1", I get an Error13 "Type Mismatch" but I don't know why. It is defined as "Short Text" just as all previous text entries are.
Anyone with any help, I would be deeply appreciative.
Sub WordAutomation()
On Error GoTo HandleError
' Object variables for Automation stuff
' declare them like so during development
' you need to set a reference to the applications
'Dim objWord As New Word.Application
' declare them like this when development is complete
' references no longer necessary
Dim objWord As Object
' Object variables for database access
Dim db As DAO.Database
Dim rstPatientVisit As DAO.Recordset
Dim rsReportData As DAO.Recordset
Dim rsExclusions As DAO.Recordset
' Scalar variables
Dim strsql As String
Dim strFile As String
Dim conPath As String
Dim wdGoToBookmark As Integer
'find the folder where the database resides
Set db = CurrentDb
Set rsReportData = db.OpenRecordset("GrabInfoOfMostRecent")
strFile = db.Name
conPath = Mid(strFile, 1, Len(strFile) - Len(Dir(strFile)))
'Step through the records one at a time, creating a Word
'document for each.
'Do While Not rsReportData.EOF
'--create new word document
Set objWord = CreateObject("Word.Application")
objWord.Documents.Add conPath & "TunTemplate.dotx"
' Make both Word and the document are visible
objWord.Visible = True
objWord.Windows(1).Visible = True
'find bookmarks and insert values
With objWord.ActiveDocument.Bookmarks
.Item("RDFirst").Range.Text = rsReportData!RDFirstName
.Item("RDLast").Range.Text = rsReportData!RDLastName
.Item("PFirstName").Range.Text = rsReportData!PVFirstName
.Item("PLastName").Range.Text = rsReportData!PVLastName
.Item("MRN").Range.Value2 = rsReportData!MRN
.Item("RDAddress").Range.Text = rsReportData!RDAddress
.Item("PAddress").Range.Text = rsReportData!Address
.Item("RDCity").Range.Text = rsReportData!RDCity
.Item("RDCounty").Range.Text = rsReportData!RDCounty
.Item("PCity").Range.Text = rsReportData!City
.Item("PCounty").Range.Text = rsReportData!County
.Item("RDPostalCode").Range.Text = rsReportData!RDPostalCode
.Item("PPostalCode").Range.Text = rsReportData!PostalCode
.Item("Diagnosis1").Range.Text = rsReportData!Diagnosis1
.Item("Treatment1").Range.Text = rsReportData!Treatment1
.Item("Changes1").Range.Text = rsReportData!Changes1
.Item("Diagnosis2").Range.Text = rsReportData!Diagnosis2
.Item("Treatment2").Range.Text = rsReportData!Treatment2
.Item("Changes2").Range.Text = rsReportData!Changes2
.Item("Diagnosis3").Range.Text = rsReportData!Diagnosis3
.Item("Treatment3").Range.Text = rsReportData!Treatment3
.Item("Changes3").Range.Text = rsReportData!Changes3
.Item("Diagnosis4").Range.Text = rsReportData!Diagnosis4
.Item("Treatment4").Range.Text = rsReportData!Treatment4
.Item("Changes4").Range.Text = rsReportData!Changes4
.Item("Diagnosis5").Range.Text = rsReportData!Diagnosis5
.Item("Treatment5").Range.Text = rsReportData!Treatment5
.Item("Changes5").Range.Text = rsReportData!Changes5
.Item("Weight").Range.Text = rsReportData!Weight
.Item("Height").Range.Text = rsReportData!Height
.Item("BMICalc").Range.Text = rsReportData!BMICalc
.Item("Waist").Range.Text = rsReportData!Waist
.Item("BP").Range.Text = rsReportData!BP
.Item("RAcuity").Range.Text = rsReportData!REyeAcuity
.Item("LAcuity").Range.Text = rsReportData!LEyeAcuity
.Item("RRetina").Range.Text = rsReportData!RLensRetina
.Item("LRetina").Range.Text = rsReportData!LLensRetina
.Item("HbA1c").Range.Text = rsReportData!HbA1C
.Item("Creatinine").Range.Text = rsReportData!Creatinine
.Item("TChol").Range.Text = rsReportData!TChol
.Item("UrineACR").Range.Text = rsReportData!UrineACR
.Item("LDL").Range.Text = rsReportData!LDL
.Item("TSH").Range.Text = rsReportData!TSH
.Item("HDL").Range.Text = rsReportData!HDL
.Item("B12").Range.Text = rsReportData!B12
.Item("TG").Range.Text = rsReportData!TG
.Item("EGFR").Range.Text = rsReportData!EGFR
End With
'find and write exclusion data
strsql = "SELECT ReportID, Exclusion " & _
"FROM ExclusionData " & _
"WHERE ReportID=" & rsReportData!ReportID
Set rsExclusions = db.OpenRecordset(strsql)
Do While Not rsExclusions.EOF
With objWord.ActiveDocument.Bookmarks
.Item("exclusions").Range.Text = rsExclusions!Exclusion & vbCrLf
rsExclusions.MoveNext
End With
Loop
rsExclusions.Close
'Save the document and close Word
objWord.ActiveDocument.SaveAs (conPath & rsReportData!MRN & ".doc")
'objWord.Quit
'go to next record for processing
'rsReportData.MoveNext
'Loop
'Tell the user the process is done.
MsgBox "Done!" & vbCrLf & vbCrLf & _
"Look in this directory" & vbCrLf & conPath & vbCrLf & _
"for your documents."
ProcDone:
' clean up our object variables
Set objWord = Nothing
Set rsReportData = Nothing
Set rsExclusions = Nothing
Set db = Nothing
ExitHere:
Exit Sub
HandleError:
'display appropriate error message
Select Case Err.Number
Case 5151 'Word template not found
'Close stranded applications
MsgBox "Word template not found"
Case 5152 'Invalid file name
'Close stranded applications
objWord.ActiveDocument.Close SaveChanges:=False
objWord.Quit
MsgBox "This file or folder does not exist"
Case Else
MsgBox Err.Description, vbExclamation, _
"Error " & Err.Number
End Select
Resume ProcDone
End Sub
Simply with the desire to help you troubleshoot this; I offer the following.
Try converting the problem field into a string using:
.Item("Diagnosis1").Range.Text = CStr(rsReportData!Diagnosis1)
You may also want to display a dialog box with the contents of rsReportData!Diagnosis1:
MsgBox "rsReportData!Diagnosis1 is: " & rsReportData!Diagnosis1 _
, vbOkOnly + vbInformation
To convert null values into zero-length-strings, you can use the following:
.Item("Diagnosis1").Range.Text= IIf(IsNull(rsReportData!Diagnosis1), "", rsReportData!Diagnosis1)
i have the below script , modify from this http://www.vbforums.com/showthread.php?613400-Loop-through-folders-subfolders
Private Sub Command1_Click()
Dim fld As Folder
Dim searchString As String
Dim ResultFilePath As String
Set fso = New FileSystemObject
Set fld = fso.GetFolder("C:\Users\janedoe\Desktop\jane")
searchString = "ClaimSheet.xlsx"
ResultFilePath = RecursiveSearch(fld, searchString)
Set fld = Nothing
Set fso = Nothing
If ResultFilePath = "" Then
MsgBox ("We could not find the file " & searchString)
Else
MsgBox ("We found it, its at " & ResultFilePath)
End If
End Sub
Function RecursiveSearch(fld As Folder, search As String) As String
Dim tfold As Folder
Dim tfil As File
For Each tfold In fld.SubFolders
Debug.Print "looking in the " & tfold & " folder"
RecursiveSearch tfold, search
If RecursiveSearch = search Then
Exit Function
End If
Next
Debug.Assert InStr(tfil, search) = 0
If InStr(tfil.Name, search) Then
RecursiveSearch = tfil.Path
Exit function
End If
Next
End Function
What I would like the RecursiveSearch function to do is, search the folder for the searchString file, once found, stop searching and return the file path.
The problem is, I can't exit function without losing the value at the line
RecursiveSearch = tfil.Path
I think it does that because the function might have gone out of scope when returning the upper level .
Any help would be appreciated,
Your recursion line should be:
RecursiveSearch = RecursiveSearch(tfold, search)
This will allow each level of the recursion to pass it's result back up the chain.
Also, the following line seems to be missing from the code in your question:
For Each tfil In fld.Files
here is a code which i wanne run on background so no windowmessages. The meaning of it is that it checks a connection. If there isn't a connection it writes a error to a file. a function reads that file if there are 5 lines it should create a event-error. The problem is that the last part doesn't work correctly.
my qeustion is can somebody fix it or help me fixing it. Here is the code:
strDirectory = "Z:\text2"
strFile = "\foutmelding.txt"
strText = "De connectie is verbroken"
strWebsite = "www.helmichbeens.com"
If PingSite(strWebsite) Then WScript.Quit 'Website is pingable - no further action required
Set objFSO = CreateObject("Scripting.FileSystemObject")
RecordSingleEvent
If EventCount >= 5 Then
objFSO.DeleteFile strDirectory & strFile
Set WshShell = WScript.CreateObject("WScript.Shell")
strCommand = "eventcreate /T Error /ID 100 /L Scripts /D " & _
Chr(34) & "Test event." & Chr(34)
WshShell.Run strcommand
End if
'------------------------------------
'Record a single event in a text file
'------------------------------------
Sub RecordSingleEvent
If Not objFSO.FolderExists(strDirectory) Then objFSO.CreateFolder(strDirectory)
Set objTextFile = objFSO.OpenTextFile(strDirectory & strFile, 8, True)
objTextFile.WriteLine(Now & strText)
objTextFile.Close
End sub
'----------------
'Ping my web site
'----------------
Function PingSite( myWebsite )
Set objHTTP = CreateObject( "WinHttp.WinHttpRequest.5.1" )
objHTTP.Open "GET", "http://" & myWebsite & "/", False
objHTTP.SetRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MyApp 1.0; Windows NT 5.1)"
On Error Resume Next
objHTTP.Send
PingSite = (objHTTP.Status = 200)
On Error Goto 0
End Function
'-----------------------------------------------
'Counts the number of lines inside the text file
'-----------------------------------------------
Function EventCount()
strData = objFSO.OpenTextFile(strDirectory & strFile,ForReading).ReadAll
arrLines = Split(strData,vbCrLf)
EventCount = UBound(arrLines)
Set objFSO = Nothing
End Function
thats the code you can copy it to see it your self. i thank you for your time and intrest
Greets helmich
It doesn't work because function EventCount sets objFSO=nothing, so,
If EventCount >= 5 Then
objFSO.DeleteFile strDirectory & strFile
fails
Use the logevent method of the Shell object
If EventCount >= 5 Then
objFSO.DeleteFile strDirectory & strFile
Set WshShell = WScript.CreateObject("WScript.Shell")
Call WshShell.LogEvent(1, "Test Event")
End if
You don't need to run a separate command
Thats not the problem is this
Windows host script gives a error
Line:41
Char:2
Translation of error: the data required for this operation are not yet available
code: 80070057
source: WinHttp.WinHttpRequest
thats the problem and i do not know how to fix it
it has something to do that he can't read the lines in the txtfile and then not execute the create event command
I am trying to call a function. Inside function I am reading an xml file and changing value to one of the nodes. But its exiting from function after the line sXmlFile = OpenXMLFile("\\common_automation\common_bin\" & sXmlFileName & ".xml")
The functionality inside the function when tested separately is working fine. But how I do make the control go to the entire function without exiting. Before executing the statements in function fully for the 1st call, its taking the 2nd call to the function.
x=replace_instrument_id(strIp,"newFund")
y=replace_instrument_id(strIp,"newBlock")
z=replace_instrument_id(strIp,"newSecRef")
Function replace_instrument_id(sCusip,sXmlFileName)
WScript.Echo"sCusip:" & sCusip
WScript.Echo"sXmlFileName:" & sXmlFileName
sXmlFile = OpenXMLFile("\\common_automation\common_bin\" & sXmlFileName & ".xml")
WScript.Echo "sXmlFile" & sXmlFile
strCusip = sCusip
Dim sNS : sNS = "xmlns:xs='http://www.w3.org/2001/XMLSchema' xmlns:msdata='urn:schemas-microsoft-com:xml-msdata'"
Dim oXDoc : Set oXDoc = CreateObject( "Msxml2.DOMDocument.6.0" )
Dim sXPath
if(sXmlFileName="newSecRef") Then
sXPath = "/NewDataSet/ReturningDataSet/live_ins_id"
Else
sXPath = "/NewDataSet/ReturningDataSet/ins_id"
End If
oXDoc.setProperty "SelectionLanguage", "XPath"
oXDoc.setProperty "SelectionNamespaces", sNS
oXDoc.async = False
oXDoc.loadXml sXmlFile
If 0 = oXDoc.ParseError Then
oXDoc.selectSingleNode(sXPath).text = strCusip
oXDoc.save "\common_automation\common_bin\"& sXmlFileName &".xml"
WScript.Echo oXDoc.selectSingleNode(sXPath).text
Else
WScript.Echo oXDoc.parseError.reason
End If
End Function
Function OpenXMLFile (filename)
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile(filename, 1)
thisline = objFile.ReadAll
objFile.Close
OpenXMLFile = thisline
End Function
The output I am getting is
sCusip:02R99BET7
sXmlFileName:newFund
sCusip:02R99BET7
sXmlFileName:newBlock
sCusip:02R99BET7
sXmlFileName:newSecRef