I need to create this dialog programatically because it will have a variable number of controls depending on the client. (The naming conventions are sloppy right now because i am in the middle adapting someone else's code.) The code chokes when the focusGained sub is entered (see below).
I have tried many things but especially of note is: if i change the relevant lines to deal with the textChanged event instead, it all works as expected.
Sub main
Dim dlgmodel As Variant
Dim oComponents As Variant
Dim oDoc As Variant
dlgmodel = CreateUnoService("com.sun.star.awt.UnoControlDialogModel")
With dlgmodel
.Name = "checkwriter"
.Title = "check writer"
.PositionX = 170
.PositionY = 70
.Width = 190
.Height = 100
.DesktopAsParent = false ' or true, does not affect problem
End With
Dim oModel As Variant
oModel = dlgmodel.createInstance("com.sun.star.awt.UnoControlGroupBoxModel")
omodel.name = "rbgroup"
dlgmodel.insertByName(oModel.Name, oModel)
dim j%
for j = 0 to 3 ' 3 is for example
oModel = dlgmodel.createInstance("com.sun.star.awt.UnoControlRadioButtonModel")
With oModel
.Name = "rb" & j
.PositionX = 10
.PositionY = 6 + j * 15
.Width = 12
.Height = 12
.groupname = "rbgroup"
End With
dlgmodel.insertByName(oModel.Name, oModel)
oModel = dlgmodel.createInstance("com.sun.star.awt.UnoControlEditModel")
with omodel
.Name = "txt" & j
.PositionX = 40
.PositionY = 6 + j * 15
.Width = 40
.Height = 12
end with
dlgmodel.insertByName(oModel.Name, oModel)
next
Dim oDlg As Variant
oDlg = CreateUnoService("com.sun.star.awt.UnoControlDialog")
oDlg.setModel(dlgmodel)
Dim oControl As Variant
oListener = CreateUnoListener("txt_", "com.sun.star.awt.XFocusListener")
oControl = oDlg.getControl("txt0") ' testing one single edit control
ocontrol.addFocusListener(oListener)
Dim oWindow As Variant
oWindow = CreateUnoService("com.sun.star.awt.Toolkit")
oDlg.createPeer(oWindow, null)
oDlg.execute()
End Sub
'entering focusGained() causes
' "BASIC runtime error. Property or method not found: $(ARG1)."
' after clearing that, the print statement executes.
' ***warning*** without the print statement the dialog will become uncloseable.
sub txt_focusGained(event as object)
print "txt1"
end sub
The interface com.sun.star.awt.XFocusListener requires two methods. You only implemented one of them, which is why the error occurs.
To fix it, add the following:
sub txt_focusLost(event as object)
print "txt2"
end sub
However, are you sure you want a focus listener? As you will see by running it, the revised code results in an infinite loop. Focus is generally tricky and works differently depending on the operating system. Normally I use textChanged instead.
details of solution with example here
https://ask.libreoffice.org/en/question/218979/why-is-this-edit-control-event-handler-not-working/
Related
I would like to dynamically set some textbox values with database values.
I have tried to use something similar to below but I get the following compile error:
Can't assign to read only property. The .name = is highlighted.
Is it possible to assign the textbox values in this manner?
Dim x As Integer
For x = 1 To 30
Form1.RS.Fields(x).Name = RS.Fields(x).Value
Next
You can try using controls collection of the form :
Dim x As Integer
For x = 1 To 30
Form1.Controls(RS.Fields(x).Name).Text = RS.Fields(x).Value
Next
As a takeoff on Eddi's answer, here's code that allows for multiple control types on the form:
Dim x As Integer
For x = 1 To 30
If TypeOf Me.Controls(RS.Fields(x).Name) Is TextBox Then
Me.Controls(RS.Fields(x).Name).Text = RS.Fields(x).Value
ElseIf TypeOf Me.Controls(RS.Fields(x).Name) Is CheckBox Then
Me.Controls(RS.Fields(x).Name).Value = _
IIf(RS.Fields(x).Value = 1, vbChecked, vbUnchecked)
End If
Next
One shortcoming of the above code is the loss of intellisense. You can structure the code like the following so it is strongly-typed, which has a number of benefits including intellisense:
Dim tb As TextBox
Dim cb As CheckBox
Dim x As Integer
For x = 1 To 30
If TypeOf Me.Controls(RS.Fields(x).Name) Is TextBox Then
Set tb = Me.Controls(RS.Fields(x).Name)
tb.Text = RS.Fields(x).Value
ElseIf TypeOf Me.Controls(RS.Fields(x).Name) Is CheckBox Then
Set cb = Me.Controls(RS.Fields(x).Name)
cb.Value = IIf(RS.Fields(x).Value = 1, vbChecked, vbUnchecked)
End If
Next
Assuming you have an array of Text1 textboxes indexed from 1 to 30, you can use:
Dim iCounter As Integer
For iCounter = 1 To 30
' Check that counter is within the bounds of the Text1 array
If iCounter >= Text1.LBound And iCounter <= Text1.UBound Then
Text1(iCounter).Text = RS.Fields(iCounter).Value
End If
Next
There's extra code here to check that the counter is within the range of the Text1 array. The Text1 array could be gaps (missing items) in between its LBound and UBound values so it's not perfect. For example you could delete Text1(13) and still have LBound = 1 and UBound = 30. The easiest way is to check for error '340', if you decide to add that. Since you are building the UI you can simply remove any gaps.
Using an array of Textbox controls lets you share common code like the following, which highlights the text when the cursor enters the textbox:
Private Sub Text1_GotFocus(Index As Integer)
With Text1(Index)
.SelStart = 0
.SelLength = Len(.Text)
End With
End Sub
I was working on a system in VBA word. The goal of the system is to replace several different words in a document with input from a text box. So far I have a userform with 12 different text boxes each containing input from a user to replace words in the document. I made a button in the userform to print all the input from the textboxes to the document.
For each textbox I made the following code:
Sub FindAndReplaceAllStoriesHopefully()
Dim myStoryRange As Range
'
'
'Loop replaces everything with <KLANTNAAM> in the document
For Each myStoryRange In ActiveDocument.StoryRanges
With myStoryRange.Find
.Text = "<KLANTNAAM>"
.Replacement.Text = TextBox1.Value
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
Do While Not (myStoryRange.NextStoryRange Is Nothing)
Set myStoryRange = myStoryRange.NextStoryRange
With myStoryRange.Find
.Text = "<KLANTNAAM>"
.Replacement.Text = TextBox1.Value
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
Loop
Next myStoryRange
So far I did this for all 12 textboxes and it works but it isn't smooth. The
button upon getting clicked is calling the function with
Call FindAndReplaceAllStoriesHopefully
I have a few problems which I just cannot fix:
Once the button is clicked and some textboxes are not filled by the user, the marked words like <KLANTNAAM> are still replaced and removed from the document.
The performance of the macro is not great since the same code is copied 12 times.
Once the button is clicked, there is no easy way for the user to undo mistakes typed in the userform since the results are already printed.
I was hoping to get some tips so I can finalize this application.
Something like this:
Private Sub CommandButton1_Click()
Dim numBlank As Long, n As Long, txt As String
Dim bookMarkName As String
numBlank = Me.CountBlanks
If numBlank > 0 Then
If MsgBox(numBlank & " entries are blank!. Continue?", _
vbExclamation + vbOKCancel) <> vbOK Then
Exit Sub
End If
End If
For n = 1 To 4
txt = Me.Controls("Textbox" & n).Text
bookMarkName = "BOOKMARK" & n
FindAndReplaceAllStoriesHopefully bookMarkName, txt
Next n
End Sub
Function CountBlanks() As Long
Dim n As Long, b As Long
b = 0
For n = 1 To 4
If Len(Me.Controls("Textbox" & n).Text) = 0 Then
b = b + 1
End If
Next n
CountBlanks = n
End Function
I have both AutoCAD and AutoCAD Architecture installed on my system. AutoCAD Architecture has a tab called Vision Tools with a nifty command called Display By Layer to set the display order of objects in accordance with the layers of the drawing. Is there anyway to add this tab or use this command in AutoCAD?
Not sure if you're looking for a built-in feature or APIs for it.
For a built in feature, check the DRAWORDER command. For an API/programming approach, check the respective DrawOrderTable method. See below:
Update: please also check this 3rd party tool: DoByLayer.
[CommandMethod("SendToBottom")]
public void commandDrawOrderChange()
{
Document activeDoc
= Application.DocumentManager.MdiActiveDocument;
Database db = activeDoc.Database;
Editor ed = activeDoc.Editor;
PromptEntityOptions peo
= new PromptEntityOptions("Select an entity : ");
PromptEntityResult per = ed.GetEntity(peo);
if (per.Status != PromptStatus.OK)
{
return;
}
ObjectId oid = per.ObjectId;
SortedList<long, ObjectId> drawOrder
= new SortedList<long, ObjectId>();
using (Transaction tr = db.TransactionManager.StartTransaction())
{
BlockTable bt = tr.GetObject(
db.BlockTableId,
OpenMode.ForRead
) as BlockTable;
BlockTableRecord btrModelSpace =
tr.GetObject(
bt[BlockTableRecord.ModelSpace],
OpenMode.ForRead
) as BlockTableRecord;
DrawOrderTable dot =
tr.GetObject(
btrModelSpace.DrawOrderTableId,
OpenMode.ForWrite
) as DrawOrderTable;
ObjectIdCollection objToMove = new ObjectIdCollection();
objToMove.Add(oid);
dot.MoveToBottom(objToMove);
tr.Commit();
}
ed.WriteMessage("Done");
}
With some help from VBA it might look by this. Note i did not add fancy listbox code. I just show the worker and how to list layers. The trivial Code to add things to a listbox on a form and how to sort / rearrange listbox items can be found on any excel / VBA forum on the web . Or you just uses a predefined string like in the example. To get VBA to work download and install the acc. VBA Enabler from autocad. It is free.
'select all items on a layer by a filter
Sub selectALayer(sset As AcadSelectionSet, layername As String)
Dim filterType As Variant
Dim filterData As Variant
Dim p1(0 To 2) As Double
Dim p2(0 To 2) As Double
Dim grpCode(0) As Integer
grpCode(0) = 8
filterType = grpCode
Dim grpValue(0) As Variant
grpValue(0) = layername
filterData = grpValue
sset.Select acSelectionSetAll, p1, p2, filterType, filterData
Debug.Print "layer", layername, "Entities: " & str(sset.COUNT)
End Sub
'bring items on top
Sub OrderToTop(layername As String)
' This example creates a SortentsTable object and
' changes the draw order of selected object(s) to top.
Dim oSset As AcadSelectionSet
Dim oEnt
Dim i As Integer
Dim setName As String
setName = "$Order$"
'Make sure selection set does not exist
For i = 0 To ThisDrawing.SelectionSets.COUNT - 1
If ThisDrawing.SelectionSets.ITEM(i).NAME = setName Then
ThisDrawing.SelectionSets.ITEM(i).DELETE
Exit For
End If
Next i
setName = "tmp_" & time()
Set oSset = ThisDrawing.SelectionSets.Add(setName)
Call selectALayer(oSset, layername)
If oSset.COUNT > 0 Then
ReDim arrObj(0 To oSset.COUNT - 1) As ACADOBJECT
'Process each object
i = 0
For Each oEnt In oSset
Set arrObj(i) = oEnt
i = i + 1
Next
End If
'kills also left over selectionset by programming mistakes....
For Each selectionset In ThisDrawing.SelectionSets
selectionset.delete_by_layer_space
Next
On Error GoTo Err_Control
'Get an extension dictionary and, if necessary, add a SortentsTable object
Dim eDictionary As Object
Set eDictionary = ThisDrawing.modelspace.GetExtensionDictionary
' Prevent failed GetObject calls from throwing an exception
On Error Resume Next
Dim sentityObj As Object
Set sentityObj = eDictionary.GetObject("ACAD_SORTENTS")
On Error GoTo 0
If sentityObj Is Nothing Then
' No SortentsTable object, so add one
Set sentityObj = eDictionary.AddObject("ACAD_SORTENTS", "AcDbSortentsTable")
End If
'Move selected object(s) to the top
sentityObj.MoveToTop arrObj
applicaTION.UPDATE
Exit Sub
Err_Control:
If ERR.NUMBER > 0 Then MsgBox ERR.DESCRIPTION
End Sub
Sub bringtofrontbylist()
Dim lnames As String
'predefined layer names
layer_names = "foundation bridge road"
Dim h() As String
h = split(layernames)
For i = 0 To UBound(h)
Call OrderToTop(h(i))
Next
End Sub
'in case you want a fancy form here is how to get list / all layers
Sub list_layers()
Dim LAYER As AcadLayer
For Each LAYER In ThisDrawing.LAYERS
Debug.Print LAYER.NAME
Next
End Sub
to make it run put the cursor inside the VBA IDE inside the code of list_layers andpress F5 or choose it from the VBA Macro list.
I have absolutely no experience programming in excel vba other than I wrote a function to add a data stamp to a barcode that was scanned in on our production line a few weeks back, mainly through trial and error.
Anyways, what I need help with right now is inventory is coming up and every item we have has a barcode and is usually scanned into notepad and then manually pulled into excel and "text to columns" is used. I found the excel split function and would like a little bit of help getting it to work with my scanned barcodes.
The data comes in in the format: 11111*A153333*11/30/11 plus a carriage return , where the * would be the delimiter. All the examples I've found don't seem to do anything, at all.
For example here is one I found on splitting at the " ", but nothing happens if I change it to *.
Sub splitText()
'splits Text active cell using * char as separator
Dim splitVals As Variant
Dim totalVals As Long
splitVals = Split(ActiveCell.Value, "*")
totalVals = UBound(splitVals)
Range(Cells(ActiveCell.Row, ActiveCell.Column + 1), Cells(ActiveCell.Row, ActiveCell.Column + 1 + totalVals)).Value = splitVals
End Sub
And this is applied in the Sheet1 code section, if that helps.
It really can't be this complicated, can it?
Edit: Trying to add in Vlookup to the vba.
So as I said below in the comments, I'm now working on getting the vlookup integrated into this, however it just returns N/A.
Here is the sub I wrote based on the link below
Public Sub vlook(ByRef codeCell As Range)
Dim result As String
Dim source As Worksheet
Dim destination As Worksheet
Set destination = ActiveWorkbook.Sheets("Inventory")
Set source = ActiveWorkbook.Sheets("Descriptions")
result = [Vlookup(destination!(codeCell.Row, D), source!A2:B1397, 2, FALSE)]
End Sub
And I was trying to call it right after the For loop in the worksheet change, and just created another for loop, does this/should this be a nested for loop?
Just adding the code to the VBA behind the worksheet won't actually cause it to get called. You need to handle the worksheet_change event. The following should help:
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Dim cell As Range
For Each cell In Target.Cells
If cell.Column = 1 Then SplitText cell
Next
Application.EnableEvents = True
End Sub
Public Sub SplitText(ByRef codeCell As Range)
'splits Text active cell using * char as separator
Dim splitVals As Variant
Dim totalVals As Long
splitVals = Split(codeCell.Value, "*")
totalVals = UBound(splitVals)
Range(Cells(codeCell.Row, codeCell.Column), Cells(codeCell.Row, codeCell.Column + totalVals)).Value = splitVals
End Sub
If you want to process the barcodes automatically on entering them, you need something like this (goes in the worksheet module).
Private Sub Worksheet_Change(ByVal Target As Range)
Dim splitVals As Variant
Dim c As Range, val As String
For Each c In Target.Cells
If c.Column = 1 Then 'optional: only process barcodes if in ColA
val = Trim(c.Value)
If InStr(val, "*") > 0 Then
splitVals = Split(val, "*")
c.Offset(0, 1).Resize( _
1, (UBound(splitVals) - LBound(splitVals)) + 1 _
).Value = splitVals
End If
End If 'in ColA
Next c
End Sub
I have 2 workbooks that contain the same macro. In one workbook the macro runs super fast, less than a second. In the other it takes almost 30 seconds to run. I'm using Excel 2003. The page breaks are off in both workbooks. I don't know what could be causing one to run slower than the other. Any ideas?
Sub viewFirst()
Dim dataSheet As Worksheet, inputSheet As Worksheet, projectID As Long
Dim projectRow As Long, lLastRec As Long, inputLastRow As Long, dataLastRow As Long, x As Long, sh As Shape
Worksheets("Input").Select
ActiveSheet.Protect "", UserInterfaceOnly:=True
Range("a1").Select
ActiveSheet.Pictures.Insert ("working.jpg")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Set inputSheet = Worksheets("Input")
Set dataSheet = Worksheets("Database")
With inputSheet
inputLastRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row - 1
End With
With dataSheet
dataLastRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row - 1
lLastRec = dataLastRow - 1
End With
With inputSheet
.Range("currentProject").Value = 1
projectID = .Range("currentProject").Value
projectRow = projectID + 1
For x = 1 To inputLastRow
If Range("b" & x).HasFormula Then
x = x + 1
End If
If x > inputLastRow Then
Exit For
End If
If Not Range("b" & x).HasFormula Then
.Range("b" & x).Value = dataSheet.Cells(projectRow, 2 + x)
End If
Next x
.Range("d125").Value = dataSheet.Cells(projectRow, 2 + 149)
.Range("d128").Value = dataSheet.Cells(projectRow, 2 + 150)
.Range("d131").Value = dataSheet.Cells(projectRow, 2 + 151)
.Range("d134").Value = dataSheet.Cells(projectRow, 2 + 152)
.Range("d137").Value = dataSheet.Cells(projectRow, 2 + 153)
.Range("d140").Value = dataSheet.Cells(projectRow, 2 + 154)
End With
With ActiveSheet
For Each sh In .Shapes
If sh.Type = msoPicture Then
ActiveSheet.Unprotect ""
sh.Delete
ActiveSheet.Protect "", UserInterfaceOnly:=True
End If
Next sh
End With
Range("b5").Select
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
-EDIT-
osknows, thanks for the response. Just to clarify, the workbooks are never open at the same time, and again the workbooks are identical except for the data on the dataSheet - the dataSheet where the macro runs slowly has 35 Rows x 204 Columns, the dataSheet that runs quickly has 56 Rows X 156 Columns. I am going to search for hidden columns or non-blank cells on the input sheet.
Without seeing the 2 workbooks it's difficult to tell. The best advice is to measure exactly the speed of your code by...
In a module decare
Public Declare Function GetTickCount Lib "kernel32" () As Long
then in your code between certain lines of code place
dtStart = GetTickCount
dtline2 = GetTickCount
dtline3 = GetTickCount
dtline4 = GetTickCount
..
etc
the number of ticks between dtStart and dtline2 equals dtline2 - stStart etc
Also a number of factors that could slow things down:
inputLastRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row - 1
could include many rows that seem blank but aren't.
Set inputSheet = Worksheets("Input") & Set dataSheet = Worksheets("Database") may be massive complex ranges
For Each sh In .Shapes could include many duplicate shapes over each other that look identical
You have undefined ranges & sheets that if you have multiple workbooks open and using them while code runs then workbooks/worksheets/ranges are not explicitly defined. (Eg .Range versus Range) Get into the habit of using the full path to a range Filepath/Workbook/Sheet/Range or cell etc using With statements
eg
With ThisWorkbook
With SheetXYZ
With .range("XYZ1")
End with
End With
End With
or
With ThisWorkbook
With SheetXYZ.range("XYZ1")
.formula = "=Now()"
End With
End With
Also check out this handy site Excel Pages
On the slower machine, unload any Add-ins. If you have an add-in with a global change event, that will fire every time any worksheet changes, and could be causing the slow down. You're writing to the spreadsheet quite a bit, so it would be called a lot.
Instead of writing cell-by-cell, consider building an array (2-dimensions, lower bound of 1) and write all the data to the cell in one big swoop. Here's an example of how that works
Sub WriteOnce()
Dim aReturn() As Double
Dim i As Long, j As Long
Const lLASTROW As Long = 10
Const lLASTCOL As Long = 5
ReDim aReturn(1 To lLASTROW, 1 To lLASTCOL)
For i = 1 To lLASTROW
For j = 1 To lLASTCOL
aReturn(i, j) = Rnd
Next j
Next i
Sheet1.Range("A1").Resize(UBound(aReturn, 1), UBound(aReturn, 2)).Value = aReturn
End Sub
Since I'm only accessing the worksheet once, any event handlers will only fire once.