Content Control not recognizing content - vba

I was hoping someone could help me work out why the the 'F' value in my code below continues to include my error label in the ErrorMessage String when the Count value is 5?
In the document, the content control contains text just like all the other controls (which work perfectly) but this content Control text value is not being recognised in the VBA code to map error labels.
Have tried just replacing the control and checking the properties match. Debug messages suggest the the value is just being set to the default Content Control Value of "Click or Tap here to input text".
Private Sub Create_Click()
Dim oCC As ContentControl
Dim oCC2 As ContentControl
Dim Mandatory(9) As String
Dim ErrorMessage As String
Dim ErrorCount As Integer
Dim ErrorLabel(9) As String
Dim objDoc As Document
Dim strFilename As String
Dim strFileString As String
Dim Number As String
Mandatory(0) = "A"
Mandatory(1) = "B"
Mandatory(2) = "C"
Mandatory(3) = "D"
Mandatory(4) = "E"
Mandatory(5) = "F"
Mandatory(6) = "G"
Mandatory(7) = "H"
Mandatory(8) = "I"
ErrorLabel(0) = "A Label"
ErrorLabel(1) = "B Label"
ErrorLabel(2) = "C Label"
ErrorLabel(3) = "D Label"
ErrorLabel(4) = "E Label"
ErrorLabel(5) = "F Label"
ErrorLabel(6) = "G Label"
ErrorLabel(7) = "H Label"
ErrorLabel(8) = "I Label"
ErrorMessage = ""
ErrorMessage = "The following mandatory fields are missing: "
For Count = 0 To 8
Set oCC = ActiveDocument.SelectContentControlsByTitle(Mandatory(Count)).Item(1)
MsgBox (oCC.Range.Text)
If Count = 0 Then
Number = ActiveDocument.SelectContentControlsByTitle(Mandatory(Count)).Item(1).Range.Text
End If
If oCC.Range.Text = "Click or tap here to enter text." Or oCC.Range.Text = "0.00" Then
ErrorMessage = ErrorMessage & vbCrLf & vbCrLf & "- " & ErrorLabel(Count)
MsgBox (oCC.Range.Text)
ErrorCount = ErrorCount + 1
End If
Next Count
If ErrorCount > 0 Then
MsgBox (ErrorMessage)
Else
strFileString = Number
MsgBox (strFileString)
strFilename = "Some Text Here" & " - " & strFileString & ".pdf"
With ActiveDocument
NewPath = .Path & "\" & strFilename
.SaveAs2 FileName:=NewPath, FileFormat:=wdFormatPDF
.ExportAsFixedFormat OutputFileName:=strFilename, ExportFormat:=wdExportFormatPDF, _
OpenAfterExport:=True, OptimizeFor:=wdExportOptimizeForPrint, _
Range:=wdExportAllDocument, Item:=wdExportDocumentContent
End With
End If
End Sub

Check there are no other content controls with the same title in the document.

I couldn't test your code for lack of data but from your description I guess that the ErrorMessage must be reset with each loop since it will be changed when used and would naturally retain the modified version thereafter.
Except for what follows the loop, I looked closely at your code in order to understand it. Perhaps, the changes I made will be of some use to you.
Option Explicit
Private Sub Create_Click()
Dim Doc As Document
Dim Mandatory() As String
Dim ErrorMessage As String
Dim ErrorCount As Integer
Dim strFilename As String
Dim strFileString As String ' this appears identical with 'Number'
Dim Number As String
Dim Count As Integer ' loop counter
Set Doc = ActiveDocument
Mandatory = Split("A B C D E F G H I")
Number = Doc.SelectContentControlsByTitle(Mandatory(0))(1).Range.Text
For Count = 1 To UBound(Mandatory) + 1
ErrorMessage = "The following mandatory fields are missing: "
With Doc.SelectContentControlsByTitle(Mandatory(Count))(1).Range
MsgBox "Number = " & Number & vbCr & .Text
If .Text = "Click or tap here to enter text." Or _
.Text = "0.00" Then
ErrorMessage = ErrorMessage & vbCrLf & vbCrLf & "- " & Mandatory(Count) & " Label"
MsgBox (.Text)
ErrorCount = ErrorCount + 1
End If
End With
If Count = 1 Then Exit For
Next Count
If ErrorCount > 0 Then
MsgBox (ErrorMessage)
Else
strFileString = Number
MsgBox (strFileString)
strFilename = "Some Text Here" & " - " & strFileString & ".pdf"
With Doc
NewPath = .Path & "\" & strFilename
.SaveAs2 FileName:=NewPath, FileFormat:=wdFormatPDF
.ExportAsFixedFormat OutputFileName:=strFilename, _
ExportFormat:=wdExportFormatPDF, _
OpenAfterExport:=True, _
OptimizeFor:=wdExportOptimizeForPrint, _
Range:=wdExportAllDocument, _
Item:=wdExportDocumentContent
End With
End If
End Sub
You can have VBA add the useful (some would say necessary) Option Explicit to all new code modules automatically. Select Tools > Options in the VBE window and check "Require Variable Declaration" on the Editor tab.

Related

vba macro display result of loop to msgbox

I creted a loop checking number of characters length with conditions but sadly it's not properly working,
with approriate no. of loops but not reading the next line, I want to post the result in a MsgBox,
but when I use the msgbox inside the loop I will get a msgbox for every result found or only one msgbox with one result.
What I would like is to display every result in 1 msgbox with a line vbNewLine after each result.
Below is my code:
Public Sub Rs()
Dim Text As String
Dim NumChar As String
Dim i As Integer
Dim NumRows As Long
Application.ScreenUpdating = False
'Get Cell Value
Text = Range("B2").Value
'Get Char Length
NumChar = Len(Text)
NumRows = Range("B2", Range("B2").End(xlDown)).Rows.Count
Range("B2").Select
For i = 1 To NumRows
'Character length validation
If Len(Text) <= 15 Then
MsgBox Chr(149) & " SVC_DESC " & Text & " has " & NumChar & " characters " & " and it's Valid !" & vbNewLine
Else
MsgBox Chr(149) & " SVC_DESC " & Text & " has " & NumChar & " characters " & " and Exceeded allowable number of characters!" & vbNewLine
End If
Next i
Application.ScreenUpdating = True
End Sub
Assign the new text to a string variable and display the string variable outside the loop:
Option Explicit
Sub TestMe()
Dim i As Long
Dim displayText As String
For i = 1 To 3
displayText = displayText & vbCrLf & i
Next i
MsgBox displayText
End Sub
Build a string through concatenation and display the strings after exiting the loop.
Public Sub Rs()
Dim Text As String
Dim NumChar As String
Dim i As Integer
Dim NumRows As Long
dim msg1 as string, msg2 as string
Application.ScreenUpdating = False
'Get Cell Value
Text = Range("B2").Value
'Get Char Length
NumChar = Len(Text)
NumRows = Range("B2", Range("B2").End(xlDown)).Rows.Count
Range("B2").Select
For i = 1 To NumRows
'Character length validation
If Len(Text) <= 15 Then
msg1 = msg1 & Chr(149) & " SVC_DESC " & Text & " has " & NumChar & " characters " & " and it's Valid !" & vbLF
Else
msg2 = msg2 & Chr(149) & " SVC_DESC " & Text & " has " & NumChar & " characters " & " and Exceeded allowable number of characters!" & vbLF
End If
Next i
Application.ScreenUpdating = True
if cbool(len(msg1)) then
msg1 = left(msg1, len(msg1)-1)
MsgBox msg1
end if
if cbool(len(msg2)) then
msg2 = left(msg2, len(msg2)-1)
MsgBox msg2
end if
End Sub
A MsgBox uses Chr(10) aka vbLF for new lines; vbNewLine is overkill.

