I am completely new to VB6, and I need to print images on a page. I am having print options in 2 different places on the same page.
What I have tried:
I tried to write a common method to perform the print operation:
Private Sub mnuPrintImage_Click()
On Error GoTo mnuPrintImage_Click_Error
gobjRLItemImage.PrintImage imgItem
Exit Sub
mnuPrintImage_Click_Error:
ShowError "frmItem.mnuPrintImage_Click"
End Sub
I tried to use Me.PrintForm, but when I do so, I am getting a popup to save the complete page. However, I need to print the image directly and don't want to save it locally.
Public Sub PrintImage()
On Error GoTo PrintImageError
me.printform
Exit Sub
PrintImageError:
Select Case Err.Number
Case 440:
' Cancel button pressed; do nothing
Case Else
Err.Raise Err.Number
End Select
End Sub
Related
I'm making some changes to a program that was written by another developer, which uses an SSDB Grid.
I'm writing the code for the BeforeUpdate method.
On Error GoTo BeforeUpdate_Err
Dim ans%
ans% = MsgBox("These changes will be committed to the database. These changes cannot be undone. " & _
"Would you like to continue?", vbYesNo, "Confirm Changes")
If ans% = 7 Then
Grd_Collection.CancelUpdate
End If
Exit Sub
BeforeUpdate_Err:
MsgBox (Err.Description)
The only other code for the grid is the InitColumnProps method.
However, after hitting the Exit Sub line, I get an error message "Update Error".
I've searched the code for this being hard-coded but it isn't, so it's coming from the grid.
What is causing the error and how do I fix it?
Doesn't the BeforeUpdate method pass in an integer? (Cancel As Integer) or something?
Therefore, you should just be able to change your code (and tidy it up) to this:
On Error GoTo BeforeUpdate_Err
If MsgBox("These changes will be committed to the database. These changes cannot be undone. " & _
"Would you like to continue?", vbYesNo, "Confirm Changes") = vbNo Then
Cancel = 1
End If
Exit Sub
BeforeUpdate_Err:
MsgBox (Err.Description)
I've got a simple program than scans data into a spreadsheet along with a timestamp, then you can either update the data by saving, or quit and exit and save.
The only issue I've been stuck on for a day or so is to work around the error handling of the case of the spreadsheet being already open. Id like to have something like this;
if file is open THEn msgbox("File is open, close file and start again")
WScript.Quit
Option Explicit
DIM oFs: Set oFs = CreateObject("Scripting.FileSystemObject")
DIM objExcel, strExcelPath, objSheet
DIM ib
DIM msg1
DIM msg2
strExcelPath = "c:\temp\Example.xls"
Set objExcel = CreateObject("Excel.Application")
objExcel.WorkBooks.Open strExcelPath
Set objSheet = objExcel.ActiveWorkbook.Worksheets(1)
DO
ib=inputbox("SCAN NAME, SCAN LOTS"&vbCrLf&"TO UPDATE,SCAN ""UPDATE."""&vbCrLf&"TO EXIT, SCAN ""QUIT.""","Picklot Passout Database")
IF ib="" THEN
msg1=MsgBox("You must scan either a NAME or LOT NUMBER."&vbCrLf&"If you want to exit, scan QUIT."&vbCrLf&"Click OK to continue.",vbokonly,"Cannot Insert Blank Data")
ELSEIF ib= "QUIT" OR ib= "quit" THEN
objExcel.ActiveWorkbook.Save
objExcel.ActiveWorkbook.Close
objExcel.Application.Quit
set objExcel = Nothing
Set oFs = Nothing
ELSEIF ib="update" OR ib="UPDATE" THEN
objExcel.ActiveWorkbook.Save
msg2=MsgBox("Update Complete.",vbokonly,"Database Updated")
ELSE
objSheet.Range("A2").EntireRow.Insert
objSheet.Cells(2, 1).Value = ib
objSheet.Cells(2, 2).Value=(now)
END IF
LOOP WHILE NOT ib="quit" AND NOT ib="QUIT"
This may help point you in the right direction. Sorry for the rushed, lowercase syntax and unconventional indentations (do not follow my bad practice - keep yours! :D), I wrote it in notepad you see - but it has been tested successfully.
Anyhow, with reference to your code, I have restructured it in a bad manner, familiar to me, adding the functionality you specify. Essentially the task manager application list is checked for a running instance of the "example" Excel file (depending on what version of excel you're using the syntax will differ).
If found it will make it the active window (thereby preventing a read only duplicate instance initiating). If no instance is found it will open "example.xlsx", in this case using a relative path to the script itself. A subroutine is then called to do the business with the cells...
I have written it in such a way to try keep your specs as well as maintain the "OK" and "Cancel" buttons explicitly functional. Please feel free to tinker with this, you may need to address the path and instr lines differently. I hope it helps! All the best.
path=createobject("scripting.filesystemobject").getparentfoldername(wscript.scriptfullname)
excelpath=path&"\example.xlsx"
set objword=createobject("word.application")
set coltasks=objword.tasks
i=0
for each objtask in coltasks
name=lcase(objtask.name)
if instr(name, "microsoft excel - example") then
i=1
end if
next
if i=1 then
wscript.echo "An active instance of ""example.xlsx"" has been found"
set objexcel=getobject(excelpath)
call UPDATER
else
set objexcel=createobject("excel.application")
objexcel.workbooks.open(excelpath)
set objsheet=objexcel.activeworkbook.worksheets(1)
objexcel.visible=true
call UPDATER
end if
sub UPDATER
do
data=inputbox("Please enter data" &vbcrlf&vbcrlf& "To save data & continue, type ""update""" &vbcrlf& "To save data & exit, type ""quit""","Excel DB Updater")
if isempty(data) then
objexcel.activeworkbook.close
objexcel.application.quit
wscript.quit()
elseif lcase(data)="quit" then
objexcel.activeworkbook.save
objexcel.activeworkbook.close
objexcel.application.quit
quit=msgbox("DB Updating complete",vbokonly,"Excel DB Updater")
wscript.quit
elseif lcase(data)="update" then
objexcel.activeworkbook.save
update=msgbox("Data save complete, press OK to continue",vbokonly,"Excel DB Updater")
elseif len(data)<>0 then
objsheet.range("A1").entirerow.insert
objsheet.cells(1, 1).value=data
objsheet.cells(1, 2).value=(now)
add=msgbox("Data added, press OK to continue",vbokonly,"Excel DB Updater")
end if
loop while len(data)>=0 and not lcase(data)="quit"
end sub
When I tried to read the "Left property" of a control, it is giving me the error,
"Left cannot be read at run time"
Here is my code,
for each ctrl in me.controls
if ctrl.left > 2490 then
'app logic
end if
next
what is wrong in this code. It worked without error in another computer.
Can anyone tell me what is wrong
You may have a design-time only placeable control on your form like a timer for example, that does not have a run-time left property. You could check the type of control to ensure only TextBox, Label, Button, etc. get checked, or just use an on error resume next:
Check for object type using TypeOf:
Dim ctrl As Control
For Each ctrl In Me.Controls
If TypeOf ctrl Is Timer Then
Else
If ctrl.Left > 2490 Then
'app logic
End If
End If
Next
Check for object type using TypeName:
Dim ctrl As Control
For Each ctrl In Me.Controls
If TypeName(ctrl) = "Timer" Then
Else
If ctrl.Left > 2490 Then
'app logic
End If
End If
Next
Using On Error Resume Next:
Dim ctrl As Control
On Error Resume Next
for each ctrl in me.controls
if ctrl.left > 2490 then
'app logic
end if
Next
If you use the last method, it's important to handle errors inline reraising any unexpected error. Otherwise if you get any different error than the one you're expecting you could have a very tough time finding it. So:
Dim ctrl As Control
On Error Resume Next
for each ctrl in me.controls
if ctrl.left > 2490 then
Select Case Err.Number
Case 0 'No Error, ignore
Case 393 'The error you want to ignore
Err.Clear 'Reset for next iteration
Case Else
On Error Goto 0
Err.Raise Err.Number 'Reraise any unexpected errors
End Select
'app logic
end if
Next
On Error Goto 0
It would be helpful to me, if anyone can provide me an idea to below problem.
I’ve a scenario in which my script will be executing each test step line by line and for each test step it will report pass and fail result in html result page.
If test step result is pass, it will proceed to next test step and further on.
Similarly for failed cases it proceeds to next test step and executes it.
Is it possible to stop the script when it fails?
Below is the sample outline script
Call webEdit_check (“google”,”google”,”nametxtbox”,”xxxx”)
Call Link_check (strbrowser,strpage,strlink)
Call WebButton_check (strbrowser,strpage,strWebbutton)
So according to above script, it will call webEdit function and check whether object is displayed and visible and will enter value in webEdit textbox and result will be written as pass in html result, if all conditions are satisfied.
After completing above function, now it will call link function and will initiate execution .Here also it will check if object is displayed .If success, it will go to next step. Let us assume link is not visible, here second step in this function fails and so result is written as fail and execution of third function begins( call WebButton_check). What I need is entire execution should be stopped as previous test step is failed. Is there any function to run at back end, to stop the execution? When test step fails? Is there any solution to my problem?
(Please note I’ve multiple scenarios so “Exit Test/Exit function” is not applicable.)
Functions are
webEdit_check
Function webEdit_check(strbrowser,strpage,strwebEdit,strvalue)
Testobject=Browser(strbrowser).Page(strpage).WebEdit(strlink)
If Testobject.exist(10) Then
blnvisible= testobject.getRoproperty(visible)
If blnvisible =True Then
Testobject.set strvalue
Environment.value(result)=pass
‘It will write result to html page
Call html (“test step is success”,Environment(result))
Else
Environment.value(result)=fail
Call html (“test step is fail”,Environment(result))
End If
Else
Environment.value(result)=fail
Call html (“test object is not visible fail”,Environment(result))
End If
End Function
webEdit_check
Function webEdit_check(strbrowser,strpage,strLink)
Testobject=Browser(strbrowser).Page(strpage).Link(strlink)
If Testobject.exist(10) Then
blnvisible= testobject.getRoproperty(visible)
If blnvisible =True Then
Testobject.click
Environment.value(result)=pass
‘It will write result to html page
Call html (“test step is success”,Environment(result))
Else
Environment.value(result)=fail
Call html (“test step is fail”,Environment(result))
End If
Else
Environment.value(result)=fail
Call html (“test object is not visible fail”,Environment(result))
End If
End Function
WebButton_check
Function WebButton_check(strbrowser,strpage,strWebButton)
Testobject=Browser(strbrowser).Page(strpage).WebButton(strWebButton)
If Testobject.exist(10) Then
blnvisible= testobject.getRoproperty(visible)
If blnvisible =True Then
Testobject.click
Environment.value(result)=pass
‘It will write result to html page
Call html (“test step is success”,Environment(result))
Else
Environment.value(result)=fail
Call html (“test step is fail”,Environment(result))
End If
Else
Environment.value(result)=fail
Call html (“test object is not visible fail”,Environment(result))
End If
End Function
(strverify,Result)
Function (strverify,Result)
If Environment(result)=pass Then
Td.write(<td(strverify)/>td<xxx><td(Result)/>td)
'(please note this is sample, which I typed, it’s just for concept)
Else
Td.write(<td(strverify)/>td<xxx><td(Result)/>td)
End If
End Function
If possible please mail (visitjaga#gmail.com) me the solution as in my office I’ve limited access to outside website. I’ll not be able to check immediately. I’ve been strucked with this issue for pass 20 days.
Thanks& Regard’s
Jagadeesh Mani
visitjaga#gmail.com
May be try this
On Error Resume Next
Call Link_check (strbrowser,strpage,strlink)
Err.Raise 6 ' Raise an overflow error.
MsgBox "Error # " & CStr(Err.Number) & " " & Err.Description
Err.Clear ' Clear the error.
In the above if the Function Link_check results in an error then, the execution will not move forward.If you want to execute next function use
On Error Resume Next
Call Link_check (strbrowser,strpage,strlink)
Err.Raise 6 ' Raise an overflow error.
MsgBox "Error # " & CStr(Err.Number) & " " & Err.Description
Err.Clear ' Clear the error.
On Error goto 0
WebButton_check
I hope this is what you have asked for.
To make my question more simple, i've 15 scenario's and for each scenario below function will be executed every time
Call WebEdit_check (“google”,”google”,”nametxtbox”,”xxxx”)
Call Link_check (strbrowser,strpage,strlink)
Call WebButton_check (strbrowser,strpage,strWebbutton)
so if when executing 3 rd scenario, Below step function fails
Call Link_check (strbrowser,strpage,strlink)
It will write fail in html result file and 3 rd scenario execution should be stopped and exceution of 4 th scenario should begin. This Err.Raise 6 will raise a user predefined error msg
for cnt i=0 to 15
Call WebEdit_check (“google”,”google”,”nametxtbox”,”xxxx”)
Error Resume Next
Call Link_check (strbrowser,strpage,strlink)'If the Error Occurs here then add On Error Resume Next above this statement
Call WebButton_check (strbrowser,strpage,strWebbutton)
Err.Clear 'This will clear the error.As,you want to keep this process to run for 15 times for each scenario.just add On Error goto 0
add On Error goto 0
Next
This might help
Greetings for the day,
Hi, I am a beginner using vb 6.0. I am using the following code and getting 'user defined type not defined'.the code is below.the line where i get error is highlighted.Kindly help.should i add some references or components?if so,what it would be. your timely and kindly help will be much more helpful for me
Public Sub LoadDocument()
Dim xDoc As MSXML2.DOMDocument
Set xDoc = New MSXML2.DOMDocument
xDoc.async = False
xDoc.validateOnParse = False
If xDoc.Load("C:\Users\284582\Desktop\XML1.xml") Then
DisplayNode xDoc.ChildNodes, 0
End If
End Sub
' Error on this line'
Public Sub DisplayNode(ByRef Nodes As MSXML.IXMLDOMNodeList, _
ByVal Indent As Integer)
Dim xNode As MSXML.IXMLDOMNode
Indent = Indent + 2
For Each xNode In Nodes
If xNode.NodeType = NODE_TEXT Then
Debug.Print Space$(Indent) & xNode.ParentNode.nodeName & _
":" & xNode.NodeValue
End If
If xNode.HasChildNodes Then
DisplayNode xNode.ChildNodes, Indent
End If
Next xNode
End sub
It's MSXML2.IXMLDOMNodeList, not MSXML.IXMLDOMNodeList.
The library may be missing from your references. Try this.
Manually adding MSXML2
1. Open MS Access.
2. Database Tools ribbon
3. Visual Basic ribbon item (icon)
4. Double-click on any module to open it.
5. Tools menu
6. References…
7. Find Microsoft XML, v6.0. is in the list
a. If in list but not checked, check it and click [OK].
b. If not in the list:
i. click [Browse…] and add "c:\windows\system32\msxml6.dll"
8. [OK] your way back to the Visual Basic window.
9. Close the Visual Basic Window. You should be good to go.
Programmatically adding MSXML2
Add the following sub and function. Run the sub. Edit the sub to include a path if necessary.
Check for broken references in the library
Adapted from Add references programatically
Sub CheckXmlLibrary()
' This refers to your VBA project.
Dim chkRef As Reference, RetVal As Integer ' A reference.
Dim foundWord As Boolean, foundExcel As Boolean, foundXml As Boolean
foundWord = False
foundExcel = False
foundXml = False
' Check through the selected references in the References dialog box.
For Each chkRef In References
' If the reference is broken, send the name to the Immediate Window.
If chkRef.IsBroken Then
Debug.Print chkRef.Name
End If
'copy and repeat the next 2 if statements as needed for additional libraries.
If InStr(UCase(chkRef.FullPath), UCase("msxml6.dll")) <> 0 Then
foundXml = True
End If
Next
If (foundXml = False) Then
'References.AddFromFile ("C:\Windows\System32\msxml6.dll") <-- For other than XML, modify this line and comment out line below.
RetVal = AddMsXmlLibrary
If RetVal = 0 Then MsgBox "Failed to load XML Library (msxml6.dll). XML upload/download will not work."
End If
End Sub
Add XML reference to the library
Developed by Chris Advena. Thanks to http://allenbrowne.com/ser-38.html for the insight.
Public Function AddMsXmlLibrary(Optional PathFileExtStr As String = "C:\Windows\System32\msxml6.dll") As Integer
On Error GoTo FoundError
AddMsXmlLibrary = 1
References.AddFromFile (PathFileExtStr)
AllDone:
Exit Function
FoundError:
On Error Resume Next
AddMsXmlLibrary = 0
On Error GoTo 0
End Function