I have an Add button in the dialog form to add items, its quantity, price , currency and list in the field below. There is a currency field in the form. it is a drop down list with many currencies. The currency should be same on adding the items. if there is currency change, message box should appear. below is the part of the code for add button event. "cur" is the currency field.
Sub Click(Source As Button)
'On Error Goto errhandle
Dim work As New notesuiworkspace
Dim uidoc As notesuidocument
Dim doc As notesdocument
Dim item As String, weight As String
Dim qty As String, price As String
Dim sbtotal As String
Dim gtotal As String
Set uidoc = work.currentdocument
Set doc =uidoc.Document
item = uidoc.FieldGetText("Item")
qty = uidoc.FieldGetText("Qty")
price = uidoc.FieldGetText("Price")
cur = uidoc.FieldGetText("cur")
sbtotal= uidoc.FieldGetText("SubTotal")
Call uidoc.Refresh
'weight = uidoc.FieldGetText("W_Qty")
'adj = uidoc.fieldGetText("Adj")
remark = uidoc.FieldGetText("Remarks")
If item = "" Or qty = "" Or price = "" Then
Msgbox "Please complete the data entry ", 16, "Error - Incomplete Data Entry"
Exit Sub
End If
recordNo = uidoc.fieldgettext("ww")
If recordNo = "" Then
recordNumber = 0
Else
pos = Instr(recordNo,";")
If pos > 0 Then
number = Right(recordNo , pos -1)
Else
number = Left(recordNo , pos +1)
End If
recordNumber = Cint(number)
End If
recordNumber = recordNumber + 1
'to append text
Call uidoc.FieldAppendText("no" ,";" & Cstr(recordNumber))
Call uidoc.FieldAppendText("Item1" ,";" & item)
Call uidoc.FieldAppendText("Q1" , ";" & Cstr(qty))
Call uidoc.FieldAppendText("amt" , ";" & Cdbl(price))
Call uidoc.FieldAppendText("C1" , ";" & Cstr(cur))
Call uidoc.FieldAppendText("TSubTotal" , ";" & Cdbl(sbtotal))
'clear entering data
uidoc.FieldClear("Remarks")
uidoc.FieldClear("Item")
uidoc.FieldClear("Qty")
uidoc.FieldClear("Price")
'uidoc.FieldClear("W_Qty")
Call uidoc.FieldSetText("SubTotal","0.00")
uidoc.refresh
Dim subtotal As Double
subtotal = 0
Forall stotal In doc.TSubTotal
If stotal <> "" Then
subtotal = subtotal + Cdbl(stotal)
End If
End Forall
total = subtotal '+ Cdbl(curdoc.SubTotal(0))
Call uidoc.FieldSetText("GrandTotal",Format(total,"#,##0.00"))
uidoc.refresh
uidoc.gotofield"Item"
End Sub
Please help me. Thanks.
Create a new hidden field called selectedCurrency. The initial value of this field should be empty.
In your Add button code, you need to first check selectedCurrency, and if it is blank you should set it equal to cur.
Then, also in the code for the Add button, you need to compare selectedCurrency and cur, and if they are not equal you should display your message box.
I'd fix the currency outside the code for the Add button, and also make it required before Add can be started.
Related
I'm trying to link shape data field from external data like excel.
As #JohnGoldsmith suggested I used DropLinked but "I'm getting object name not found" error.
My main agenda is drop multiple shapes on drawing with shape data field "Name", then fill all the shape data field using external data in order. I also used spatial search for dropping shapes on drawing(Thanks to #Surrogate). By the way I'm using Visio Professional 2019.
It's often a good plan to separate chained members so you can identify whether (as #Paul points out) you're having a problem getting to the stencil or the master.
Following is a modified example of link shapes to data. I've ditched all of the spatial search stuff as I think that's a separate issue. If you still have trouble with that I would ask another question and narrow your sample code to not include the data linking part - ie just drop shapes and try and change their position. Bear in mind there's also Page.Layout and Selection.Layout
I think you've got the adding the DataRecordsets in the other linked question, so this example makes the following assumptions:
You have a drawing document open
You have the "Basic Shapes" stencil open (note my version is metric "_M")
You have a DataRecordset applied to the document named "AllNames"
The above record set has a column named "Name" that contains the data you want to link
Public Sub ModifiedDropLinked_Example()
Const RECORDSET_NAME = "AllNames"
Const COL_NAME = "Name"
Const STENCIL_NAME = "BASIC_M.vssx"
Const MASTER_NAME = "Rectangle"
Dim vDoc As Visio.Document
Set vDoc = Application.ActiveDocument
Dim vPag As Visio.Page
Set vPag = Application.ActivePage
Dim vShp As Visio.Shape
Dim vMst As Visio.Master
Dim x As Double
Dim y As Double
Dim xOffset As Double
Dim dataRowIDs() As Long
Dim row As Long
Dim col As Long
Dim rowData As Variant
Dim recordset As Visio.DataRecordset
Dim recordsetCount As Integer
For Each recordset In vDoc.DataRecordsets
If recordset.Name = RECORDSET_NAME Then
dataRowIDs = recordset.GetDataRowIDs("")
xOffset = 2
x = 0
y = 2
Dim vStencil As Visio.Document
Set vStencil = TryFindDocument(STENCIL_NAME)
If Not vStencil Is Nothing Then
Set vMst = TryFindMaster(vStencil, MASTER_NAME)
If Not vMst Is Nothing Then
For row = LBound(dataRowIDs) + 1 To UBound(dataRowIDs) + 1
rowData = recordset.GetRowData(row)
For col = LBound(rowData) To UBound(rowData)
Set vShp = vPag.DropLinked(vMst, x + (xOffset * row), y, recordset.ID, row, False)
Debug.Print "Linked shape ID " & vShp.ID & " to row " & row & " (" & rowData(col) & ")"
Next col
Next row
Else
Debug.Print "Unable to find master '" & MASTER_NAME & "'"
End If
Else
Debug.Print "Unable to find stencil '" & STENCIL_NAME & "'"
End If
Else
Debug.Print "Unable to find DataRecordset '" & RECORDSET_NAME & "'"
End If
Next
End Sub
Private Function TryFindDocument(docName As String) As Visio.Document
Dim vDoc As Visio.Document
For Each vDoc In Application.Documents
If StrComp(vDoc.Name, docName, vbTextCompare) = 0 Then
Set TryFindDocument = vDoc
Exit Function
End If
Next
Set TryFindDocument = Nothing
End Function
Private Function TryFindMaster(ByRef vDoc As Visio.Document, mstNameU As String) As Visio.Master
Dim vMst As Visio.Master
For Each vMst In vDoc.Masters
If StrComp(vMst.NameU, mstNameU, vbTextCompare) = 0 Then
Set TryFindMaster = vMst
Exit Function
End If
Next
Set TryFindMaster = Nothing
End Function
The above code drops six shapes onto the page and adds a Shape Data row (Prop._VisDM_Name) with the corresponding data value. If you want the name text to appear in the shape then you would normally modify the master with an inserted field in the shape's text. (If you get stuck with this part then ask another question.)
One last point is that this example loops through the DataRecordset rows dropping a shape for each one, but there is also a Page.DropManyLinkedU method that allows you to this en masse.
I am working on an Excel Userform to generate a report for a lot entered on a given day.
The report is stored in a Word document which contains the results of between 1 and 8 quality samples (number of samples varies by lot).
The Userform is meant to load in Excel, receive a lot number and date from the user, retrieve samples from that day and lot from a different sheet in the Excel workbook and then copy the data into a new Word doc based on a custom template.
The input part of the Userform and the Word template are both set up. I hit a snag on the event handling procedure for the "OK" button.
The form's OK button event handler gives
compile error
on
Sub makeReport(lNum As Integer, pDay As Date)
The editor isn't indicating an issue in my makeReport method; the call to makeReport in the event handler is highlighted red.
I am using the Excel 2013 VBA editor, and neither the built-in debugging tools in Excel, the Microsoft online VBA docs nor various forum posts found via Google can give me a complete answer to what is wrong and how to fix it.
OK Button event handler
Private Sub OKButton_Click() 'OK button
'Declare variables
Dim lNum As Integer
Dim pDay As Date
Dim name As String
Dim nStr As String
Dim dStr As String
'Error handler for incorrect input of lot number or pack date
On Error GoTo ErrorHandler
'Convert input values to correct types
nStr = TextBox1.Value
dStr = TextBox2.Value
'Set variable values
lNum = CInt(nStr)
MsgBox ("Step 1 Done" + vbCrLf + "Lot Number: " + nStr)
pDay = Format(dStr, "mm/dd/yyyy")
MsgBox ("Step 2 Done" + vbCrLf + "Pack Date: " + dStr)
name = nameDoc(pDay, lNum)
MsgBox ("Step 3 Done" + vbCrLf + "Report Name: " + name)
'Check for existing report
If Dir("\\CORE\Miscellaneous\Quality\Sample Reports\" + name) Then
MsgBox ("The file " + name + "already exists. Check \\CORE\Miscellaneous\Quality\Sample Reports for the report.")
Unload UserForm1
Exit Sub
Else
makeReport(lNum, pDay)
End If
'Unload User Form and clean up
Unload UserForm1
Exit Sub
ErrorHandler:
MsgBox ("Error. Please Try Again.")
'Unload UserForm1
End Sub
makeReport sub
Sub makeReport(lNum As Integer, pDay As Date)
'Template Path: \\CORE\Miscellaneous\Quality\Sample Reports\Template\Defect Report.dotm
'Save path for finished report: \\CORE\Miscellaneous\Quality\Sample Reports
'Generate doc name
Dim name As String
name = nameDoc(pDay, lNum)
'Initialize word objects and open word
Dim wApp As Word.Application
Dim wDoc As Word.Document
Set wApp = CreateObject("Word.Application")
wApp.Visible = True
Set wDoc = wApp.Documents.Add(Template:=("\\CORE\Miscellaneous\Quality\Sample Reports\Template\Defect Report.dotm"), NewTemplate:=False, DocumentType:=0)
'Initialize excel objects
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets("Defect Table")
'Fill in lot number and date at top of report
With wDoc
.Application.Selection.Find.Text = "<<date>>"
.Application.Selection.Find.Execute
.Application.Selection = pDay
.Application.Selection.EndOf
.Application.Selection.Find.Text = "<<lot>>"
.Application.Selection.Find.Execute
.Application.Selection = lNum
End With
'Initialize loop variables
Dim row1 As Integer
Dim row2 As Integer
Dim diff As Integer
Dim more As Boolean
Dim num As Integer, num1 As Integer, col As Integer
Dim count As Integer
count = 0
diff = 0
more = False
'Do while loop allows variable number of samples per day
Do While count < 8
'Checks for correct starting row of day
row1 = WorksheetFunction.Match(lNum, wsSheet.Range(), 0)
row2 = WorksheetFunction.Match(pDay, wsSheet.Range(), 0)
If IsError(row1) Or IsError(row2) Then
'Breaks for loop once all samples have been copied over
Exit Do
ElseIf row1 = row2 Then
num = 4
num1 = num
Do While num < 31
'Column variable
col = count + 1
'Copies data to word doc, accounting for blank rows in the word table
Select Case num
Case 6, 10, 16, 22, 30
num1 = num1 + 1
Case Else
num1 = num1
End Select
ActiveDocument.Tables(1).Cell(num1, col) = ActiveSheet.Range().Cells(row1, num)
num = num + 1
Next
Else
'Deiterates count to adjust for differences between row1 and row2
count = count - 1
End If
'Moves the collision to below row1 to allow MATCH to find next viable result
diff = row1 + 1
wsSheet = wsSheet.Range().Offset(diff, 0)
'Iterates count
count = count + 1
Loop
'Zeroes out word objects
Set wdDoc = Nothing
Set wdApp = Nothing
'Saves Document using regular name format for ease of access
wDoc.SaveAs2 Filename:="\\CORE\Miscellaneous\Quality\Sample Reports\" + name, FileFormat:=wdFormatDocumentDefault, AddtoRecentFiles:=False
End Sub
makeReport(lNum, pDay)
The brackets here imply that you are expecting something to be returned which can't happen as makeReport is a Sub not a Function. This is causing the compile error. To correct just remove the brackets.
You also have an additional problem as there is a mismatch with pDay. When you format a date you convert it from a Date, which is just a numeric value, into a String.
In OKButton_Click() try changing:
pDay = Format(dStr, "mm/dd/yyyy")
to:
pDay = CDate(dStr)
so that it matches the data type expected by makeReport. You can then apply the required formatting in makeReport by changing
.Application.Selection = pDay
to
.Application.Selection = Format(pDay, "mm/dd/yyyy")
I am running a search from Excel to get objects Internal ID's by External ID. In ThisWorkbook.Sheets("Other Data").Range("J30").Value I have External ID f5f9a21b-9208-de11-995f-005056bb3dfa. After search code should display Internal ID.
This one works and I am getting a message:
There were 3 objects with the display Id of f5f9a21b-9208-de11-995f-005056bb3dfa
How I can make this code to actually display these ID's for example starting from cell A1?
So instead of just a message:
MsgBox ("There were " & results.Count & " objects with the display Id of" & ThisWorkbook.Sheets("Other Data").Range("J30").Value)
I would get the ID's in Excel? Basically I need results.Count not to count items but input them to Excel.
Code edited according to suggestion, but debugger is pointing to ThisWorkbook.Sheets("Start").Cells(i, 1).Value = results(i)
Private Sub SurroundingSub()
Set oVault = oMFClientApp.BindToVault(szVaultName, 0, True, True)
' Create the condition.
Dim condition As New SearchCondition
Dim oScs: Set oScs = CreateObject("MFilesAPI.SearchConditions")
Dim oVaultConnections As MFilesAPI.VaultConnections
Dim i As Integer
' Set the expression.
condition.Expression.DataStatusValueType = MFStatusType.MFStatusTypeExtID
' Set the condition type.
condition.ConditionType = MFConditionType.MFConditionTypeEqual
' Set the value.
' In this case "MyExternalObjectId" is the ID of the object in the remote system.
condition.TypedValue.SetValue MFDataType.MFDatatypeText, ThisWorkbook.Sheets("Other Data").Range("J30").Value
'Add the condition to the collection.
oScs.Add -1, condition
'Search.
Dim results 'As ObjectSearchResults
Set results = oVault.ObjectSearchOperations.SearchForObjectsByConditions(oScs, MFSearchFlags.MFSearchFlagNone, False) ' False = SortResults
'Output the number of items matching (should be one in each object type, at a maximum).
'MsgBox ("There were " & results.Count & " objects with the display Id of" & ThisWorkbook.Sheets("Other Data").Range("J30").Value)
For i = 1 To results.Count
ThisWorkbook.Sheets("Start").Cells(i, 1).Value = results[i]
Next i
End Sub
EDIT 2
Also () does not work:
If you're looking for a quick and direct way try this:
For i = 1 To results.Count
Cells(i, 1).Value = results(i - 1)
Next i
Tip: Cells(row, column)
I have a form. The form fields are validated in the querysave event. The validation goes like this. I have some fields to be validated for its presence during save. i.e., when i click a check box and dont enter the details in its field, it should show a error message box while saving. The validation works fine for a new document. My question is
how to make it work for both new document and edit mode?
The error message is not getting displayed the second time when i click on save.i.e., when i click ok in the messagebox, dont enter data and click save, its getting saved. how to make it check for validation everytime when clicked on save.
Kindly help me. Please dont mind if my questions are obvious and simple because i m a fresher. Thanks in advance.
The script goes below,
The first part calculating ref num for new docs and secong part validating fields,
Sub Querysave(Source As Notesuidocument, Continue As Variant)
Dim w As New notesuiworkspace
Dim uidoc As notesuidocument
Set uidoc = w.CurrentDocument
Dim SESS As New NotesSession
Dim Doc As NotesDocument
Dim RefView As NotesView
Dim DB As NotesDatabase
Dim RefDoc As NotesDocument
Set DB = SESS.CurrentDatabase
Set Doc = uidoc.Document
Set RefView = DB.GetView("System\AutoNo")
If uidoc.IsNewDoc = True Then
Financial_year = Clng(Right$(Cstr(Year(Now)),3)) + 104
If Month(Now) >= 4 Then Financial_year = Financial_year + 1
Application = "ST"
DefKey$ = Cstr(Financial_year)
DefNo& = 0
Set RefDoc = RefView.GetDocumentByKey(DefKey$ , True)
If Not(RefDoc Is Nothing) Then DefNo& = Clng(Right$(RefDoc.SETTLEMENT_NO(0),5))
DefNo& = DefNo& + 1
RefNo$ = (Application + DefKey$) & "-" & Right$("00000" & Cstr(DefNo&) ,5)
Doc.SETTLEMENT_NO= RefNo$
Doc.FinFlag="Finish"
Call SESS.SetEnvironmentVar("ENV_SETT",Right$("00000" & Cstr(DefNo&) ,5))
Call uidoc.Refresh
Else
Exit Sub
End If
get_ex_rate
get_cv_local
set_flag
Dim answer2 As Integer
answer2% = Msgbox("Do you want to save this document?", 1, "Save")
If answer2 = 1 Then
Petro$= uidoc.FieldGetText("Park_Petro_Car")
Vehicle$= uidoc.FieldGetText("Vehicle_No")
Gifts$ = uidoc.FieldGetText("Gifts")
Gifts_Ent$ = uidoc.FieldGetText("Gifts_Ent")
Medical$ = uidoc.FieldGetText("Medical")
Medical_Fee$ = uidoc.FieldGetText("Medical_Fee")
Others$= uidoc.FieldGetText("Others")
OS$= uidoc.FieldGetText("Others_Specify")
Taxi$ = uidoc.FieldGetText("Taxi")
Taxi_Fee$ = uidoc.FieldGetText("Taxi_Fee")
If Petro$ <> "" And Vehicle$ = "" Then
Msgbox "Please enter Vehicle No" , 16, "Vehicle No"
Else
If Gifts$ <> "" And Gifts_Ent$ = "" Then
Msgbox "Please enter Guest/Co.Name" , 16, "Guest/Co.Name"
Else
If Medical$ <> "" And Medical_Fee$ = "" Then
Msgbox "Please enter Medical_Fee" , 16, "Medical_Fee"
Else
If Taxi$ <> "" And Taxi_Fee$ = "" Then
Msgbox "Please enter Taxi Fee" , 16, "Taxi Fee"
Else
If Others$ <> "" And OS$ = "" Then
Msgbox "Please enter Others(Specify)" , 16, "Others (Specify)"
End If
End If
End If
End If
End If
End If
If answer2 = 2 Then
continue=False
Exit Sub
End If
uidoc.Refresh
'uidoc.close
End Sub
Remove the Else from your first IF Statement, otherwise the validation only runs once, when IsNewDoc returns True, once the doc has been saved once it will return False and your QuerySave Subroutine exits.
ELSE
Exit Sub <-- remove this, your validation code only runs once per document.
End IF
Thanks for adding the code.
With the "If uidoc.IsNewDoc = True Then" you explicitly tell the code to only run when the document is new.
So either add an appropriate elseif branch or get rid of the if itself and modify the validation accordingly so it applies to new and modified documents.
Good day,
I'll start by saying I work for a small company and have no official training in
Notes everything I know I've learned buy trial and error & using other peoples codes.
Application: We have a purchase order database that has been running for a very long time and threw the ages people put in supplier names diffirently. Now I found a code that goes into the selected forms and changes the field values which is exactly what I need the only problem
is it's single line. The field I want to update have about 5 text lines (Company name, Tel No etc..) and the original programer put all off the info in one field.
Question: Is there a way in the script linked below how I can make each prompt input go into a diffirent line.I tried a few thing and I think I may be missing something obvious.(If I try chr(10);chLv all I get is either the 2 values next to each other or get them seperated by a comma)
`
Sub Initialize
Dim ws As New NotesUIWorkspace
Dim session As New NotesSession
Dim prompt As String
Dim fieldName As String
Dim fieldValue As String
Dim dataTypes As Variant
Dim thisDataType As String
Dim fieldValues As Variant
Dim newFieldValues As Variant
Dim db As NotesDatabase
Dim coll As NotesDocumentCollection
Dim i As Integer
Dim doc As NotesDocument
Dim item As NotesItem
prompt = "Please enter the name of the field to be updated"
fieldName = ws.Prompt(3, "Enter Field Name", prompt, "")
If fieldName = "" Then Exit Sub
If Instr(fieldName, " ") <> 0 Then
prompt = "Error! Field Names can't have spaces!"
Msgbox prompt, 16, "Error"
Exit Sub
End If
prompt = "Please enter the new value. For multiple values, separate with a colon."
Value1 =ws.Prompt(3, "Enter Field Value", prompt, "")
Value2= ws.Prompt(3, "Enter Field Value", prompt, "")
Fieldvalue=value1 + Chr(10) +value2
Redim dataTypes(5) As String
dataTypes(0) = "Text"
dataTypes(1) = "Number"
dataTypes(2) = "Date"
dataTypes(3) = "Readers"
dataTypes(4) = "Authors"
dataTypes(5) = "DELETE THIS FIELD"
prompt = "Choose the data type of the value(s)"
thisDataType = ws.Prompt(4, "Choose Data Type", prompt, dataTypes(0), dataTypes)
If thisDataType = "" Then Exit Sub
Set db = session.CurrentDatabase
Set coll = db.UnprocessedDocuments
fieldValues = Evaluate({#Explode("} & fieldValue & {"; ":")})
Select Case thisDataType
Case dataTypes(0) : Redim newFieldValues(Ubound(fieldValues)) As String
Case dataTypes(1) : Redim newFieldValues(Ubound(fieldValues)) As Double
Case dataTypes(2) : Redim newFieldValues(Ubound(fieldValues)) As Variant
Case dataTypes(3) : Redim newFieldValues(Ubound(fieldValues)) As String
Case dataTypes(4) : Redim newFieldValues(Ubound(fieldValues)) As String
End Select
For i = Lbound(fieldValues) To Ubound(fieldValues)
Select Case thisDataType
Case dataTypes(0) : newFieldValues(i) = Trim(fieldValues(i))
Case dataTypes(1) : newFieldValues(i) = Val(fieldValues(i))
Case dataTypes(2) : newFieldValues(i) = Cdat(fieldValues(i))
Case dataTypes(3) : newFieldValues(i) = Trim(fieldValues(i))
Case dataTypes(4) : newFieldValues(i) = Trim(fieldValues(i))
End Select
Next
Set doc = coll.GetFirstDocument
While Not doc Is Nothing
If thisDataType = "DELETE THIS FIELD" Then
If doc.HasItem(fieldName) Then Call doc.RemoveItem(fieldName)
Else
Call doc.ReplaceItemValue(fieldName, newFieldValues)
If thisDataType = dataTypes(3) Or thisDataType = dataTypes(4) Then
Set item = doc.GetFirstItem(fieldName)
If thisDataType = dataTypes(3) Then item.IsReaders = True
If thisDataType = dataTypes(4) Then item.IsAuthors = True
End If
End If
Call doc.Save(True, False)
Set doc = coll.GetNextDocument(doc)
Wend
End Sub
'
Sorry for the long post but wasn't sure what is needed. First time posting for help but I'm scared I missed something opposite.
Francois
If you don't care that the values are not actually seperate, but are in fact a single string seperated by newlines, you could try evaluating Field fieldname:=#implode(fieldname, #newline) There was a bug (now fixed) in the java api where using java newline chars \n did not translate through to the stored value. Having the field set via evaluating an #formula was a workaround.
It's possible (?) that there is a platform specific issue to using Chr(10). Have you tried using Chr(13) & Chr(10)? You coudl also try evaluating #newline and using what that gives you.
To display the values in separate lines within a field you have to open the field properties and on the 3rd Tab make sure the option "Display separate values with" is set to "New Line".
On another note the split function in lotusscript is the equivalent to the #explode, so this line:
fieldValues = Evaluate({#Explode("} & fieldValue & {"; ":")})
can be modified to the following:
fieldValues = split(fieldValue, ":")
Hope that helps.