MS Access - VBA: Sending Email Using Email Addresses in Tables

Using MS Access VBA. Setup is as follows:
tblUsers contains UserID, UserName, UserSecurityLevel, UserEmail
tblStewards contains AreaID, AreaName, Stewards where Stewards is set to be a Combo Box from a Lookup Query "SELECT tblUsers.ID, tblUsers.UserName FROM tblUsers" and I allow multiple values (e.g., each area has multiple stewards); the Stewards field has a data type of short text
frmStewardRequest has Record Source tblStewards and is designed for a user to request that the area stewards add a new item; it contains cmbAreaName, txtStewards which autopopulates based on cmbAreaName with Control Source Stewards, some open text fields for supplying the requested item, and a btnSubmitRequest
for btnSubmitRequest, I have an On Click event that generates an email to the area stewards using this VBA code:
Dim strEmailTo As String
Dim strTxtBody As String
strEmailTo = DLookup("[UserEmail]", "tblUsers", "ID = " & Me.txtSteward)
strTxtBody = "I need a new item in " & Me.cmbAreaName & "..."
DoCmd.SendObject , , acFormatTXT, strEmailTo, , , "New Item Request", strTxtBody, False
There is a problem with getting the email addresses for the area stewards: it doesn't seem this is a string. How can I get the email addresses so this will send properly? (Less important question, is there a way to prevent the pop-up box to Accept the risk of sending this email?)
This is how I do it.
Option Compare Database
Option Explicit
' This database and all the code therein is © 1999-2002 Arvin Meyer arvinm#datastrat.com
' You are free to use this code and this database in an application
' as long as you do not publish it without the author's permission.
' Additionally, you are required to include this copyright notice in the application.
Private Sub Form_Open(Cancel As Integer)
On Error GoTo Err_OF
Dim db As Database
Dim i As Integer
Dim contr As Container
Dim strRptList As String
Dim strRptName As String
Dim Length As Integer
Set db = CurrentDb()
Set contr = db.Containers("Reports")
strRptList = ""
For i = 0 To contr.Documents.Count - 1
strRptName = contr.Documents(i).name
If strRptList <> "" Then strRptList = strRptList & "; "
Length = Len(strRptName)
strRptList = strRptList & strRptName
Next i
Me!lstRpt.RowSource = strRptList
Exit_OF:
Exit Sub
Err_OF:
MsgBox Err & " " & Error, , "Report Open"
Resume Exit_OF
End Sub
Private Sub cmdEmail_Click()
On Error GoTo Err_cmdEmail_Click
Dim strDocName As String
Dim strEmail As String
Dim strMailSubject As String
Dim strMsg As String
strDocName = Me.lstRpt
strEmail = Me.txtSelected & vbNullString
strMailSubject = Me.txtMailSubject & vbNullString
strMsg = Me.txtMsg & vbNullString & vbCrLf & vbCrLf & "Your Name" & _
vbCrLf & "MailTo:youremail#nowhere.com"
DoCmd.SendObject objecttype:=acSendReport, _
ObjectName:=strDocName, outputformat:=acFormatHTML, _
To:=strEmail, Subject:=strMailSubject, MessageText:=strMsg
Exit_cmdEmail_Click:
Exit Sub
Err_cmdEmail_Click:
MsgBox Err.Description
Resume Exit_cmdEmail_Click
End Sub
Private Sub Label15_Click()
Dim hplMail As String
hplMail = "#MailTo:email_senate#datastrat.com#"
Application.FollowHyperlink HyperlinkPart(hplMail, acAddress)
End Sub
Private Sub lstRpt_Click()
Me.cmdEmail.Enabled = True
End Sub
Private Sub lstMailTo_Click()
Dim varItem As Variant
Dim strList As String
With Me!lstMailTo
If .MultiSelect = 0 Then
Me!txtSelected = .Value
Else
For Each varItem In .ItemsSelected
strList = strList & .Column(0, varItem) & ";"
Next varItem
strList = Left$(strList, Len(strList) - 1)
Me!txtSelected = strList
End If
End With
End Sub
Table tblStewards Combo Box lookup query SELECT tblUsers.ID, tblUsers.UserName FROM tblUsers needs to be fixed since there is no ID but UserID
Have used the Split function to check for multiple Steward values and then get their email id using Dlookup
I prefer using MultiValued fields especially when lookup list is not huge (nothing wrong to use).
Dim strStewards As Variant
Dim i As Long
Dim strEmailTo As String
Dim strTxtBody As String
strStewards = Split(Me.txtSteward, ",")
For i = LBound(strStewards) To UBound(strStewards)
strEmailTo = strEmailTo & ";" & Nz(DLookup("[UserEmail]", "tblUsers", "UserID=" & strStewards(i)), "")
Next
strTxtBody = "I need a new item in " & Me.cmbAreaName & "..."
DoCmd.SendObject , , acFormatTXT, strEmailTo, , , "New Item Request", strTxtBody, False

Sharepoint version history in document via vba?

