I am making a program to do web searches. I have the code set up to search what ever you enter in an input box in 3 different search engines (Google, Bing and Yahoo) and then it will open the browser with the results pages. But what I want is for it to automatically go to the first site on the results page, then make itself visible. If this is possible, please leave the modified code to do it in Google. Here is what I have so far:
sub Loading
do while brw.busy
wscript.sleep 350
loop
end sub
query=inputbox("Please Enter What You Would Like To Search:","Multi-Engine Internet Searcher")
'down-Google
set brw=CreateObject("InternetExplorer.Application")
brw.navigate "https://www.google.ca/#q=" & (query)
brw.toolbar=false
brw.statusbar=true
brw.height=650
brw.width=950
brw.left=0
brw.top=0
brw.resizable=true
Call Loading
brw.visible=true
'up-google
'down-bing
set brw=CreateObject("InternetExplorer.Application")
brw.navigate "http://www.bing.com/search?q=" & (query)
brw.toolbar=false
brw.statusbar=true
brw.height=650
brw.width=950
brw.left=0
brw.top=0
brw.resizable=true
Call Loading
brw.visible=true
'up-bing
'down-yahoo
set brw=CreateObject("InternetExplorer.Application")
brw.navigate "https://search.yahoo.com/search;_ylt=A0LEVyBsK2pU4OUAtrpXNyoA;_ylc=X1MDMjc2NjY3OQRfcgMyBGZyA3NmcARncHJpZANzcVJmTGtGSVJ5V2FZOWVJcW9NVl9BBG5fcnNsdAMwBG5fc3VnZwM5BG9yaWdpbgNzZWFyY2gueWFob28uY29tBHBvcwMwBHBxc3RyAwRwcXN0cmwDBHFzdHJsAzMEcXVlcnkDVFlVBHRfc3RtcAMxNDE2MjQ0MDA3?p=" & (query)
brw.toolbar=false
brw.statusbar=true
brw.height=650
brw.width=950
brw.left=0
brw.top=0
brw.resizable=true
Call Loading
brw.visible=true
'up-yahoo
I made some changes on your code. and it will work
query=inputbox("Please Enter What You Would Like To Search:","Multi-Engine Internet Searcher")
'quit if cancel
if query = "" then wscript.quit 1
google(query)
yahoo(query)
bing(query)
'---------wait---------
sub Loading(brw)
do while brw.busy
wscript.sleep 350
loop
end sub
'---------wait---------
'---------SetAttributes---------
sub brwAtributes(brw)
brw.toolbar=false
brw.statusbar=true
brw.height=450
brw.width=650
brw.left=0
brw.top=0
brw.resizable=true
end sub
'---------SetAttributes---------
'---------view on browser---------
sub visibleBrowser(brw)
brwAtributes(brw)
Call Loading(brw)
Set results = brw.document.all.tags("h3")(0).all.tags("a")(0)
brw.Navigate results
Call Loading(brw)
brw.visible=true
end sub
'---------Google---------
sub google(query)
set brw=CreateObject("InternetExplorer.Application")
brw.Navigate "http://www.google.com/search?q=" & (query)
visibleBrowser(brw)
end sub
'---------bing---------
sub bing(query)
set brw=CreateObject("InternetExplorer.Application")
brw.Navigate "http://www.bing.co.jp/search?q=" & (query)
visibleBrowser(brw)
end sub
'---------yahoo---------
sub yahoo(query)
set brw=CreateObject("InternetExplorer.Application")
brw.navigate "https://search.yahoo.com/search;_ylt=A0LEVyBsK2pU4OUAtrpXNyoA;_ylc=X1MDMjc2NjY3OQRfcgMyBGZyA3NmcARncHJpZANzcVJmTGtGSVJ5V2FZOWVJcW9NVl9BBG5fcnNsdAMwBG5fc3VnZwM5BG9yaWdpbgNzZWFyY2gueWFob28uY29tBHBvcwMwBHBxc3RyAwRwcXN0cmwDBHFzdHJsAzMEcXVlcnkDVFlVBHRfc3RtcAMxNDE2MjQ0MDA3?p=" & (query)
visibleBrowser(brw)
end sub
Related
I'm trying to write a script that will allow me to load pictures contained in my workbook into my userform dynamically in an attempt to make the workbook completely portable. I've come up with the following that seems to work but there is one line which I don't understand why it doesn't work without. If I remove the line .ChartArea.Select the image won't load. However, If I leave it in it works fine. Ideally I'd like to remove it so I can avoid using a pointless Select. Can anyone explain?
Option Explicit
Private Sub UserForm_Initialize()
Me.Picture = LoadPicture(Filename:=ExportMyPicture(Sheet1.Pictures(1)))
Me.PictureSizeMode = fmPictureSizeModeZoom
End Sub
Private Function ExportMyPicture(pic As Picture) As String
Dim fName As String
fName = Environ("Temp") & "/" & pic.Name & ".bmp"
With pic.Parent.ChartObjects.Add(50, 40, pic.ShapeRange.Width, pic.ShapeRange.Height)
.Border.LineStyle = 0
pic.Copy
With .Chart
' Removing the following line stops the picture from loading
.ChartArea.Select
.Paste
If .Export(Filename:=fName, filtername:="bmp") Then
ExportMyPicture = fName
End If
End With
.Delete
End With
End Function
Demo:
Using this png:
url: SO converts it to a jpg
http://pngimg.com/uploads/cat/cat_PNG50497.png
Picture by Mikku
It has all looks of a timing issue, which could be a bug in how the OLE object is implementing its .Copy method; the .Select call gives it the kick it needs to get back on track.
Comments are there to say why we do things. This is one of these cases where commenting is simply the best possible thing to do... your comment isn't bad at all - it explains why, not what - and that is exactly what we want comments to say.
' Removing the following line stops the picture from loading
.ChartArea.Select
Some alternatives:
.ChartArea.Select ' Picture.Copy timing issue; this prevents subsequent .Paste from being no-op.
.ChartArea.Select ' HERE BE DRAGONS! Remove this instruction and you'll break the .Paste!
It looks like it may be a timing issue. If you pause the macro for a few seconds after copying the picture to the clipboard, it creates a file with the image and loads it successfully. However, .ChartArea.Select seems to be a good workaround. In any case, if you want to try pausing the macro, here's an example...
Option Explicit
Private Sub UserForm_Initialize()
Me.Picture = LoadPicture(Filename:=ExportMyPicture(Sheet1.Pictures(1)))
Me.PictureSizeMode = fmPictureSizeModeZoom
End Sub
Private Function ExportMyPicture(pic As Picture) As String
Dim fName As String
fName = Environ("Temp") & "/" & pic.Name & ".bmp"
With pic.Parent.ChartObjects.Add(50, 40, pic.ShapeRange.Width, pic.ShapeRange.Height)
.Border.LineStyle = 0
pic.Copy
PauseMacro
With .Chart
.Paste
If .Export(Filename:=fName, filtername:="bmp") Then
ExportMyPicture = fName
End If
End With
.Delete
End With
End Function
Private Sub PauseMacro()
Dim StartTime As Single
StartTime = Timer
Do Until Timer > StartTime + 3 'seconds delay
DoEvents
Loop
End Sub
Note that a 1 second delay seems to work as well, but maybe best to keep it at a 3 second delay just in case.
I have to pull data from SAP. This error happens randomly:
Method 'Text' of object 'ISapCTextField' failed
I searched but none of the solutions work. Error handling by trying multiple times also didn't work. Instead of trying more methods, I avoided the .Text method altogether.
Example of line causing the error:
session.findById("wnd[0]/usr/ctxtMATNR-LOW").text = "500000000"
To avoid using the .text method, I used SendKeys to achieve the same thing. Basically making the SAP window as active window and selecting the desired field in SAP GUI by using set focus, and then using Ctrl+V via sendkeys to paste the text from a range to the field. Below is the code:
'Declaration
Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Declare Function SetForegroundWindow Lib "user32" ( _
ByVal HWnd As Long) As Long
'Finds SAP Window.
Public Sub ActivateSAPWindow()
Dim HWnd As Long
'SAP window Name can be found on the status bar of the Portal.
'Note: This only works in when you click on R/3 and it open a portal. It will not work if it open in the internet explorer
'To make it work for internet explorer , Simply change the name of the Window to find internet explorer or any window you wish.
HWnd = FindWindow(vbNullString, "R/3 - SAP NetWeaver Portal - Internet Explorer")
If HWnd Then
SetForegroundWindow HWnd
End If
End Sub
Public Sub SAPSafeText(ID As String, OriginCell As String)
'Location of the cell you wanna copy to the field.
Worksheets("SAP Mapping").Range(OriginCell).Copy
Call ActivateSAPWindow
Session.FindByID(ID).SetFocus
SendKeys "^v"
'Important to wait for completion before next line.
Wait (5)
End Sub
To call the function , Simply use SAP script record to get the Field ID name and parse into the SAPSafeText("ID of the Field as string", "Cell Range as string").
Example of call:
Call SAPSafeText("wnd[0]/usr/ctxtBWART-LOW", Low)
Call SAPSafeText("wnd[0]/usr/ctxtBWART-HIGH", High)
This is the brute force way but it works.
Why is the error happening?
Is there a better way to handle this?
I met the same situation too. I solve it. I think that is you use the sentence like
session.findbyid (*****).text = cells(i,j)
you should try to use
session.findbyid (*****).text = cells(i,j).value
You could try the following instead of sendkeys method:
...
Application.Wait (Now + TimeValue("0:00:01"))
session.findById("wnd[0]/usr/ctxtMATNR-LOW").text = "500000000"
...
Regards,
ScriptMan
below are snips of the code that could cause the random error. There are about 7 other Reports. Here is the MRP report example.
Public SapGuiAuto As Object
Public SAPApp As SAPFEWSELib.GuiApplication
Public SAPConnection As SAPFEWSELib.GuiConnection
Public Session As SAPFEWSELib.GuiSession
Sub InitSession()
On Error GoTo InternetAutomation
ErrorCounter = ErrorCounter + 1
Set SapGuiAuto = GetObject("SAPGUI")
If Not IsObject(SapGuiAuto) Then
Exit Sub
End If
Set SAPApp = SapGuiAuto.GetScriptingEngine()
If Not IsObject(SAPApp) Then
Exit Sub
End If
Set SAPConnection = SAPApp.Connections(0)
If Not IsObject(SAPConnection) Then
Exit Sub
End If
Set Session = SAPConnection.Sessions(0)
If Not IsObject(Session) Then
Exit Sub
End If
Exit Sub
InternetAutomation:
.........
End sub
sub MRP()
Call InitSession
Call TCodeBox("/n/DS1/APO_C_")
Call PlantCode_MRP("A11")
Call Material_MRP("E3")
Call SetPath_MRP
Call Execute
Call MRPReportProcess
End Sub
Sub PlantCode_MRP(Cell As String)
session.findById("wnd[0]/usr/ctxtS_WERKS-LOW").Text = Range(Cell)
session.findById("wnd[0]/usr/btn%_S_WERKS_%_APP_%-VALU_PUSH").press
Call SAPMultiSelect(Cell)
End Sub
Sub Material_MRP(Cell As String)
Worksheets("MB52 Total").Activate
session.findById("wnd[0]/usr/btn%_S_MATNR_%_APP_%-VALU_PUSH").press
Call SAPMultiSelect(Cell)
End Sub
Sub SetPath_MRP()
session.findById("wnd[0]/usr/ctxtP_PATH").Text = Desktop
session.findById("wnd[0]/usr/txtP_NAME").Text = MRPFileName
End Sub
Sub TCodeBox(TCode As String)
session.findById("wnd[0]/tbar[0]/okcd").Text = TCode
On Error GoTo TCodeErrorHandler
session.findById("wnd[0]").sendVKey 0
TCodeErrorHandler:
session.findById("wnd[0]/tbar[0]/btn[15]").press
session.findById("wnd[0]/tbar[0]/okcd").Text = TCode
session.findById("wnd[0]").sendVKey 0
Resume Next
Exit Sub 'Enter
End Sub
Sub Execute()
session.findById("wnd[0]/tbar[1]/btn[8]").press
End Sub
Regards,Jacob.
Sometimes I could solve similar errors by restarting the transaction.
for example:
Sub PlantCode_MRP(Cell As String)
on error resume next
session.findById("wnd[0]/usr/ctxtS_WERKS-LOW").Text = Range(Cell)
if err.number <> 0 then
Call TCodeBox("/n/DS1/APO_C_")
session.findById("wnd[0]/usr/ctxtS_WERKS-LOW").Text = Range(Cell)
end if
on error goto 0
'On Error GoTo InternetAutomation
session.findById("wnd[0]/usr/btn%_S_WERKS_%_APP_%-VALU_PUSH").press
Call SAPMultiSelect(Cell)
End Sub
Regards,
ScriptMan
I am new to MS Publisher 2010, and I am trying to add a "dynamic" reference to a specific page. Ideally, the visualized text should be something like:
...see the example on page XXX
I would like to make the XXX part visualize the page number of the page I am referring to. I saw that you can place bookmarks in the document, and create hyperlinks to those bookmarks, but so far I could not manage to visualize the page number tied to a bookmark.
To make another example, I would like the equivalent of this Latex expression:
...see the example on page~\pageref{reference-to-XXX}
Would it be possible to obtain this effect in Publisher 2010, maybe using a VB script? Thank you for your help!
http://answers.microsoft.com/en-us/office/forum/office_2007-office_other/how-do-i-hyperlink-specific-text-within-the-same/598cfd98-6217-4eac-9ac9-969477c46401?auth=1
"This is fairly easy with Pub 2007. Just Insert > bookmark and drag that icon to where you want the link to go. Then select the text >insert hyperlink > place in this document and choose the bookmark that you just created. The only time I have had problems is if the page is not long enough below the bookmark...and there are workarounds.
http://office.microsoft.com/en-us/publisher-help/create-a-hyperlink-HP010203490.aspx
DavidF"
Let me know if this helps or if you for some reason need to do it in VBA
Edit:
It is fairly easy to write a macro to refresh links to pages, but links to bookmarks seem to be poorly supported by the object model, unless I've overlooked something. My solution consists of two parts.
First of all, links that should be refreshed are recognised by their display text starting with "page " (LIKE "page *"). The refresh macro simply recognizes those links and changes their display text to page X. However, this doesn't work for links to bookmarks, which in the object model seem to behave like links to pages, except the pageID they refer to does not exist. I spent quite a while trying to figure out what the relationship might be between this non-existent hyperlink and the bookmark, but to no avail. Instead I've created a workaround in which you manually link the hyperlink and the bookmark with a tag object (creating a tag for the bookmark with the value of the non-existent page ID of the hyperlink).
Instructions for normal links to pages
Create a hyperlink to a page. The text of it must begin with ”page ”
(otherwise RefreshReferenceLinks must be edited)
Run C_RefreshReferenceLinks to refresh to check that it worked
Instructions for links to bookmarks (tagging workaround)
Create a bookmark (Insert -> Bookmark)
Create a hyperlink to the Bookmark
Select the hyperlink and run A_GetPageIdOfHyperlink
Select the bookmark and run B_TagBookmarkWithPageId
Run C_RefreshReferenceLinks to refresh to check that it worked
You can download my example project containing example content, instructions, and the macros below here: http://www.filedropper.com/showdownload.php/pageandbookmarklinks (it will probably give you a security warning because it contains macros)
Full source
Public Const tagName = "BookmarkPageId"
Sub A_GetPageIdOfHyperlink()
Dim oHyperlink As Hyperlink
Set oHyperlink = ActiveDocument.Selection.TextRange.Hyperlinks(1)
CopyText oHyperlink.pageId
MsgBox oHyperlink.pageId & " copied to clipboard as text"
End Sub
Sub B_TagBookmarkWithPageId()
Dim oShape As Shape
Set oShape = ActiveDocument.Selection.ShapeRange(1)
If IsBookmark(oShape) Then
If TagExists(oShape.Tags, tagName) Then
oShape.Tags(tagName).Delete
End If
Dim txt As String
txt = Trim(GetClipBoardText())
Debug.Print "Ssdsd:" & txt
Dim newTag As Tag
Set newTag = oShape.Tags.Add(tagName, txt)
MsgBox "Tagged as " & tagName & " = '" & txt & "'"
Else
MsgBox "Not a bookmark"
End If
End Sub
Sub C_RefreshReferenceLinks()
Dim oPage As Page
Dim oShape As Shape
For Each oPage In ActiveDocument.Pages
For Each oShape In oPage.Shapes
RefreshInShape oShape
Next oShape
Next oPage
For Each oPage In ActiveDocument.MasterPages
For Each oShape In oPage.Shapes
RefreshInShape oShape
Next oShape
Next oPage
For Each oShape In ActiveDocument.ScratchArea.Shapes
RefreshInShape oShape
Next oShape
End Sub
Function RefreshInShape(oShape As Shape)
Dim cHyperlinks As Hyperlinks
Dim oHyperlink As Hyperlink
If oShape.HasTextFrame = False Then Exit Function
Set cHyperlinks = oShape.TextFrame.TextRange.Hyperlinks
For i = 1 To cHyperlinks.Count
Set oHyperlink = cHyperlinks(i)
If oHyperlink.TargetType = pbHlinkTargetTypePageID Then
If oHyperlink.TextToDisplay Like "page *" Then
oHyperlink.TextToDisplay = "page " & GetPageNumberByPageId(oHyperlink.pageId)
End If
End If
Next i
End Function
Function GetPageNumberByPageId(pageId)
Dim oPage As Page
Dim oShape As Shape
Dim oTag As Tag
For Each oPage In ActiveDocument.Pages
If CLng(oPage.pageId) = CLng(pageId) Then
GetPageNumberByPageId = oPage.PageNumber
Exit Function
End If
Next oPage
For Each oPage In ActiveDocument.Pages
For Each oShape In oPage.Shapes
If TagExists(oShape.Tags, tagName) Then
Set oTag = oShape.Tags(tagName)
If CStr(oTag.Value) = CStr(pageId) Then
GetPageNumberByPageId = oPage.PageNumber
Exit Function
End If
End If
Next oShape
Next oPage
GetPageNumberByPageId = "[ERROR]"
End Function
Function IsBookmark(oShape As Shape)
IsBookmark = False
If oShape.Type = pbWebHTMLFragment And oShape.AutoShapeType = msoShapeMixed Then
IsBookmark = True
End If
End Function
Function TagExists(collection As Tags, itemName As String) As Boolean
TagExists = False
Dim oTag As Tag
For Each oTag In collection
If oTag.Name = itemName Then
TagExists = True
Exit For
End If
Next oTag
End Function
Function GetParentOfType(obj As Object, sTypeName As String)
Do Until TypeName(GetParentOfType) = "Page"
Set GetParentOfType = obj.Parent
Loop
End Function
Sub CopyText(Text As String)
'VBA Macro using late binding to copy text to clipboard.
'By Justin Kay, 8/15/2014
'Thanks to http://akihitoyamashiro.com/en/VBA/LateBindingDataObject.htm
Set MSForms_DataObject = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
MSForms_DataObject.SetText Text
MSForms_DataObject.PutInClipboard
Set MSForms_DataObject = Nothing
End Sub
Function GetClipBoardText() As String
Set DataObj = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
On Error GoTo Whoa
'~~> Get data from the clipboard.
DataObj.GetFromClipboard
'~~> Get clipboard contents
GetClipBoardText = DataObj.GetText(1)
Exit Function
Whoa:
GetClipBoardText = ""
End Function
I have an Excel application I've developed and now want to store all of the data in an Access file (rather than an Excel sheet). I'm able to read data in and write data out, my issue has to do with handling concurrent users. There's around 150-200 square images that when clicked open up a UserForm that is loaded with data. Users are able to go in and edit any of that data so I want to make sure that two users are not editing a record at the same time. Given the size of it I do not want to lock down the entire file, just the one record. Everything I've read so far indicates that the record only locks while in .Edit, however I want to lock it as soon as the user opens the UserForm, then apply any edits they made and unlock it.
Here's where I'm at now with the code, the first three sections are where the main focus is with this:
Sub OpenDAO()
Set Db = DBEngine.Workspaces(0).OpenDatabase(Path, ReadOnly:=False)
strSQL = "SELECT * FROM AccessDB1 WHERE ID = 5" '& Cells(1, Rng.Column)
Set Rs = Db.OpenRecordset(strSQL)
End Sub
'==========================================================================
Sub CloseDAO()
On Error Resume Next
Rs.Close
Set dbC = Nothing
Set Rs = Nothing
Set Db = Nothing
End Sub
'==========================================================================
Function ADO_update(Target As Range)
Set ws = Sheets("Sheet1")
Set dbC = DBEngine.Workspaces(0).Databases(0)
'if no change exit function
If Target.Value = oldValue Then GoTo 0
On Error GoTo trans_Err
'begin the transaction
DBEngine.BeginTrans
dbC.Execute "UPDATE AccessDB1 SET Field1 = 5 WHERE ID= 5"
DBEngine.CommitTrans dbForceOSFlush
Exit Function
trans_Err:
'roll back the transaction
Workspaces(0).Rollback
0
End Function
'==========================================================================
Function MakeSQLText(data As Variant)
If (IsNumeric(data)) Then
MakeSQLText = data
Else
MakeSQLText = "'" & Replace(data, "'", "''") & "'"
End If
End Function
I've written some VBA script to load a webpage then copy the entire html contents into a string, then select specific data from that string. In essence I search for a rail timetable, then copy out details for 5 journeys (departure time, interchanges, journey time & cost)
I have the above script sorted to do one search, but I now want to loop it and run approximately 300 searches. The issue I've found is that the script won't wait for the webpage to open, and therefore the string returned is empty, effectively returning nothing.
What I need to do is load an address, wait for the page to load, then continue the script. Do you have any suggestions? I've searched a lot and just haven't been able to sort, I've tried Application.Wait in a number of places and still no further ahead.
The code I'm using is below:
Sub CreateIE()
Dim tOLEobject As OLEobject
Dim NRADDRESS As String
NRADDRESS = Range("h11")
On Error Resume Next
Worksheets("Sheet1").Shapes.Range(Array("WebBrow")).Delete
Set tOLEobject = Worksheets("Sheet1").OLEObjects.Add(ClassType:="Shell.Explorer.2",Link:=False, _
DisplayAsIcon:=False, Left:=0, Top:=15, Width:=912, Height:=345)
For Each tOLEobject In Worksheets("Sheet1").OLEObjects
If tOLEobject.Name = "WebBrowser1" Then
With tOLEobject
.Left = 570
.Top = 1
.Width = 510
.Height = 400
.Name = "WebBrow"
End With
With tOLEobject.Object
.Silent = True
.MenuBar = False
.AddressBar = False
.Navigate NRADDRESS
End With
End If
Next tOLEobject
Sheets("Sheet2").Activate
Sheets("Sheet1").Activate
Call ReturnText
End Sub
NRADDRESS is a web address made up of a number of different parameters (origin, destination, date and time)
The "Call ReturnText" is the script I use to copy the website HTML into a string and extract what I want.
In that case, you might try something like this:
Set objIE = CreateObject("InternetExplorer.Application")
objIE.navigate strURL
Do While objIE.readyState <> 4 And objIE.Busy
DoEvents
Loop
which, I believe, requires a reference to Microsoft Internet Controls.
When I first started using VBA to load webpages, I also used the IE Object, but later found it creates all kinds of complications I didn't need, when all I really wanted was to download the file. Now I always use URLDownloadToFile.
A good example of it's use can be found here:
VBA - URLDownloadToFile - Data missing in downloaded file