'---------------------------------------------------------------------- ' VBA code to work with the Problems reporting form ' ' 1. Get field values / selections from form ' ' 2. Perform basic edits (missing values), display error message ' if errors ' ' 3. If edits OK, insert data into IBM i database ' ' 4. Prompt to save document and continue entry or quit '---------------------------------------------------------------------- Dim ErrorMsg 'global var for error message box '---------------------------------------------------------------------- ' [A] Subroutine that is invoked when the Send button is clicked '---------------------------------------------------------------------- Private Sub cmdSend_Click() '------------------------------------------------------------------ ' [A.1] validate the entries, if any invalid data, add ' error message to errors list '------------------------------------------------------------------ ErrorMsg = "" If (IsFieldBlank("txtName")) Then AddError ("Enter your name") If (Not IsValidDropDownList("ddlDept")) Then AddError ("Select your department") 'check for one and only one problem area checked Dim problemAreaCount As Integer If (IsCheckboxChecked("chkWindows")) Then problemAreaCount = problemAreaCount + 1 If (IsCheckboxChecked("chkGreen")) Then problemAreaCount = problemAreaCount + 1 If (IsCheckboxChecked("chkReport")) Then problemAreaCount = problemAreaCount + 1 If (IsCheckboxChecked("chkInternet")) Then problemAreaCount = problemAreaCount + 1 If (IsCheckboxChecked("chkOther")) Then problemAreaCount = problemAreaCount + 1 If (problemAreaCount = 0) Then AddError ("Check one of the problems") If (problemAreaCount > 1) Then AddError ("Can only check one problem type") If (Not IsValidDropDownList("ddlAffect")) Then AddError ("Select how this affects you") End If If (IsFieldBlank("txtEmail")) Then AddError ("Enter your email address") If (IsFieldBlank("txtExtension")) Then AddError ("Enter your extension") If (IsFieldBlank("txtDescription")) Then AddError ("Enter a problem description") '------------------------------------------------------------------ ' [A.2] if any errors, display error box '------------------------------------------------------------------ If (Len(ErrorMsg) > 0) Then Dim okBtn okBtn = MsgBox(ErrorMsg, vbOKOnly, "Errors on Form") '------------------------------------------------------------------ ' [A.3] no errors, prompt for save/continue, save/exit, ' write to database '------------------------------------------------------------------ Else Dim saveBtn saveBtn = MsgBox("Click Yes to save and enter another problem, No to save and exit Word", _ vbYesNo, _ "Save/Return, Save/Close") WriteToDatabase ActiveDocument.Saved = False ActiveDocument.Save If (saveBtn = vbNo) Then ActiveDocument.Close Else ActiveDocument.FormFields("chkWindows").CheckBox.Value = False ActiveDocument.FormFields("chkGreen").CheckBox.Value = False ActiveDocument.FormFields("chkReport").CheckBox.Value = False ActiveDocument.FormFields("chkInternet").CheckBox.Value = False ActiveDocument.FormFields("chkOther").CheckBox.Value = False ActiveDocument.FormFields("ddlAffect").DropDown.Value = 1 ActiveDocument.FormFields("txtDescription").TextInput.Clear End If End If End Sub '---------------------------------------------------------------------- ' [B] Add an error message to the error message list '---------------------------------------------------------------------- Private Sub AddError(errorText As String) ErrorMsg = ErrorMsg & errorText & vbCrLf End Sub '---------------------------------------------------------------------- ' [C] Given a form field name of a checkbox, ' determine if it is checked. ' Returns true if checked, false if not checked '---------------------------------------------------------------------- Private Function IsCheckboxChecked(fieldName As String) As Boolean If (Field(fieldName) = 1) Then IsCheckboxChecked = True Else IsCheckboxChecked = False End If End Function '---------------------------------------------------------------------- ' [D] Given a form field name, determine if the field is blank ' Returns true if blank, false if not blank '---------------------------------------------------------------------- Private Function IsFieldBlank(fieldName As String) As Boolean If (FieldLength(fieldName) = 0) Then IsFieldBlank = True Else IsFieldBlank = False End If End Function '---------------------------------------------------------------------- ' [E] Given a form field name of a drop-down list, ' check for a valid selection (not a separator) ' Returns true if valid, false if invalid '---------------------------------------------------------------------- Private Function IsValidDropDownList(fieldName As String) As Boolean If (FieldLength(fieldName) = 0) Or (Left(Field(fieldName), 1) = "-") Then IsValidDropDownList = False Else IsValidDropDownList = True End If End Function '---------------------------------------------------------------------- ' [F] Given a form field name, return the field's value '---------------------------------------------------------------------- Private Function Field(fieldName As String) As String Field = ActiveDocument.FormFields(fieldName).Result End Function '---------------------------------------------------------------------- ' [G] Given a form field name, return the field's length '---------------------------------------------------------------------- Private Function FieldLength(fieldName As String) As Integer FieldLength = Len(Trim(Field(fieldName))) End Function '---------------------------------------------------------------------- ' [H] Write data to IBM i database file ' Add Microsoft ActiveX Data Objects 2.8 library ' using the VBA Tools, References menu item ' ' On the IBM i, run the following SQL statement to create the ' WORD.PROBLEMS table used in this example: ' ' CREATE TABLE WORD.PROBLEMS ( ' NAME CHAR(30) CCSID 37 NOT NULL , ' DEPARTMENT CHAR(30) CCSID 37 NOT NULL , ' PROBTYPE CHAR(3) CCSID 37 NOT NULL , ' HOWAFFECTS CHAR(30) CCSID 37 NOT NULL , ' EMAIL CHAR(50) CCSID 37 NOT NULL , ' DESCRIPTION VARCHAR(32000) CCSID 37 NOT NULL) '---------------------------------------------------------------------- Private Sub WriteToDatabase() '------------------------------------------------------------------ ' [H.1] create connection to IBM i using OLE DB Provider '------------------------------------------------------------------ Dim conn As New ADODB.connection conn.Open ("Provider=IBMDA400;Data Source=M270;User ID=QUSER;Password=QUSER") '------------------------------------------------------------------ ' [H.2] create an ADO command object '------------------------------------------------------------------ Dim cmd As New ADODB.Command Set cmd.ActiveConnection = conn '------------------------------------------------------------------ ' [H.3] create parameters for the command '------------------------------------------------------------------ Dim pNAME As ADODB.Parameter Dim pDEPARTMENT As ADODB.Parameter Dim pPROBLEMTYPE As ADODB.Parameter Dim pHOWAFFECTS As ADODB.Parameter Dim pEMAIL As ADODB.Parameter Dim pDESCRIPTION As ADODB.Parameter '------------------------------------------------------------------ ' [H.4] assign parameter values based on form data '------------------------------------------------------------------ Set pNAME = cmd.CreateParameter("NAME", adChar, adParamInput, 30) pNAME.Value = Field("txtName") Set pDEPARTMENT = cmd.CreateParameter("DEPARTMENT", adChar, adParamInput, 30) pDEPARTMENT.Value = Field("ddlDept") Set pPROBLEMTYPE = cmd.CreateParameter("PROBTYPE", adChar, adParamInput, 3) If (IsCheckboxChecked("chkWindows")) Then pPROBLEMTYPE.Value = "WIN" If (IsCheckboxChecked("chkGreen")) Then pPROBLEMTYPE.Value = "GRN" If (IsCheckboxChecked("chkReport")) Then pPROBLEMTYPE.Value = "REP" If (IsCheckboxChecked("chkInternet")) Then pPROBLEMTYPE.Value = "INT" If (IsCheckboxChecked("chkOther")) Then pPROBLEMTYPE.Value = "OTH" Set pHOWAFFECTS = cmd.CreateParameter("HOWAFFECTS", adChar, adParamInput, 30) pHOWAFFECTS.Value = Field("ddlAffect") Set pEMAIL = cmd.CreateParameter("EMAIL", adChar, adParamInput, 50) pEMAIL.Value = Field("txtEmail") Set pDESCRIPTION = cmd.CreateParameter("DESCRIPTION", adVarChar, adParamInput, 32000) pDESCRIPTION.Value = Field("txtDescription") '------------------------------------------------------------------ ' [H.5] format INSERT statement, append parameter values to ' statement, execute command '------------------------------------------------------------------ With cmd .CommandText = "INSERT INTO WORD.PROBLEMS(NAME, DEPARTMENT, PROBTYPE, HOWAFFECTS, EMAIL, DESCRIPTION) " .CommandText = .CommandText & " VALUES(?, ?, ?, ?, ?, ?)" .Parameters.Append pNAME .Parameters.Append pDEPARTMENT .Parameters.Append pPROBLEMTYPE .Parameters.Append pHOWAFFECTS .Parameters.Append pEMAIL .Parameters.Append pDESCRIPTION .Execute End With conn.Close End Sub