Here is my problem:
Duplicate versions
I checked the version history on the Sharepoint site and it doesn't show any duplicates.
Here is the code im using:
Sub versionhistory()
'
' versionhistory Macro
On Error Resume Next
' On Error GoTo message
Dim dlvVersions As Office.DocumentLibraryVersions
Dim dlvVersion As Office.DocumentLibraryVersion
Dim strVersionInfo As String
Set dlvVersions = ThisDocument.DocumentLibraryVersions
'MsgBox ActiveDocument.Bookmarks.Count
Dim tbl As Word.Table
'Set tbl = ActiveDocument.Tables.Item(2)
Set tbl = ActiveDocument.Bookmarks("VersionTable").Range.Tables(1)
If dlvVersions.IsVersioningEnabled Then
strVersionInfo = "This document has " & dlvVersions.Count & " versions: " & vbCrLf
Call InsertVersionHistory(tbl, dlvVersions)
For Each dlvVersion In dlvVersions
strVersionInfo = strVersionInfo & _
" - Version #: " & dlvVersion.Index & vbCrLf & _
" - Modified by: " & dlvVersion.ModifiedBy & vbCrLf & _
" - Modified on: " & dlvVersion.Modified & vbCrLf & _
" - Comments: " & dlvVersion.Comments & vbCrLf
Next
Else
strVersionInfo = "Versioning not enabled for this document."
End If
'MsgBox strVersionInfo, vbInformation + vbOKOnly, "Version Information"
Set dlvVersion = Nothing
Set dlvVersions = Nothing
Call GetUserName
'message:
'MsgBox Err.Description
MsgBox ("Insert Version Number in the Header and type a Title in the [Insert Title here] on the front page. It will be automatically updated in the footer." & vbNewLine & vbNewLine & "Do Not Type in the Review and Version tables.")
End Sub
Private Function InsertVersionHistory(oVerTbl As Word.Table, oVersions As Office.DocumentLibraryVersions)
Dim rowIndex As Integer
Dim oVersion As Office.DocumentLibraryVersion
Dim oNewRow As Row
'test
Dim versionIndex As Integer
For rowIndex = 2 To oVerTbl.Rows.Count
oVerTbl.Rows.Item(2).Delete
Next rowIndex
rowIndex = 1
'test
versionIndex = oVersions.Count
For Each oVersion In oVersions
If (rowIndex > 5) Then
Return
End If
rowIndex = rowIndex + 1
oVerTbl.Rows.Add
Set oNewRow = oVerTbl.Rows(oVerTbl.Rows.Count)
oNewRow.Shading.BackgroundPatternColor = wdColorWhite
oNewRow.Range.Font.TextColor = wdBlack
oNewRow.Range.Font.Name = "Tahoma"
oNewRow.Range.Font.Bold = False
oNewRow.Range.Font.Size = 12
oNewRow.Range.ParagraphFormat.SpaceAfter = 4
With oNewRow.Cells(1)
'.Range.Text = oVersion.Index
.Range.Text = versionIndex
End With
With oNewRow.Cells(2)
.Range.Text = FormUserFullName(GetUserFullName(oVersion.ModifiedBy))
End With
With oNewRow.Cells(3)
.Range.Text = oVersion.Modified
End With
With oNewRow.Cells(4)
.Range.Text = oVersion.Comments
End With
versionIndex = versionIndex - 1
Next
Set oVersion = Nothing
End Function
Function GetUserFullName(userName As String) As String
Dim WSHnet, UserDomain, objUser
Set WSHnet = CreateObject("WScript.Network")
'UserDomain = WSHnet.UserDomain
'Set objUser = GetObject("WinNT://" & UserDomain & "/" & userName & ",user")
userName = Replace(userName, "\", "/")
Set objUser = GetObject("WinNT://" & userName & ",user")
'MsgBox objUser.FullName
GetUserFullName = objUser.FullName
End Function
Function FormUserFullName(userName As String) As String
Dim arrUserName As Variant
Dim changedUserName As String
arrUserName = Split(userName, ",")
Dim length As Integer
length = UBound(arrUserName) - LBound(arrUserName) + 1
If length >= 2 Then
changedUserName = arrUserName(1) & " " & arrUserName(0)
Else
changedUserName = userName
End If
FormUserFullName = changedUserName
End Function
Private Function GetUserName()
Dim userName As String
userName = ActiveDocument.BuiltInDocumentProperties("Author")
ActiveDocument.BuiltInDocumentProperties("Author") = FormUserFullName(userName)
End Function
I know this is old, but I was looking for the same thing and found this article. I'm still trying it out, but wanted to share before I got distracted with my real job.
From: SixSigmaGuy on microsoft.public.sharepoint.development-and-programming.narkive.com/...
Wanted to share my findings, so far. Surprisingly, I could not find
anything in the SharePoint Designer object/class that supported versions,
but the Office, Word, Excel, and PowerPoint objects do support it.. It
wasn't easy to find, but once I found it, it works great, as long as the
file in the document library is one of the Office documents.
Here's some sample code, written in Excel VBA, showing how to get the
version information for a paritcular SharePoint Document Library file
created in Excel:
Public viRow As Long
Function fCheckVersions(stFilename As String) As Boolean
' stFilename is the full URL to a document in a Document Library.
'
Dim wb As Excel.Workbook
Dim dlvVersions As Office.DocumentLibraryVersions
Dim dlvVersion As Office.DocumentLibraryVersion
Dim stExtension As String
Dim iPosExt As Long
ThisWorkbook.Worksheets("Sheet1").Cells(viRow, 1) = stFilename
If Workbooks.CanCheckOut(stFilename) = True Then
Set wb = Workbooks.Open(stFilename, , True)
Set dlvVersions = wb.DocumentLibraryVersions
If dlvVersions.IsVersioningEnabled = True Then
ThisWorkbook.Worksheets("Sheet1").Cells(viRow, 3) = "Num
Versions = " & dlvVersions.Count
For Each dlvVersion In dlvVersions
ThisWorkbook.Worksheets("Sheet1").Cells(viRow, 4) = "Version: " & dlvVersion.Index
ThisWorkbook.Worksheets("Sheet1").Cells(viRow, 5) = "Modified Date: " & dlvVersion.Modified
ThisWorkbook.Worksheets("Sheet1").Cells(viRow, 6) = "Modified by: " & dlvVersion.ModifiedBy
ThisWorkbook.Worksheets("Sheet1").Cells(viRow, 7) = "Comments: " & dlvVersion.Comments
viRow = viRow + 1
Next dlvVersion
End If
wb.Close False
End If
Set wb = Nothing
DoEvents
End Function`
Fortunately, I discovered that Excel can open non-Excel files in most
cases. I.e., I can, for example, open a jpg file in Excel and use the
dlvVersions collection for that file.

lists in vb.net, struggling with structure

I'm having a bit of trouble with a list in vb.net.
Basically what I am trying to do is send an email and the user can select from 4 options to send a carbon copy to. I started out with a series of if statements checking to see if a checkbox was checked and if it was then it added it to CC, but that seems to only ever add one. So I created ccList, the idea is it creates a list of strings and adds that to cc instead. I'm not sure if it will work but if I add a break in the second, third or fourth if, it doesn't fall into it and only ever passes through the first (if every check box is true). If I only check one then it falls into that one correctly.
If FSEmailAddress <> "" Then
Dim OutlookMessage As outlook.MailItem
Dim AppOutlook As New outlook.Application
Dim ccList As List(Of String) = Nothing
Try
OutlookMessage = AppOutlook.CreateItem(outlook.OlItemType.olMailItem)
Dim Recipents As outlook.Recipients = OutlookMessage.Recipients
Recipents.Add(FSEmailAddress)
If email1.Checked = True Then
ccList.Add("email1#some.email.com")
End If
If email2.Checked = True Then
ccList.Add("email2#some.email.com; ")
End If
If email3.Checked = True Then
ccList.Add("email3#some.email.com; ")
End If
If email4.Checked = True Then
ccList.Add("email4#some.email.com; ")
End If
OutlookMessage.CC = ccList.ToString
OutlookMessage.Subject = responseVIN.Text & " was sent back to you by " & GetUserName()
'link = archive_dir & responseVIN.Text
OutlookMessage.Body = responseVIN.Text & " was returned To you" & vbCrLf & "Navigate To the following location To view the comments In the ReadMe file:" & vbCrLf & vbCrLf & archive_dir & responseVIN.Text & vbCrLf & vbCrLf & resAdvice.Text
OutlookMessage.BodyFormat = outlook.OlBodyFormat.olFormatHTML
OutlookMessage.Send()
For anybody interested:
Here is the solution to both of the problems I was having:
Dim FSEmailAddress As String = ""
Dim link As String = ""
Dim ccJoin As String = ""
If FSEngineerName = "Email 1" Then
FSEmailAddress = "email1#some.email.com"
ElseIf FSEngineerName = "Email 2" Then
FSEmailAddress = "email2#some.email.com"
ElseIf FSEngineerName = "Email 3" Then
FSEmailAddress = "email3#some.email.com"
ElseIf FSEngineerName = "Email 4" Then
FSEmailAddress = "email4#some.email.com"
End If
If FSEmailAddress <> "" Then
Dim OutlookMessage As outlook.MailItem
Dim AppOutlook As New outlook.Application
Dim ccList As New List(Of String)
Try
OutlookMessage = AppOutlook.CreateItem(outlook.OlItemType.olMailItem)
Dim Recipents As outlook.Recipients = OutlookMessage.Recipients
Recipents.Add(FSEmailAddress)
If email1.Checked Then
ccList.Add("email1#some.email.com")
End If
If email2.Checked Then
ccList.Add("email2#some.email.com; ")
End If
If email3.Checked Then
ccList.Add("email3#some.email.com; ")
End If
If email4.Checked Then
ccList.Add("email4#some.email.com; ")
End If
ccJoin = String.Join("; ", ccList.ToArray())
OutlookMessage.CC = ccJoin
OutlookMessage.Subject = responseVIN.Text & " was sent back to you by " & GetUserName()
OutlookMessage.Body = responseVIN.Text & " was returned To you" & vbCrLf & "Navigate To the following location To view the comments In the ReadMe file:" & vbCrLf & vbCrLf & archive_dir & responseVIN.Text & vbCrLf & vbCrLf & resAdvice.Text
OutlookMessage.BodyFormat = outlook.OlBodyFormat.olFormatHTML
OutlookMessage.Send()
Catch ex As Exception
MessageBox.Show("Mail could Not be sent")
Finally
OutlookMessage = Nothing
AppOutlook = Nothing
End Try
End If

VBA DO Loops Issue

I am trying to create a pop up question in powerpoint VBA, so far so good. But below code doesn’t seem to work. Idea is that you get a popup box with value to enter between 100 - 200 (inclusive). But must enter a value between or can accept failed as input. The inputbox cannot be cancelled or null/empty responses. The inner loop (loop 1) seems to work ok, but if I enter 150 it doesn't terminate the loop 2 instead keeps going unless type failed but it stops with any text rather than only "failed".
Sub OnSlideShowPageChange(ByVal SSW As SlideShowWindow)
'Declare Variables
Dim xType, xLimitHi, xLimitLo, xPrompt As String
Dim InputvarTemp As String
Dim msgResult As Integer
xLimitHi = 200
xLimitLo = 100
xPrompt = "Enter Value between 100 and 200 (Inclusive)"
Do 'loop 2 check within limit or failed
msgResult = vbNo
Do 'loop 1 check Empty / Null or Cancelled input
InputvarTemp = InputBox(xPrompt, xPrompt)
If StrPtr(InputvarTemp) = 0 Then ' Check if cancelled is pressed
MsgBox "Invalid Input - Cannot be cancelled", 16, "Invalid Input."
Else
If Len(InputvarTemp) = 0 Then ' Check Null response
MsgBox "Invalid Input - Cannot be Empty / Null ", 16, "Invalid Input."
Else
msgResult = MsgBox("You have Entered " & InputvarTemp, vbYesNo + vbDefaultButton2, "Check Value in between " & xLimitLo & " to " & xLimitHi & "(Inclusive)")
If CDec(InputvarTemp) < 100 Or CDec(InputvarTemp) > 200 Then ' Check within Limits
MsgBox "Invalid Input - Not Within Limit", 16, "Invalid Input."
End If
End If
End If
Loop Until Len(InputvarTemp) > 0 And msgResult = vbYes And StrPtr(InputvarTemp) = 1 And IsNull(InputvarTemp) = False 'loop 1 check Empty / Null or Cancelled input
Loop Until CDec(InputvarTemp) >= 100 And CDec(InputvarTemp) <= 200 Or InputvarTemp = "Failed" 'loop 2 check within limit
Select Case InputvarTemp
Case "Failed"
MsgBox "Test Criteria Failed, Contact Production Engineer", 16, "Failed Test Criteria."
Case Else
MsgBox "Test Criteria Passed", 16, "Passed Test Criteria."
End Select
End Sub
Can anyone point me to the problem? Many thanks in advance. This is a part of a bigger code project but this part is not working I have isolated this code in to a single file to run by itself to figure out the issue.
To better understand what's going on, you need to write your code in such a way that it does as little as possible; right now you have a single procedure that does so many things it's hard to tell exactly what's going wrong and where.
Write a function to confirm user's valid numeric input:
Private Function ConfirmUserInput(ByVal input As Integer) As Boolean
ConfirmUserInput = MsgBox("Confirm value: " & CStr(input) & "?", vbYesNo) = vbYes
End Function
Then write a function to deal with user's input:
Private Function IsValidUserInput(ByVal userInput As String,_
ByVal lowerLimit As Double, _
ByVal upperLimit As Double) _
As Boolean
Dim result As Boolean
Dim numericInput As Double
If StrPtr(userInput) = 0 Then
'msgbox / cannot cancel out
ElseIf userInput = vbNullString Then
'msgbox / invalid empty input
ElseIf Not IsNumeric(userInput) Then
'msgbox / must be a number
Else
numericInput = CDbl(userInput)
If numericInput < lowerLimit Or numericInput > upperLimit Then
'msgbox / must be within range
Else
result = ConfirmUserInput(numericInput)
End If
End If
IsValidUserInput = result
End Function
This function can probably be written in a better way, but nonetheless it will return False if any of the validation rules fail, or if user doesn't confirm their valid input. Now you're equipped for looping, and since all the complex logic is extracted into its own function, the loop body gets pretty easy to follow:
Private Function GetTestCriteria(ByVal lowerLimit As Double, _
ByVal upperLimit As Double) As Boolean
Const failed As String = "Failed"
Dim prompt As String
prompt = "Enter Value between " & lowerLimit & _
" and " & upperLimit & " (Inclusive)."
Dim userInput As String
Dim isValid As Boolean
Do
userInput = InputBox(prompt, prompt)
isValid = IsValidUserInput(userInput, lowerLimit, upperLimit) _
Or userInput = failed
Loop Until IsValid
GetTestCriteria = (userInput <> failed)
End Sub
The OnSlideShowPageChange procedure can now look like this:
Private Sub OnSlideShowPageChange(ByVal SSW As SlideShowWindow)
If GetTestCriteria(100, 200) Then
MsgBox "Test criteria passed."
Else
MsgBox "Test criteria failed, contact production engineer."
End If
End Sub
I haven't tested any of this code, but I'm sure debugging these more specialized functions will be easier than debugging your monolithic chunk of code; by extracting these functions, you untangle the logic, and I bet the above does exactly what you're trying to do. Also note:
Dim xType, xLimitHi, xLimitLo, xPrompt As String declares xPrompt as a String, and everything else as a Variant. I don't think that's your intent here.
Select Case is best used with Enum values; use If-ElseIf constructs otherwise.
Slight modifications, per below comment:
how do i capture the user input to do something like write to a file
Now if you wanted to do something with the valid user inputs, say, write them to a file, you'd need GetTestCriteria to return the input - but that function is already returning a Boolean. One solution could be to use an "out" parameter:
Private Function GetTestCriteria(ByVal lowerLimit As Double, _
ByVal upperLimit As Double, _
ByRef outResult As Double) As Boolean
Const failed As String = "Failed"
Dim prompt As String
prompt = "Enter Value between " & lowerLimit & _
" and " & upperLimit & " (Inclusive)."
Dim userInput As String
Dim isValid As Boolean
Do
userInput = InputBox(prompt, prompt)
isValid = IsValidUserInput(userInput, lowerLimit, upperLimit, outResult) _
Or userInput = failed
Loop Until IsValid
GetTestCriteria = (userInput <> failed)
End Sub
Private Function IsValidUserInput(ByVal userInput As String,_
ByVal lowerLimit As Double, _
ByVal upperLimit As Double, _
ByRef outResult As Double) _
As Boolean
Dim result As Boolean
Dim numericInput As Double
If StrPtr(userInput) = 0 Then
'msgbox / cannot cancel out
ElseIf userInput = vbNullString Then
'msgbox / invalid empty input
ElseIf Not IsNumeric(userInput) Then
'msgbox / must be a number
Else
numericInput = CDbl(userInput)
If numericInput < lowerLimit Or numericInput > upperLimit Then
'msgbox / must be within range
Else
result = ConfirmUserInput(numericInput)
outResult = numericInput
End If
End If
IsValidUserInput = result
End Function
And now you can call a method in OnSlideShowPageChange, to write the valid result to a file:
Private Sub OnSlideShowPageChange(ByVal SSW As SlideShowWindow)
Dim result As Double
If GetTestCriteria(100, 200, result) Then
MsgBox "Test criteria passed."
WriteResultToFile result
Else
MsgBox "Test criteria failed, contact production engineer."
End If
End Sub
If you run into issues implementing this WriteResultToFile procedure, and existing Stack Overflow questions don't have an answer for you (slightly unlikely), feel free to ask another question!
Retailcoder's answer as a general approach is top notch. I would like to draw attention specifically to the use of IsNumeric() which would solve most issues. Currently your code fails if any non-numeric string is entered.
Had a look at the code to try and see if I could at least answer what was happening to try and appease your curiosity. You mentioned that it looked like you couldn't leave your second loop. In practice I was unable to exit your first loop. I'm sure was due to the StrPtr(InputvarTemp) = 1. I didn't even know what that was until I looked it up. In short it is an undocumented feature that was used to check if Cancel was pushed / get the underlying memory address of variables (apparently).
Before the end of the first loop I put this in for debugging
MsgBox Len(InputvarTemp) & " " & msgResult & " " & StrPtr(InputvarTemp) & " " & IsNull(InputvarTemp)
When I type "150" in the InputBox the results of the message box are as follows. The third value represent the StrPtr(InputvarTemp)
3 6 246501864 FALSE
246501864 is greater than 1 which would cause the loop exit to fail. Again, retailcoder has an excellent answer and I will not reinvent his wheel.
with thanks to #retailcoder and #Matt below is the completed code for any to use, your help is truly appropriated
Capture user input to a file(s) from Powerpoint presentation, using a Config.ini to minimize everyday programming (or no programming code to a standard user)
> Code in Slide 1
Option Explicit
Option Compare Text
Public WithEvents PPTEvent As Application
Public TimeNow, ToDate As String
Public WorkOrder, Serial, UserName As String
Public ReportFile, TempReportFile, TimingFile As String
Sub OnSlideShowPageChange(ByVal SSW As SlideShowWindow)
'Declare Variables
Dim ShellRun As Long
Dim INIPath, StartTime, EndTime, TimeDifferance As String ' from Enviorment
Dim PCPver, ModuleName, PCPFileName, Timed, ResultsFolder, TrainingFolder, TimeingFolder, TrainedFolder, xType, xPrompt, xvarUnit, y As String 'From INI file
Dim xLimitHi, xLimitLo As Variant
Dim result As Double
Dim FailedResult As Double
Dim PCPverInput, inputvar, InputvarDate, InputvarTrueFalse, InputvarGeneral, InputvarLimit, InputvarTemp As String 'From User
Dim TrainingFile, SelfCheck, InvalidCharacter1, InvalidCharacter2 As String 'Variables for Filenames
Dim msgResult, msgResultTemp As Integer
Dim myVarPass As Boolean
Dim KeyAscii As Integer 'Try and Hook Esc key
Dim ppApp As Object
Const fsoForAppend = 8
'Declare and create a FileSystemObject.
Dim fso, ResutlsFSO, TrainingFSO, TimeingFSO As Object 'Need Microsoft Script Runtime in references
' Declare a TextStream.
Dim oFile, ResutlsStream, TrainingStream, TimeingStream As Object
'Assign Variables
INIPath = ActivePresentation.Path & "\" & "Config.ini"
'ShellRun = Shell(ActivePresentation.Path & "\" & "Esc.exe")
SelfCheck = ActivePresentation.Name
ToDate = Format(Date, "dd-mmm-yyyy")
TimeNow = Replace(Format(time, "hh:mm:ss"), ":", "-")
StartTime = Format(time, "hh:mm:ss")
'Retrive Folderpaths and create file names
ModuleName = GetINIString("PCPInfo", "ModuleName", INIPath)
Timed = GetINIString("Options", "Timed", INIPath)
Set ResutlsFSO = CreateObject("Scripting.FileSystemObject")
Set TrainingFSO = CreateObject("Scripting.FileSystemObject")
Set TimeingFSO = CreateObject("Scripting.FileSystemObject")
'Retrive PCP version from Ini file
PCPver = GetINIString("PCPInfo", "PCPver", INIPath)
PCPFileName = GetINIString("PCPInfo", "PCPFileName", INIPath)
ResultsFolder = GetINIString("Folders", "ResultsFolder", INIPath)
TrainingFolder = GetINIString("Folders", "TrainingFolder", INIPath)
TimeingFolder = GetINIString("Folders", "TimeingFolder", INIPath)
TrainedFolder = GetINIString("Folders", "TrainedFolder", INIPath)
Do
If (SelfCheck <> PCPFileName) Then
MsgBox "Invalid Config.ini File. Replace with Correct INI file to continue. ", 16, "Invalid Config.ini File."
End If
Loop Until (SelfCheck = PCPFileName)
'Collect PCP version, User Name, Work Order, Serial Number
If (SSW.View.CurrentShowPosition = 1) Then
'Retrive PCP Version from BOM - User Input
Do
Do
PCPverInput = InputBox("Enter PCP Number including Version", "Enter PCP Number including Version")
If (Len(PCPverInput) < 4) Then
MsgBox "Invalid Input - PCP version cannot be Empty / Null / cancelled", vbOKOnly, "Invalid Input"
End If
Loop Until (Len(PCPverInput) > 4)
'Check PCPversion against BOM
If (PCPver <> PCPverInput) Then
'Display Warning Messages
MsgBox "Incorrect PCP version. Contact Team Leader / Product Engineer. Cannot Continue the programm", 16, "Incorrect PCP version."
End If
Loop Until (PCPver = PCPverInput)
'Retrive UserName - User Input
Do
msgResult = 7
Do
UserName = InputBox("Enter / Scan Operator Name", "Enter / Scan Operator Name")
msgResult = MsgBox("You have Enterd Operator Name " & UserName, vbYesNo + vbDefaultButton2, "Operator Name")
If (Len(UserName) < 4) Then
MsgBox "Invalid Input - User / Operator Name cannot be Empty / Null / cancelled", 16, "Invalid Input"
End If
Loop Until (Len(UserName) > 4) And (msgResult = vbYes)
Loop Until (Len(UserName) > 4)
'Retrive Work Order
Do
msgResult = 7
Do
WorkOrder = InputBox("Enter / Scan Work Order", "Enter / Scan Work Order")
msgResult = MsgBox("You have Enterd Work Order " & WorkOrder, vbYesNo + vbDefaultButton2, "Work Order")
If (Len(WorkOrder) < 4) Then
MsgBox "Invalid Input - Work Order cannot be Empty / Null / cancelled. Minimum 5 Numbers", 16, "Invalid Input"
End If
Loop Until (Len(WorkOrder) > 4) And (msgResult = vbYes)
Loop Until (Len(WorkOrder) > 4)
'Retrive Serial Number
Do
msgResult = 7
Do
Serial = InputBox("Enter / Scan Serial Number", "Enter / Scan Serial Number")
msgResult = MsgBox("You have Enterd Serial Number " & Serial, vbYesNo + vbDefaultButton2, "Serial Number")
If (Len(Serial) < 1) Then
MsgBox "Invalid Input - Serial Number cannot be Empty / Null / cancelled. Use -NOSERIAL- if Not Applicable", 16, "Invalid Input"
End If
Loop Until (Len(Serial) > 1) And (msgResult = vbYes)
Loop Until (Len(Serial) > 1)
If (Len(Dir(ResultsFolder, vbDirectory)) = 0) Then
MkDir ResultsFolder
End If
If (Len(Dir(ResultsFolder & "\" & WorkOrder, vbDirectory)) = 0) Then
MkDir ResultsFolder & "\" & WorkOrder
End If
If (Len(Dir(ResultsFolder & "\" & WorkOrder & "\" & Serial, vbDirectory)) = 0) Then
MkDir ResultsFolder & "\" & WorkOrder & "\" & Serial
End If
ReportFile = ResultsFolder & "\" & WorkOrder & "\" & Serial & "\" & PCPver & "_" & ToDate & "_" & TimeNow & ".txt"
Set ResutlsStream = ResutlsFSO.CreateTextFile(ReportFile, True)
ResutlsStream.WriteLine PCPver & " " & ModuleName & " Build / Test Checklist"
ResutlsStream.WriteLine "===================================================================================================="
ResutlsStream.WriteLine ""
ResutlsStream.WriteLine "Work Order :" & WorkOrder
ResutlsStream.WriteLine "Serial Number (if Applicable) :" & Serial
ResutlsStream.WriteLine "Test / Assembly Operator (Full Name) :" & UserName
ResutlsStream.WriteLine "Date (dd-mmm-yyyy) :" & ToDate
ResutlsStream.WriteLine ""
ResutlsStream.Close
If (Len(Dir(TrainingFolder, vbDirectory)) = 0) Then
MkDir TrainingFolder
End If
If (Len(Dir(TrainingFolder & "\" & UserName, vbDirectory)) = 0) Then
MkDir TrainingFolder & "\" & UserName
End If
TrainingFile = TrainingFolder & "\" & UserName & "\" & PCPver & ".csv"
If (Len(Dir(TrainingFile)) = 0) Then
Set TrainingStream = TrainingFSO.CreateTextFile(TrainingFile, True)
TrainingStream.WriteLine UserName & "'s " & ModuleName & " " & PCPver & " Training File"
TrainingStream.WriteLine "===================================================================================================="
TrainingStream.WriteLine "Operator" & Chr(44) & "PCP Version" & Chr(44) & "W/O" & Chr(44) & "Serial" & Chr(44) & "Date" & Chr(44) & "Time"
TrainingStream.WriteLine "===================================================================================================="
Else
Set TrainingStream = TrainingFSO.OpenTextFile(TrainingFile, 8)
End If
TrainingStream.WriteLine UserName & Chr(44) & PCPver & Chr(44) & WorkOrder & Chr(44) & Serial & Chr(44) & ToDate & Chr(44) & Format(time, "HH:MM:SS AM/PM")
TempReportFile = ReportFile
End If
'Detect Slide Number and Retrive Relevant Question from INI File
y = SSW.View.CurrentShowPosition
If (Len(y) > 0) Then
xType = GetINIString(SSW.View.CurrentShowPosition, "PromptType", INIPath)
If (Len(xType) > 0) Then
Set ResutlsStream = ResutlsFSO.OpenTextFile(TempReportFile, 8)
Select Case xType
Case "Message"
xPrompt = GetINIString(SSW.View.CurrentShowPosition, "Prompt", INIPath)
MsgBox xPrompt, vbYes, xPrompt
Case "Date"
xPrompt = GetINIString(SSW.View.CurrentShowPosition, "Prompt", INIPath)
Do
msgResult = 7
Do
inputvar = InputBox(xPrompt, "Enter Date")
InputvarDate = inputvar
msgResult = MsgBox("You have Enterd " & Format(inputvar, "dd-Mmm-yyyy") & " to " & xPrompt, vbYesNo + vbDefaultButton2, "Check Date Input")
If (StrPtr(inputvar) = 0) Or (Len(inputvar) < 6) Then
MsgBox "Invalid Date Input - Cannot be Empty / Null / cancelled. Enter a Valid date, in dd-Mmm-yyyy format", 16, "Invalid Input."
End If
inputvar = Format(inputvar, "dd-Mmm-yyyy")
If (Not IsDate(inputvar)) Then
MsgBox "Enter a Valid date, in dd-Mmm-yyyy format", 16, "Invalid Date."
End If
Loop Until (IsDate(inputvar) = True) And (msgResult = vbYes) And (Len(InputvarDate) > 6)
Loop Until (IsDate(inputvar) = True) And (msgResult = vbYes)
ResutlsStream.WriteLine "Step " & SSW.View.CurrentShowPosition & ". " & xPrompt & Chr(9) & ":" & Chr(9) & inputvar & " " & xvarUnit
Case "TrueFalse"
xPrompt = GetINIString(SSW.View.CurrentShowPosition, "Prompt", INIPath)
Do
msgResult = 7
Do
inputvar = InputBox(xPrompt, "Enter True or False")
msgResult = MsgBox("You have Enterd " & inputvar & " to " & xPrompt, vbYesNo + vbDefaultButton2, "Check Your Input (True/False)")
If (StrPtr(inputvar) = 0) Or (Len(inputvar) < 0) Then
MsgBox "Invalid Input - Cannot be Empty / Null / cancelled", 16, "Invalid Input."
End If
If (inputvar <> "True") And (inputvar <> "False") Then
MsgBox "Invalid Input - Enter Either True or False", 16, "Invalid Input."
End If
Loop Until (Len(inputvar) > 0) And (inputvar = "True") Or (inputvar = "False") And (msgResult = vbYes)
Loop Until (Len(inputvar) > 0) And (inputvar = "True") Or (inputvar = "False") And (msgResult = vbYes)
If inputvar = True Then
ResutlsStream.WriteLine "Step " & SSW.View.CurrentShowPosition & ". " & xPrompt & Chr(9) & ":" & Chr(9) & inputvar
Else
MsgBox "Test criteria failed, contact production engineer."
ResutlsStream.WriteLine "Step " & SSW.View.CurrentShowPosition & ". " & xPrompt & Chr(9) & ":" & Chr(9) & inputvar & " " & xvarUnit & " Failed" & " ***NCR Required***"
End If
Case "General"
xPrompt = GetINIString(SSW.View.CurrentShowPosition, "Prompt", INIPath)
Do
msgResult = 7
Do
inputvar = InputBox(xPrompt, xPrompt)
msgResult = MsgBox("You have Enterd " & inputvar & " to " & xPrompt, vbYesNo + vbDefaultButton2, "Check Input")
If (StrPtr(inputvar) = 0) Or (Len(inputvar) < 0) Then
MsgBox "Invalid Input - Cannot be Empty / Null / cancelled", 16, "Invalid Input."
End If
Loop Until (Len(inputvar) > 0) And (msgResult = vbYes)
Loop Until (Len(inputvar) > 0) And (msgResult = vbYes)
ResutlsStream.WriteLine "Step " & SSW.View.CurrentShowPosition & ". " & xPrompt & Chr(9) & ":" & Chr(9) & inputvar & " " & xvarUnit
Case "Limit"
xLimitHi = GetINIString(SSW.View.CurrentShowPosition, "LimitHi", INIPath)
xLimitLo = GetINIString(SSW.View.CurrentShowPosition, "LimitLo", INIPath)
xPrompt = GetINIString(SSW.View.CurrentShowPosition, "Prompt", INIPath)
xvarUnit = GetINIString(SSW.View.CurrentShowPosition, "varUnit", INIPath)
If GetTestCriteria(xPrompt, xLimitLo, xLimitHi, xvarUnit, result) Then
ResutlsStream.WriteLine "Step " & SSW.View.CurrentShowPosition & ". " & xPrompt & Chr(9) & ":" & Chr(9) & result & " " & xvarUnit
Else
MsgBox "Test criteria failed, contact production engineer."
Do
msgResult = 7
Do
FailedResult = InputBox("Enter Values Failed in " & xPrompt, "Enter Failed Value")
msgResult = MsgBox("You have Enterd Failed Value of " & FailedResult, vbYesNo + vbDefaultButton2, "Check Failed Input")
If (StrPtr(FailedResult) = 0) Or (Len(FailedResult) = 0) Then
MsgBox "Invalid Input - Cannot be Empty / Null / cancelled", 16, "Invalid Input."
End If
Loop Until (Len(FailedResult) > 0) And (msgResult = vbYes)
Loop Until (Len(FailedResult) > 0) And (msgResult = vbYes)
ResutlsStream.WriteLine "Step " & SSW.View.CurrentShowPosition & ". " & xPrompt & Chr(9) & ":" & Chr(9) & FailedResult & " " & xvarUnit & " Failed" & " ***NCR Required***"
End If
ResutlsStream.Close
End Select
End If
End If
If (Timed = "ON") Then
If (Len(Dir(TimeingFolder, vbDirectory)) = 0) Then
MkDir TimeingFolder
End If
If (Len(Dir(TimeingFolder & "\" & PCPver, vbDirectory)) = 0) Then
MkDir TimeingFolder & "\" & PCPver
End If
TimingFile = TimeingFolder & "\" & PCPver & "\" & "Timing-" & WorkOrder & "-" & Serial & "-" & PCPver & "-" & ToDate & ".csv"
If (Len(Dir(TimingFile)) = 0) Then
Set TimeingStream = TimeingFSO.CreateTextFile(TimingFile, True)
TimeingStream.WriteLine UserName & "'s " & ModuleName & " " & PCPver & " Build Time File"
TimeingStream.WriteLine "===================================================================================================="
TimeingStream.WriteLine "Seq/Step" & Chr(44) & "Start Time" & Chr(44) & "End Time"
Else
Set TimeingStream = TimeingFSO.OpenTextFile(TimingFile, 8)
End If
EndTime = Format(time, "hh:mm:ss")
TimeingStream.WriteLine "No:" & SSW.View.CurrentShowPosition & Chr(44) & StartTime & Chr(44) & EndTime
TimeingStream.Close
End If
End Sub
Private Function ConfirmUserInput(ByVal inputvar As Double) As Boolean
ConfirmUserInput = MsgBox("Confirm value: " & CStr(inputvar) & "?", vbYesNo + vbDefaultButton2, "Confirm value") = vbYes
End Function
Private Function IsValidUserInput(ByVal userInput As String, ByVal xLimitLo As Double, ByVal xLimitHi As Double, ByRef outResult As Double) As Boolean
Dim result As Boolean
Dim numericInput As Double
If StrPtr(userInput) = 0 Then
MsgBox "Invalid Input - Entry cannot be cancelled", 16, "Invalid User Input"
ElseIf userInput = vbNullString Then
MsgBox "Invalid Input - Entry cannot be Empty / Null", 16, "Invalid User Input"
ElseIf Not IsNumeric(userInput) Then
MsgBox "Invalid Input - Numeric Input required", 16, "Invalid User Input"
Else
numericInput = CDbl(userInput)
If numericInput < xLimitLo Or numericInput > xLimitHi Then
MsgBox "Invalid Input - Not within Limits", 16, "Invalid User Input"
Else
result = ConfirmUserInput(numericInput)
outResult = numericInput
End If
End If
IsValidUserInput = result
End Function
Private Function GetTestCriteria(ByVal xPrompt As String, ByVal xLimitLo As Double, ByVal xLimitHi As Double, ByVal xvarUnit As String, ByRef outResult As Double) As Boolean
Const failed As String = "Failed"
Dim prompt As String
prompt = "Enter Value between " & xLimitLo & xvarUnit & " and " & xLimitHi & xvarUnit & "(Inclusive)"
Dim userInput As String
Dim isValid As Boolean
Do
userInput = InputBox(prompt, xPrompt)
isValid = IsValidUserInput(userInput, xLimitLo, xLimitHi, outResult) Or userInput = failed
Loop Until isValid
GetTestCriteria = (userInput <> failed)
End Function
Private Sub TextBox1_Change()
End Sub
Private Sub TextBox2_Change()
End Sub
Private Sub TextBox2_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
End Sub
> Code in Module
Option Explicit
Option Compare Text
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Private Declare Function GetPrivateProfileInt Lib "kernel32" Alias "GetPrivateProfileIntA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal nDefault As Long, ByVal lpFileName As String) As Long
Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpString As String, ByVal lpFileName As String) As Long
Private Const CONFIG_FILE = "Config.ini"
Public Function GetINIString(ByVal sApp As String, ByVal sKey As String, ByVal filepath As String) As String
Dim sBuf As String * 256
Dim lBuf As Long
lBuf = GetPrivateProfileString(sApp, sKey, "", sBuf, Len(sBuf), filepath)
GetINIString = Left$(sBuf, lBuf)
End Function
Public Function WriteINI(ByVal sApp As String, ByVal sKey As String, ByVal sValue As String) As String
WritePrivateProfileString sApp, sKey, sValue, "Config.ini"
End Function
Code in Config.ini
Config.ini to be remain in same folder as the .ppsm file
[PCPInfo]
;This will force the operator to check PCP version against BOM
;This is required as it is used to tie in the check list to the PCP
PCPver=12.3456.789.A01
;this is used as the heading for creating results files
ModuleName=NEW Validation Test Case
;this to check the correct PCP Power-point file is present with the ini file - if this is incorrect power point will not run
PCPFileName=12.3456.789.A01 NEW Validation Test Case.ppsm
[Options]
;Switch ON/OFF to collect timing data
Timed=ON
[Folders]
;If required creates last folder of the path
;folder where all check-lists/result files collected
ResultsFolder=C:\Reports\Validation
;folder where all training data collected
TrainingFolder=C:\Training Records
;folder where all timing data collected
TimeingFolder=C:\Times
;Check Who has completed training here - Not implemented
TrainedFolder=C:\TrainedOP
;Do not Use Slide No 1 - Use slide number in square brackets [x]
;First Slide collects Work Order, User name , Serial Number information
;PromptTypes Message,Date,TrueFalse,General,Limit *compulsory
;Type Message Displays Pop up message only , No Data Collection
;Type Date accepts dates in DD-MMM-YYYY format
;Type TrueFalse can be used for Passed failed, checks etc.
;Type General can be used for Part Serial numbers, batch dates
;Type Limit can be used for test parameters with a range,-
; - if not within the range "Failed" can be used to complete the step and return to a previous step
; LimitHi refers to Higher limit should be less than or equal to *compulsory for type Limit
; LimitLo Refers to Lower limit should be Greater than or equal to *compulsory for type Limit
;Prompt will pop-up the user input box wit the text as question/criteria *compulsory
;VarUnit Type of Unit Ohms,Psi,kPa etc.
[2]
PromptType=Message
LimitHi=
LimitLo=
Prompt=Revision Record
varUnit=
[4]
PromptType=Date
LimitHi=
LimitLo=
Prompt=Enter to days Date
varUnit=
[6]
PromptType=TrueFalse
LimitHi=
LimitLo=
Prompt=Enter True or False
varUnit=
[8]
PromptType=General
LimitHi=
LimitLo=
Prompt=Enter Any text
varUnit=
[10]
PromptType=Limit
LimitHi=200
LimitLo=100
Prompt=Enter Value within limits
varUnit=Bar
thanks again #retailcoder
best regards
Dumidu Roshan aka rellik - #rellik