I am trying to get a vbs script to ask for a url of a youtube video and play the audio. I have this so far
Option Explicit
Dim Msg,Question,PathSound,URL
URL = InputBox("What url would you like to play from?")
PathSound = "URL"
Question = MsgBox(Msg,VbQuestion+VbYesNo,Msg)
If Question = VbYes Then
Call Play(PathSound)
Else
Wscript.Quit()
End If
'**********************************************************
Sub Play(SoundFile)
Dim Sound
Set Sound = CreateObject("WMPlayer.OCX")
Sound.URL = SoundFile
Sound.settings.volume = 100
Sound.Controls.play
do while Sound.currentmedia.duration = 0
wscript.sleep 100
loop
wscript.sleep(int(Sound.currentmedia.duration)+1)*1000
End Sub
'**********************************************************
Try something like this :
Option Explicit
Dim Msg,Question,URL,Title
Title = "Extract or play youtube audio with Vbscript by Hackoo 2016"
Msg = "Did you want to continue with this script to play music ? or stop music and quit this script ?"
Question = MsgBox(Msg,VbQuestion+VbYesNo,Title)
If Question = VbYes Then
URL = InputBox("What url would you like to play from ?" , "Play Sound from internet",_
"https://www.youtube.com/watch?v=4Aa9GwWaRv0")
'http://www.chocradios.ch/djbuzzradio_windows.mp3.asx
If URL = "" Then Wscript.Quit()
If Instr(URL,"youtube") > 0 Then
Call Play_Youtube(URL)
Else
Call Play(URL)
End If
Else
Call Kill("iexplore.exe")
Call Kill("Wscript.exe")
Wscript.Quit()
End If
'**********************************************************
Sub Play(SoundFile)
Dim Sound
Set Sound = CreateObject("WMPlayer.OCX")
Sound.URL = SoundFile
Sound.settings.volume = 100
Sound.Controls.play
do while Sound.currentmedia.duration = 0
wscript.sleep 100
loop
wscript.sleep(int(Sound.currentmedia.duration)+1)*1000
End Sub
'**********************************************************
Sub Play_Youtube(URL)
Dim ie
Set ie = CreateObject("InternetExplorer.Application")
ie.Navigate(URL)
ie.Visible=false
DO WHILE ie.busy
LOOP
End Sub
'**********************************************************
Sub Kill(Process)
Dim Command,Ws,Execution
Set Ws = CreateObject("Wscript.Shell")
Command = "cmd /c Taskkill /F /IM "& Process &""
Execution = Ws.Run(Command,0,True)
End Sub
'***********************************************************
Related
I am trying to post some information into webpage and then return some other information after posting and clicking on Login button and this is my code
Sub Test()
Dim driver As New WebDriver
Dim x As Variant
Dim ele As SelectElement
Dim s As String
With driver
.Start "Chrome", "https://studea.emis.gov.eg"
.Wait (5000)
sBack:
.Get "/std_data_mail.aspx"
.FindElementById("ContentPlaceHolder1_TextBox3").SendKeys "30904201602611"
Set ele = .FindElementById("ContentPlaceHolder1_Dropyear").AsSelect
ele.SelectByValue 2009
Set ele = .FindElementById("ContentPlaceHolder1_Dropmonth").AsSelect
ele.SelectByIndex 4
Set ele = .FindElementById("ContentPlaceHolder1_DropDay").AsSelect
ele.SelectByValue 20
Set ele = .FindElementById("ContentPlaceHolder1_DropDownList5").AsSelect
ele.SelectByIndex 12
Set ele = .FindElementById("ContentPlaceHolder1_DropDownListsex").AsSelect
ele.SelectByIndex 1
.FindElementById("ContentPlaceHolder1_Button2").Click
.Wait (5000)
'.FindElementById("").SendKeys ""
On Error Resume Next
s = Empty
s = .FindElementByXPath("/html/body/span/h1").Text
On Error GoTo 0
If Left(s, 12) = "Server Error" Then
If MsgBox("Server Error. Would You Like To Try Again?", vbYesNo) = vbYes Then GoTo sBack Else Exit Sub
Else
'THIS PART DOESNOT RETURN ANYTHING
Debug.Print .FindElementById("ContentPlaceHolder1_txtsdname").Text
Debug.Print .FindElementById("ContentPlaceHolder1_txtsdid").Text
Debug.Print .FindElementById("ContentPlaceHolder1_txtsdschool").Text
End If
Stop
End With
Stop
End Sub
The code runs and when there's a server error, a message box appear to tell the user to try again. And when there is a response, I got no data although the page loaded on the driver.
I have commented the lines I got a problem at.
I am trying to open excel files downloded from internet and then copy the data into another excel file during vba runs with their commands.
But the command that open the excel file is executed after the ends of vba code regardless of their position.
For example, below code shows whole process of downloading and opening the excel file from a site. But at the "open_excel" function "InvokePattern.Invoke" actually occurs after the execution of all vba codes.
How do I execute this at first? Could I give some priority on that command?
Or how to wait on "InvokePattern.Invoke" until that finished?
(I try wait time or kinds of time manipulation which doesn't work)
Sub crawler_main() ' this is main function
.....
Call ieopen(ie, url_futures) 'internet explorer is opened with some url
Call click_excel(ie)
Call open_excel(ie)
Call copy_data(wbname)
.....
End Sub
Sub ieopen(ie As InternetExplorer, url As String) ' open ie
Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = True
ie.navigate url
Do Until (ie.readyState = 4 And Not ie.Busy)
DoEvents
Loop
Application.Wait (Now + TimeValue("00:00:05"))
End Sub
Sub click_excel(ie As InternetExplorer) 'download excel
Dim inquiry As Object
Set inquiry = ie.document.getElementsByClassName("btn-board btn-board-search")(0)
inquiry.Click
Do Until (ie.readyState = 4 And Not ie.Busy)
DoEvents
Loop
'Application.Wait (Now + TimeValue("00:00:05"))
Dim Buttons_Excel As Object
Dim Button As Object
Set Buttons_Excel = ie.document.getElementsByTagName("button")
For Each Button In Buttons_Excel
If Button.innerHTML = "Excel" Then
Button.FireEvent ("onclick")
Exit For
End If
Next
End Sub
Sub open_excel(ie As InternetExplorer) 'click open in dialog open/save
Dim e As IUIAutomationElement
Dim o As CUIAutomation
Set o = New CUIAutomation
Dim h As Long
h = ie.hwnd
h = FindWindowEx(h, 0, "Frame Notification Bar", vbNullString)
If h = 0 Then Exit Sub
Set e = o.ElementFromHandle(ByVal h)
Dim iCnd As IUIAutomationCondition
Set iCnd = o.CreatePropertyCondition(UIA_NamePropertyId, "열기")
Dim Button_Download As IUIAutomationElement
Set Button_Download = e.FindFirst(TreeScope_Subtree, iCnd)
Dim InvokePattern As IUIAutomationInvokePattern
Set InvokePattern = Button_Download.GetCurrentPattern(UIA_InvokePatternId)
InvokePattern.Invoke
End Sub
Sub copy_data(wbname As String) 'copy data from recently opened file.
'But here is problematic since file is open after the execution of all vba codes
For Each wb In Application.Workbooks
If wb.Name Like "dat" & "*" Then
Set wb_data = Workbooks(wb.Name)
Exit For
End If
Next wb
............
End Sub
This might be relevant: http://msdn.microsoft.com/en-us/libr...87(VS.85).aspx
Note that you can use realtime which is higher but you will have to set permissions to do so...
Code:
Sub SetPriority()
Const ABOVE_NORMAL = 32768
Const HIGH = 128
strComputer = "."
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" _
& strComputer & "\root\cimv2")
Set colProcesses = objWMIService.ExecQuery _
("Select * from Win32_Process Where Name = 'excel.exe'")
For Each objProcess In colProcesses
objProcess.SetPriority (HIGH)
Next
End Sub
I was trying go gather/scrape data from the Web using this code:
Sub GetSP()
Dim appIE As Object
Set appIE = CreateObject("internetexplorer.application")
With appIE
.Navigate "http://uk.investing.com/currencies/streaming-forex-rates-majors"
.Visible = True
End With
Do While appIE.Busy
DoEvents
Loop
RunCodeEveryX:
Set allRowOfData = appIE.document.getElementById("pair_1")
Dim myValue As String: myValue = allRowOfData.Cells(2).innerHTML
Range("A1").Value = myValue
Application.Wait Now + TimeValue("00:00:01")
GoTo RunCodeEveryX
appIE.Quit
Set appIE = Nothing
End Sub
However, when the code is running, I can't even edit the Excel because Excel seems to be busy working on getting the data. What I hope for was the code is running, I can do something out of the same sheet with the web scraping continuing.
Is there any alternative to wait now? (Which I think makes Excel busy)
Thanks!
#jeeped - I was able to gather the appropriate data using your preferred mode and successfully extract the data. I wonder if there is a good way to repeat this step infinitely (since the data is refreshing on the webpage, I'd like this to repeat as with my initial code) until I stop it while being able to edit the rest of the worksheet.
Thanks! Hope you don't mind me addressing you specifically though the question is open to everyone.
Sub GetSP()
Dim HTMLDoc As New HTMLDocument
Dim oHttp As MSXML2.xmlHTTP
On Error Resume Next
Set oHttp = New MSXML2.xmlHTTP
If Err.Number <> 0 Then
Set oHttp = CreateObject("MSXML.XMLHTTPRequest")
MsgBox "Error 0 has occured"
End If
On Error GoTo 0
If oHttp Is Nothing Then
MsgBox "Just cannot make"
Exit Sub
End If
oHttp.Open "GET", "http://uk.investing.com/currencies/streaming-forex-rates-majors", False
oHttp.send
HTMLDoc.body.innerHTML = oHttp.responseText
With HTMLDoc
PriceGetter = .getElementById("pair_1").innerText
PriceGetter2 = .getElementsByClassName("pid-1-bid")(0).innerText
Range("A1").Value = PriceGetter
Range("A2").Value = PriceGetter2
End With
End Sub
You can use a Loop instead of the Application.Wait. When you are using DoEvents inside it, the App is still responsive.
If you are on Windows, here is a Function that sleeps for a certain amount of time:
Declare Function GetTickCount Lib "kernel32.dll" () As Long
Function Sleep(milliseconds As Long)
Dim NowTick As Long
Dim EndTick As Long
EndTick = GetTickCount + (milliseconds)
Do
NowTick = GetTickCount
DoEvents
Loop Until NowTick >= EndTick
End Function
Call it like this:
Sleep 1000 'Sleeps for 1 Second
I had managed to write a short script that navigates to the link i desire but im unable to search a string "Hello World" in that webpage [please note that im not any expert in VBS and if there are any mistakes just forgive] and i dont know to the url where "Hello World" leads too.
On error resume next
Dim WshShell, objIE, ElementCol
Dim LinkHref
Dim a
LinkHref = "www.abcdef.com"
Set WshShell = WScript.CreateObject("WScript.Shell")
Set objIE = CreateObject("InternetExplorer.Application")
objIE.Visible = False
objIE.Navigate LinkHref
wshShell.AppActivate objIE
Do While objIE.Busy
wscript.sleep 6000
Loop
LinkHref = "Hello World"
For Each a In objIE.Document.GetElementsByTagName("A")
If LCase(a.GetAttribute("href")) = LCase(LinkHref) Then
a.Click
Exit For
End If
Next
objIE.Visible = True
Try something like this
For Each a In objIE.Document.GetElementsByTagName("a")
If LCase(a.href = LCase(LinkHref) Then
a.Click
Exit For
End If
Next
I have a large excel sheet with a log that consists of around 30000 entries.
The programmer before me has created a removeline.cmd file to remove all extra blank lines in a certain column for the excel file.
The code for the RemoveLine.cmd:
cls
cd\
SET vbfile=newlinetest.exe
K:
cd "IPM - CompOps\Ops Docs\avail-stats\Originals"
%vbfile%
exit
The file runs correctly but at the end it displays this error, which is essentially what I'm trying to get rid of:
Run-time error '1004';
Method '~' of object '~' failed
EDIT:
the program newlinetest.exe was written in VB6 (I have access to it on my machine).
The full source-code for newline.frm is:
VERSION 5.00
Begin VB.Form Form1
Caption = "Form1"
ClientHeight = 4500
ClientLeft = 3435
ClientTop = 3585
ClientWidth = 5175
LinkTopic = "Form1"
ScaleHeight = 4500
ScaleWidth = 5175
Begin VB.CommandButton Command1
Caption = "Excel"
Height = 495
Left = 1800
TabIndex = 0
Top = 3720
Width = 855
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub Command1_Click()
Dim oXL As Object ' Excel application
Dim oBook As Object ' Excel workbook
Dim oSheet As Object ' Excel Worksheet
Dim oChart As Object ' Excel Chart
Dim year As String
Dim i As Long
Dim MyRowNumber As Long
Dim Row As Long
Dim comment As String, newline As String
Dim curDate As String
Open "K:\IPM - CompOps\Ops Docs\avail-stats\Originals\Inputavailfile.txt" For Input As #1
Input #1, Data
Close #1
'Start Excel and create a new workbook
Set oXL = CreateObject("Excel.application")
Set oBook = oXL.Workbooks.Add
Set oSheet = oBook.Worksheets.Item(1)
oXL.Visible = True
oXL.UserControl = True
year = Format(Now, "yyyy")
curDate = Date - 3
curDate = Format(curDate, "m/d/yyyy")
Application.DisplayAlerts = False
Workbooks.Open FileName:="K:\IPM - CompOps\Ops Docs\avail-stats\Originals\" + Data
Myfile = "K:\IPM - CompOps\Ops Docs\avail-stats\Originals\" + Data
On Error GoTo Handler
vOurResult = Cells.Find(What:=curDate, LookAt:=xlWhole).Select
If (vOurResult = True) Then
MyRowNumber = ActiveCell.Row
Set ExcelLastCell = ActiveSheet.Cells.SpecialCells(xlLastCell)
'MsgBox vOurResult
Row = ExcelLastCell.Row
col = ExcelLastCell.Column
' MsgBox curDate
Cells(ActiveCell.Row, ActiveCell.Column + 6).Select
comment = ActiveCell.Text
newline = Replace(comment, Chr(10), " ")
ActiveCell.Value = newline
For i = MyRowNumber To Row - 1
comment = ""
newline = ""
Cells(ActiveCell.Row + 1, ActiveCell.Column).Select
comment = ActiveCell.Text
newline = Replace(comment, Chr(10), " ")
ActiveCell.Value = newline
Next i
'MsgBox curDate
ActiveWorkbook.SaveAs FileName:=Myfile, FileFormat:=xlNormal
End If
oXL.Quit
Handler:
oXL.Quit
End Sub
Private Sub Form_Load()
Command1_Click
End
End Sub
Private Sub Label1_Click()
End Sub
You have these lines towards the end of the Sub:
oXL.Quit
Handler:
oXL.Quit
The second Quit call fails, generating the error. You need to exit the procedure just before the Handler (which will only be called in the event of an error):
oXL.Quit
Exit Sub
Handler:
oXL.Quit
That's because the code 'falls through' to your line-label called Handler.
Thus when your Handler then tries to call Method 'Quit' of object 'oXL', that will fail because oXL has already quit.
The obvious solution is to Exit Sub before it reaches the Handler.
The general layout for a Sub (from MSDN):
Sub InitializeMatrix(Var1, Var2, Var3, Var4)
On Error GoTo ErrorHandler
. . .
Exit Sub
ErrorHandler:
. . .
Resume Next
End Sub
Hope this helps!
EDIT:
Seems the original question that I was helping the asker with via chat was deleted and later re-posted (I assume to get some fresh page-views).
Although Andy G has already answered this re-post, I figured not to let my answer go to waste and posted it anyway, hoping the explanation and reference might help future readers.