Hello I am creating an application in which camera captures images automatically at a interval of 1 second. In below code I can take images on button click. But I want auto-camera.
Here is the code. Please help me how can I create?
Sub Process_Global
End Sub
Sub Globals
Dim camera1 As Camera
Dim btnTakePicture As Button
Dim Panel1 As Panel
End Sub
Sub Activity_Create(FirstTime As Boolean)
Activity.LoadLayout("1")
End Sub
Sub Camera1_Ready (Success As Boolean)
If Success Then
camera1.StartPreview
btnTakePicture.Enabled = True
Else
ToastMessageShow("Cannot open camera.", True)
End If
End Sub
Sub Activity_Resume
btnTakePicture.Enabled = False
camera1.Initialize(Panel1, "Camera1")
End Sub
Sub Activity_Pause (UserClosed As Boolean)
camera1.Release
End Sub
Sub Camera1_PictureTaken (Data() As Byte)
camera1.StartPreview
Dim t As Long
Dim filename As String
t = DateTime.Add(DateTime.Now,0,0,1)
filename = t & ".jpg"
Dim out As OutputStream
out = File.OpenOutput(File.DirRootExternal, filename, False)
out.WriteBytes(Data, 0, Data.Length)
out.Close
ToastMessageShow("Image Saved" , True)
btnTakePicture.Enabled = True
End Sub
Sub btnTakePicture_Click
btnTakePicture.Enabled = False
camera1.TakePicture
End Sub
Related
In LibreOffice Basic sub I use a bunch of uno properties in an array. Which is the simplest Unostructure or UnoService that I must "embed" them, in order to use the getByName "function"?
Example:
dim props(1) as new com.sun.star.beans.PropertyValue
props(0).Name = "blahblah1"
props(0).Value = "blahblah1Value"
props(1).Name = "blahblah2"
props(1).Name = 3000
I want to be able to use something like:
b = props.getByName("blahblah2").Value
or something like (assuming I "assigned" them in a structure-like-object called "somestruct") :
b = somestruct.getprops.getByName("blahblah2").Value
As I understand that this can be done by creating a "UnoService" which supports the getByName and then, somehow, assigning these props to this service
Which is the "lightest" such service?
(I mean the service that uses less resources)
Thanks in advance.
Really supporting the interface XNameAccess is not as easy. The services which implement this interface are supposed using this interface for existing named properties, not for own created ones.
But you can use the service EnumerableMap to achieve what you probably want.
Example:
sub testEnumerableMap
serviceEnumerableMap = com.sun.star.container.EnumerableMap
oEnumerableMap = serviceEnumerableMap.create("string", "any")
oEnumerableMap.put("blahblah1", "blahblah1Value")
oEnumerableMap.put("blahblah2", 3000)
oEnumerableMap.put("blahblah3", 1234.67)
msgbox oEnumerableMap.get("blahblah1")
msgbox oEnumerableMap.get("blahblah2")
msgbox oEnumerableMap.get("blahblah3")
'msgbox oEnumerableMap.get("blahblah4") 'will throw error
msgbox oEnumerableMap.containsKey("blahblah2")
msgbox oEnumerableMap.containsValue(3000)
if oEnumerableMap.containsKey("blahblah4") then
msgbox oEnumerableMap.get("blahblah4")
end if
end sub
But starbasic with option Compatible is also able supporting Class programming like VBA does.
Example:
Create a module named myPropertySet. Therein put the following code:
option Compatible
option ClassModule
private aPropertyValues() as com.sun.star.beans.PropertyValue
public sub setProperty(oProp as com.sun.star.beans.PropertyValue)
bUpdated = false
for each oPropPresent in aPropertyValues
if oPropPresent.Name = oProp.Name then
oPropPresent.Value = oProp.Value
bUpdated = true
exit for
end if
next
if not bUpdated then
iIndex = ubound(aPropertyValues) + 1
redim preserve aPropertyValues(iIndex)
aPropertyValues(iIndex) = oProp
end if
end sub
public function getPropertyValue(sName as string) as variant
getPropertyValue = "N/A"
for each oProp in aPropertyValues
if oProp.Name = sName then
getPropertyValue = oProp.Value
exit for
end if
next
end function
Then within a standard module:
sub testClass
oPropertySet = new myPropertySet
dim prop as new com.sun.star.beans.PropertyValue
prop.Name = "blahblah1"
prop.Value = "blahblah1Value"
oPropertySet.setProperty(prop)
prop.Name = "blahblah2"
prop.Value = 3000
oPropertySet.setProperty(prop)
prop.Name = "blahblah3"
prop.Value = 1234.56
oPropertySet.setProperty(prop)
prop.Name = "blahblah2"
prop.Value = 8888
oPropertySet.setProperty(prop)
msgbox oPropertySet.getPropertyValue("blahblah1")
msgbox oPropertySet.getPropertyValue("blahblah2")
msgbox oPropertySet.getPropertyValue("blahblah3")
msgbox oPropertySet.getPropertyValue("blahblah4")
end sub
LibreOffice Basic supports the vb6 Collection type.
Dim coll As New Collection
coll.Add("blahblah1Value", "blahblah1")
coll.Add(3000, "blahblah2")
MsgBox(coll("blahblah1"))
Arrays of property values are the only thing that will work for certain UNO interfaces such as dispatcher calls. If you simply need a better way to deal with arrays of property values, then use a helper function.
Sub DisplayMyPropertyValue
Dim props(0 To 1) As New com.sun.star.beans.PropertyValue
props(0).Name = "blahblah1"
props(0).Value = "blahblah1Value"
props(1).Name = "blahblah2"
props(1).Name = 3000
MsgBox(GetPropertyByName(props, "blahblah1"))
End Sub
Function GetPropertyByName(props As Array, propname As String)
For Each prop In props
If prop.Name = propname Then
GetPropertyByName = prop.Value
Exit Function
End If
Next
GetPropertyByName = ""
End Function
XNameAccess is used for UNO containers such as Calc sheets. Normally these containers are obtained from the UNO interface, not created.
oSheet = ThisComponent.Sheets.getByName("Sheet1")
May UNO objects support the XPropertySet interface. Normally these are also obtained from the UNO interface, not created.
paraStyleName = cellcursor.getPropertyValue("ParaStyleName")
It may be possible to create a new class in Java that implements XPropertySet. However, Basic uses helper functions instead of class methods.
I think the serviceEnumerableMap is the answer (so far). Creating the values and searching them was much faster then creating props in a dynamic array and searching them with a for loop in basic.
(I do not "dare" to use "option Compatible", although I was a big fun of VB6 and VBA, because of the problems in code that maybe arise).
I used this code to test time in a form:
SUB testlala(Event)
TESTPROPS(Event)
' TESTENUM(Event)
MSGBOX "END OF TEST"
END SUB
SUB TESTENUM(Event)
DIM xcounter AS LONG
'b = now()
serviceEnumerableMap = com.sun.star.container.EnumerableMap
oEnumerableMap = serviceEnumerableMap.create("string", "any")
FOR xcounter= 0 TO 10000
oEnumerableMap.put("pr" & FORMAT(xcounter,"0000"), xcounter -10000)
NEXT
'b=now()-b
b = now()
FOR xcounter = 1 TO 5000
lala = Int((9000 * Rnd) +1)
g =oEnumerableMap.get("pr" & FORMAT(lala,"0000"))
'MSGBOX GetValueFromName(props,"pr" & FORMAT(xcounter,"0000"))
NEXT
b=now()-b
MSGBOX b*100000
END SUB
SUB TESTPROPS(Event)
DIM props()
DIM xcounter AS LONG
'b = now()
FOR xcounter= 0 TO 10000
AppendProperty(props,"pr" & FORMAT(xcounter,"0000"), xcounter -10000)
NEXT
'b=now()-b
b = now()
FOR xcounter = 1 TO 5000
lala = Int((9000 * Rnd) +1)
g = GetValueFromName(props,"pr" & FORMAT(lala,"0000"))
'MSGBOX GetValueFromName(props,"pr" & FORMAT(xcounter,"0000"))
NEXT
b=now()-b
MSGBOX b*100000
END SUB
REM FROM Andrew Pitonyak's OpenOffice Macro Information ------------------
Sub AppendToArray(oData(), ByVal x)
Dim iUB As Integer 'The upper bound of the array.
Dim iLB As Integer 'The lower bound of the array.
iUB = UBound(oData()) + 1
iLB = LBound(oData())
ReDim Preserve oData(iLB To iUB)
oData(iUB) = x
End Sub
Function CreateProperty(sName$, oValue) As com.sun.star.beans.PropertyValue
Dim oProperty As New com.sun.star.beans.PropertyValue
oProperty.Name = sName
oProperty.Value = oValue
CreateProperty() = oProperty
End Function
Sub AppendProperty(oProperties(), sName As String, ByVal oValue)
AppendToArray(oProperties(), CreateProperty(sName, oValue))
End Sub
Okay so when I press a specific button I want to loop through all forms, then find every control in each form with the tag 'TESTING'. If the tag = 'TESTING' then I want to change the caption of the object to 'abc123'.
The only objects with the tag 'TESTING' will be labels, so they will have the caption property.
So far I have this as the function:
Public Function changelabel()
On Error Resume Next
Dim obj As AccessObject, dbs As Object
Dim ctrl as Control
Set dbs = Application.CurrentProject
For Each obj In dbs.AllForms
DoCmd.OpenForm obj.Name, acDesign
For Each ctrl In Me.Controls
If ctrl.Tag = "TESTING" Then
ctrl.Caption = "abc123"
End If
Next ctrl
Next obj
End Function
Then this as the button code:
Public Sub TestButton_Click()
Call changelabel
End Sub
So it executes the first for loop and opens all the forms in design view correctly. The problem lies with the second for loop. None of the label captions that have the tag property as 'TESTING' are changed to 'abc123'.
So what do I need to change to get the second for loop to work?
Public Sub GetForms()
Dim oForm As Form
Dim nItem As Long
Dim bIsLoaded As Boolean
For nItem = 0 To CurrentProject.AllForms.Count - 1
bIsLoaded = CurrentProject.AllForms(nItem).IsLoaded
If Not bIsLoaded Then
On Error Resume Next
DoCmd.OpenForm CurrentProject.AllForms(nItem).NAME, acDesign
End If
Set oForm = Forms(CurrentProject.AllForms(nItem).NAME)
GetControls oForm
If Not bIsLoaded Then
On Error Resume Next
DoCmd.Close acForm, oForm.NAME
End If
Next
End Sub
Sub GetControls(ByVal oForm As Form)
Dim oCtrl As Control
Dim cCtrlType, cCtrlCaption As String
For Each oCtrl In oForm.Controls
If oCtrl.ControlType = acSubform Then Call GetControls(oCtrl.Form)
Select Case oCtrl.ControlType
Case acLabel: cCtrlType = "label": cCtrlCaption = oCtrl.Caption
Case acCommandButton: cCtrlType = "button": cCtrlCaption = oCtrl.Caption
Case acTextBox: cCtrlType = "textbox": cCtrlCaption = oCtrl.Properties("DataSheetCaption")
Case Else: cCtrlType = ""
End Select
If cCtrlType <> "" Then
Debug.Print oForm.NAME
Debug.Print oCtrl.NAME
Debug.Print cCtrlType
Debug.Print cCtrlCaption
End If
Next
End Sub
Something like this
Public Function changelabel()
Dim f As Form
Dim i As Integer
Dim c As Control
For i = 0 To CurrentProject.AllForms.Count - 1
If Not CurrentProject.AllForms(i).IsLoaded Then
DoCmd.OpenForm CurrentProject.AllForms(i).Name, acDesign
End If
Set f = Forms(i)
For Each c In f.Controls
If c.Tag = "TESTING" Then
c.Caption = "TESTING"
End If
Next c
Next i
End Function
You'll need to add a bit of house-keeping to set the objects used to nothing etc..
I'm trying to write a lottery application and have written out all the code. Everything seems to be fine except the part where it's supposed to show the winning numbers and the user's numbers. When the ResultsForm pops up, all the labels are blank instead of having the numbers filled in. Any help would be greatly appreciated. I will include the code for the MainForm, the ResultsForm and the Module I used.
Public Class MainForm
Dim rand As New Random
Private Sub MainForm_Load(ByVal sender As System.Object, ByVal e As System.EventArgs)
GenerateNewLotteryNumbers()
End Sub
Private Sub btnCheckNumbers_Click(sender As Object, e As EventArgs) Handles btnCheckNumbers.Click
If ValidateUserPicks() Then
DisplayResults()
End If
End Sub
Private Sub btnPlayAgain_Click(sender As Object, e As EventArgs) Handles btnPlayAgain.Click
GenerateNewLotteryNumbers()
Reset()
End Sub
Private Sub btnExit_Click(sender As Object, e As EventArgs) Handles btnExit.Click
Me.Close()
End Sub
Sub GenerateNewLotteryNumbers()
For intCount = 0 To g_intUPPER_SUB
g_intNumbers(intCount) = rand.Next(10)
Next
End Sub
Sub Reset()
txtDigit1.Clear()
txtDigit2.Clear()
txtDigit3.Clear()
txtDigit4.Clear()
txtDigit5.Clear()
txtDigit1.Focus()
End Sub
Sub DisplayResults()
Dim frmResults As New ResultsForm
frmResults.ShowDialog()
End Sub
Function ValidateUserPicks() As Boolean
Dim blnIsValid As Boolean = False
If Integer.TryParse(txtDigit1.Text, g_intUserPicks(0)) And
g_intUserPicks(0) >= 0 And g_intUserPicks(0) <= 9 Then
If Integer.TryParse(txtDigit2.Text, g_intUserPicks(1)) And
g_intUserPicks(1) >= 0 And g_intUserPicks(1) <= 9 Then
If Integer.TryParse(txtDigit3.Text, g_intUserPicks(2)) And
g_intUserPicks(2) >= 0 And g_intUserPicks(2) <= 9 Then
If Integer.TryParse(txtDigit4.Text, g_intUserPicks(3)) And
g_intUserPicks(3) >= 0 And g_intUserPicks(3) <= 9 Then
If Integer.TryParse(txtDigit5.Text, g_intUserPicks(4)) And
g_intUserPicks(4) >= 0 And g_intUserPicks(4) <= 9 Then
End If
blnIsValid = True
Else
MessageBox.Show("Digit 5: Enter a number between 0 and 9.")
txtDigit5.Focus()
txtDigit5.SelectAll()
End If
Else
MessageBox.Show("Digit 4: Enter a number between 0 and 9.")
txtDigit4.Focus()
txtDigit5.SelectAll()
End If
Else
MessageBox.Show("Digit 3: Enter a number between 0 and 9.")
txtDigit3.Focus()
txtDigit3.SelectAll()
End If
Else
MessageBox.Show("Digit 2: Enter a number between 0 and 9.")
txtDigit2.Focus()
txtDigit2.SelectAll()
End If
Return blnIsValid
End Function
End Class
ResultsForm:
Public Class ResultsForm
Private Sub ResultsForm_Load(ByVal sender As System.Object, ByVal e As System.EventArgs)
DisplayLotteryNumbers()
ShowResults()
End Sub
Private Sub btnOk_Click(sender As Object, e As EventArgs) Handles btnOk.Click
Me.Close()
End Sub
Sub DisplayLotteryNumbers()
lblWinningNumber1.Text = g_intNumbers(0).ToString
lblWinningNumber2.Text = g_intNumbers(1).ToString
lblWinningNumber3.Text = g_intNumbers(2).ToString
lblWinningNumber4.Text = g_intNumbers(3).ToString
lblWinningNumber5.Text = g_intNumbers(4).ToString
lblYourNumber1.Text = g_intNumbers(0).ToString
lblYourNumber2.Text = g_intNumbers(1).ToString
lblYourNumber3.Text = g_intNumbers(2).ToString
lblYourNumber4.Text = g_intNumbers(3).ToString
lblYourNumber5.Text = g_intNumbers(4).ToString
End Sub
Sub DisplayWinnerForm()
Dim frmWinner As New WinnerForm
frmWinner.ShowDialog()
End Sub
Sub ShowResults()
Select Case MatchingDigits()
Case 1
lblResults.Text = "One Matching Digit."
Case 2
lblResults.Text = "Two Matching Digits."
Case 3
lblResults.Text = "Three Matching Digits."
Case 4
lblResults.Text = "Four Matching Digits."
Case 5
lblResults.Text = "All Digits Match!"
DisplayWinnerForm()
Case Else
lblResults.Text = "No Matching Digits."
End Select
End Sub
Function MatchingDigits() As Integer
Dim numMatches As Integer
For intCount = 0 To g_intUPPER_SUB
If g_intNumbers(intCount) = g_intUserPicks(intCount) Then
numMatches += 1
End If
Next
Return numMatches
End Function
End Class
Module:
Module LotteryModule
Public Const g_intUPPER_SUB As Integer = 4
Public g_intNumbers(g_intUPPER_SUB) As Integer
Public g_intUserPicks(g_intUPPER_SUB) As Integer
End Module
I have following macro code, this will run macro automatically and login into mentioned website. But xls sheets remains opened ..
-----------------------------------------------------------------
Sub Auto_open()
login
End Sub
Sub login()
Dim IntExpl As Object
Set IntExpl = CreateObject("InternetExplorer.Application")
Dim dd As Object
Dim dd1 As Object
Dim dd2 As Object
Dim dd3 As Object
With IntExpl
.navigate "........."
.Visible = True
' If (.Document.getElementById("LoginUsername").exist) Then
Do Until IntExpl.ReadyState = 4
Loop
Set dd = .Document.getElementById("LoginUsername")
dd.Value = "AAAAA"
dd.Click
Set dd1 = .Document.getElementById("LoginPassword")
dd1.Value = "AAAAAA"
dd1.Click
Set dd2 = .Document.getElementById("loginBtn")
dd2.Click
End With
End Sub
-------------------------------------------------------------------------------
I want to close xls file also after running whole macro.
You can define your workbook and then close it once the macro is completed.
Sub Auto_open()
Dim wb as Workbook
set wb = ActiveWorkbook
login
wb.close
End Sub
Sub login()
Dim IntExpl As Object
Set IntExpl = CreateObject("InternetExplorer.Application")
Dim dd As Object
Dim dd1 As Object
Dim dd2 As Object
Dim dd3 As Object
With IntExpl
.navigate "........."
.Visible = True
' If (.Document.getElementById("LoginUsername").exist) Then
Do Until IntExpl.ReadyState = 4
Loop
Set dd = .Document.getElementById("LoginUsername")
dd.Value = "AAAAA"
dd.Click
Set dd1 = .Document.getElementById("LoginPassword")
dd1.Value = "AAAAAA"
dd1.Click
Set dd2 = .Document.getElementById("loginBtn")
dd2.Click
End With
End Sub
I know there is a way to pass class variables in vb.net as such:
Module Module1
Sub Main()
' Declare an instance of the class and assign a value to its field.
***Dim c1 As Class1 = New Class1()***
c1.Field = 5
Console.WriteLine(c1.Field)
' Output: 5
' ByVal does not prevent changing the value of a field or property.
ChangeFieldValue(***c1***)
Console.WriteLine(***c1.Field***)
' Output: 500
' ByVal does prevent changing the value of c1 itself.
ChangeClassReference(c1)
Console.WriteLine(c1.Field)
' Output: 500
Console.ReadKey()
End Sub
Public Sub ChangeFieldValue(***ByVal cls As Class1***)
cls.Field = 500
End Sub
Public Sub ChangeClassReference(***ByVal cls As Class1***)
cls = New Class1()
cls.Field = 1000
End Sub
Public Class Class1
Public Field As Integer
End Class
End Module
However when I try to emulate the same procedure in vba, it doesn't work.
is it possible to do in vba (for Excel)?
Try the following.
Sub Main()
Dim c1 As New Class1
c1.Field = 5
Debug.Print c1.Field
changeFieldValue c1
Debug.Print c1.Field
changeClassReference c1
Debug.Print c1.Field
End Sub
Public Sub changeClassReference(cls As Class1)
Set cls = New Class1
cls.Field = 1000
End Sub
Public Sub changeFieldValue(cls As Class1)
cls.Field = 500
End Sub
You'll need to add a new class module with the following code:
Public Field As Long