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
Related
I managed to adapt a vba macro (which I also found here) and got it running. So when the macro is started a file dialog asks me for the source file and the output gives me the word count of this file into cell "A1".
Public Sub word_counter()
Dim objWord As Object, objDocument As Object
Dim strText As String
Dim lngIndex As Long
Dim cellrange As String
Dim intChoice As Integer
Dim strPath As String
Set objWord = CreateObject("Word.Application")
objWord.Visible = False
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
intChoice = Application.FileDialog(msoFileDialogOpen).Show
strPath = Application.FileDialog( _
msoFileDialogOpen).SelectedItems(1)
Set objDocument = objWord.documents.Open(strPath)
strText = objDocument.Content.Text
objDocument.Close SaveChanges:=False
For lngIndex = 0 To 31
strText = Replace(strText, Chr$(lngIndex), Space$(1))
Next
Do While CBool(InStr(1, strText, Space$(2)))
strText = Replace(strText, Space$(2), Space$(1))
Loop
Sheets("calc tool").Select
Range("A1") = UBound(Split(strText, Space$(1)))
objWord.Quit
Set objDocument = Nothing
Set objWord = Nothing
End Sub
Now i want to add the filename to the output as text in cell "A2" right next to the word count of this file.
A1: 1234 A2: filename.docx
I tried to add the solution described in the SOF question 12687536
here!
The results were disappointing and i ran into compiling errors or run time error '91'
This was one of my solutions which didn't work out.
Public Sub word_count()
Dim objWord As Object, objDocument As Object
Dim strText As String
Dim lngIndex As Long
Dim cellrange As String
Dim intChoice As Integer
Dim strPath As String
Dim filename As String
Dim cell As Range
Set objWord = CreateObject("Word.Application")
objWord.Visible = False
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
intChoice = Application.FileDialog(msoFileDialogOpen).Show
strPath = Application.FileDialog( _
msoFileDialogOpen).SelectedItems(1)
Set objDocument = objWord.documents.Open(strPath)
strText = objDocument.Content.Text
objDocument.Close SaveChanges:=False
For lngIndex = 0 To 31
strText = Replace(strText, Chr$(lngIndex), Space$(1))
Next
Do While CBool(InStr(1, strText, Space$(2)))
strText = Replace(strText, Space$(2), Space$(1))
Loop
Sheets("calc tool").Select
Range("A1") = UBound(Split(strText, Space$(1)))
filename = Application.GetOpenFilename
cell = Application.Range("A2")
cell.Value = filename
objWord.Quit
Set objDocument = Nothing
Set objWord = Nothing
End Sub
Any idea how to make this work?
You have to select a sheet before you can use Range().
Thus change
cell = Application.Range("A2")
cell.Value = filename
to
Range("A2") = filename
or better
Application.ActiveSheet.Range("A2").Value = filename
and you write the filename into the cell A2 in your active sheet.
This is the code I have so far:
REM ***** BASIC *****
Option Explicit
rem-----------------------------------------------------------------------
REM----
Sub Main
Dim YearNm As Long, DayCol As Long, DayRow As Long
Dim DataSheet As Object, oSheet As Object
Dim SelDate As Date
Dim oDoc As String, oSelection As String
Set DataSheet = ThisComponent.CurrentController.ActiveSheet
oDoc = ThisComponent
oSelection = ThisComponent.CurrentSelection
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
'Private Sub Worksheet_Change(ByVal Target As Dim oSheet as Object[n]oSheet = ThisComponent.CurrentController.ActiveSheet[n]oSheet.getCellRangeByName($1))
'If Not Intersect(Target, Dim oSheet as Object[n]oSheet = `
'`ThisComponent.CurrentController.ActiveSheet[n]oSheet.getCellRangeByName($1)("AH6:AH29")) Is Nothing Then
If Not Intersect(Target,Range("AH6:AH29")) Is Nothing Then
'("AH5") = ThisComponent.CurrentController.ThisComponent.CurrentController.ActiveSheet.getCellDim oSheet as Object[n]oSheet = ThisComponent.CurrentController.ThisComponent.ActiveSheet[n}ThisComponent.CurrentController.Select(oSheet.getCellThisComponent.CurrentController.ThisCompponent.CurrentController.ActiveSheet.getCellDim oSheet as Object[n]oSheet = ThisComponent.CurrentController.ActiveSheet.getCellDim oSheet as Object[n]oSheet =ThisComponent.CurrentController.ActiveSheet[n]oSheet.getCellRangeByName($1)ByName(ByName(ByName($2)).Value))ed Date
'Range("AH5") = ThisComponent.CurrentController.ThisComponent.CurrentController.ActiveSheet.getCell = ThisComponent.CurrentController.ThisComponent.ActiveSheet.CurrentController.Select(oSheet.getCellThisComponent.CurrentController.ThisCompponent.CurrentController.ActiveSheet.getCellDim oSheet as Object[n]oSheet = ThisComponent.CurrentController.ActiveSheet.getCellDim oSheet as Object[n]oSheet = ThisComponent.CurrentController.ActiveSheet[n]oSheet.getCellRangeByName($1)ByName(ByName(ByName($2)).Value))as Date)
Range("AH5") = oSelection
'
YearNm = [ScYear]
'Determine if data worksheet exists
On Error Resume Next
Set DataSheet = ThisWorkbook.Sheets("" & YearNm & "")
On Error Goto 0
If DataSheet Is Nothing Then
ThisWorkbook.Sheets.Add(After:=Sheets("Schedule")).Name = YearNm
Set DataSheet = ThisWorkbook.Sheets("" & YearNM & "")
Active
End If
'
DayRow = Tatget.Row 'Row
DayCol = SelDate - DateSerial(YearNm, 1, 1) + 1 'Dtermine Column for Data Sheet
DataSheet.Cells(DayRow, DayCol).Value = Target.Value
End If
End Sub
Private Sub Sheet()
CurrentController.setThisComponent.CurrentController.ActiveSheet(vSheet);ionChange(ByVal Target As Dim oSheet as Object[n]oSheet = ThisComponent.CurrentController.ActiveSheet[n]oSheet.getCellRangeByName($1)("B6:AF29")) Is Nothing Then
If IsDate(Target.Value) = False Then Exit Sub
SlDate = Target.Value 'Selected Date
YearNm = [ScYear]
ThisComponent.CurrentControlller.ThisComponent.CurrentController.ActiveSheet.getCellDim oSheet as Object[n]oSheet = ThisComponent.CcurrentController.ActiveSheet[n]oSheet.getCellRangeByName($1)ByName(("AH5")).Value = SelDate
'Determine if data worksheet exists
On Error Resume Next
Set DataSheet = ThisWorkbook.Sheets("" & YearNm & "")
On Error Goto 0
If DataSheet Is Nothing Then
'
ThisWorkbook.Sheets.Add(After:=Sheets("Schedule")).Name = YearNm
Set DataSheet = ThisWorkbook.Sheets("" & YearNm & "")
Activate
End If
DayRow = Target.Row 'Row
DayCol = SelDate - DateSerial(YearNm, 1, 1) +1 'Determine Column for Data Sheet
ThisComponent.CurrentController.ThisComponent.CurrentController.ActiveSheet.getCellThisComponent.CurrentController.ThisComponent.CurrentController.ActiveSheet.getCellDim oSheet as Object[n]oSheet = ThisComponent.CurrentController.Activesheet[n]oSheet.getCellRangeByName($1)ByName(ByName(("AH6:AH29")).Value = DataSheet.ThisComponent.CurrentController.ThisComponent.CurrentController.ActiveSheet.getCellDim oSheet as Object[n]oSheet =
ThisComponent.Currentcontroller.ActiveSheet[n]oSheet.getCellRangeByName($1)ByName((DataSheet).getCellByPosition((6,DayCol), DataSheet.Cells(29, DayCol)), $3)).Value
End If
End Sub]
Basically what I need to happen is this: when a new day is selected, the value in cell "AH5" change to the selected date long version, "month day, year".
Thank you in advance.
I am trying to convert visual basic to open office.
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..
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