XL97: Macro Created in Form by Web Form Wizard

• Microsoft Excel 97 for Windows

SUMMARY

When you use the Microsoft Excel 97 Web Form Wizard to create a form for gathering data over the Internet or an intranet, and you select the "Microsoft Internet Information Server with the Internet Database Connector" option in Step 3 of the Wizard, a Visual Basic for Applications module, called WebForm_Submit, is added to the workbook form created by the Wizard. This article provides the macro code created by the Wizard, and some information on the Auto_Open macro in the module that can be edited.

MORE INFORMATION

Microsoft provides programming examples for illustration only, without warranty either expressed or implied, including, but not limited to, the implied warranties of merchantability and/or fitness for a particular purpose. This article assumes that you are familiar with the programming language being demonstrated and the tools used to create and debug procedures. Microsoft support professionals can help explain the functionality of a particular procedure, but they will not modify these examples to provide added functionality or construct procedures to meet your specific needs. If you have limited programming experience, you may want to contact the Microsoft fee-based consulting line at (800) 936-5200. For more information about the support options available from Microsoft, please see the following page on the World Wide Web:

http://www.microsoft.com/support/supportnet/overview/overview.asp

Attribute VB_Name = "WebForm_Submit"

Option Explicit

' If you remove the comment markers from the following code, only the
' cells that you specified as input cells in the Web Form Wizard will be
' selectable when the user opens the form. This protects the form from
' users attempting to delete or change objects or cells on the form.
' See the help topic on EnableSelection for additional information.
'Sub Auto_Open()
'
'    With ThisWorkbook.ActiveSheet
'        .EnableSelection = xlUnlockedCells
'        .Protect DrawingObjects:=True, Contents:=True, _
'            UserInterfaceOnly:=True
'    End With
'End Sub

Sub SubmitInfo()
    Dim aControl As Variant
    Dim MyArray()
    Dim i, j, UBoundaControl, UBoundTestaControl As Integer
    Dim sInfoToSubmit, sURL As String
    Dim sThisField As String
    Dim fDoneFirst As Boolean
    Dim iListIndex As Integer
    Dim Wks As Worksheet

    ' Check if there is some hidden name if not quit it
    On Error Resume Next
        Set Wks = ThisWorkbook.ActiveSheet
        sURL = Evaluate(Wks.Names("WebForm_URLOfIDC").Value)
    On Error GoTo 0

    If IsEmpty(sURL) Then GoTo SheetDamaged

    On Error GoTo SheetDamaged
    aControl = Evaluate(Wks.Name & "!WebForm_Control")

    On Error Resume Next
        UBoundTestaControl = UBound(aControl, 2)
    On Error GoTo 0

    If UBoundTestaControl = 0 Then
        UBoundaControl = 1
    Else
        UBoundaControl = UBound(aControl, 1)
    End If

    On Error GoTo SheetDamaged
    ReDim MyArray(UBoundaControl, 3)
    For j = LBound(aControl, 1) To UBoundaControl
        If UBoundTestaControl = 0 Then
            MyArray(j, 1) = aControl(1)
            MyArray(j, 2) = aControl(2)
        Else
            MyArray(j, 1) = aControl(j, 1)
            MyArray(j, 2) = aControl(j, 2)
        End If

        Select Case TypeName(Evaluate(MyArray(j, 1)))
            Case "Range"
                MyArray(j, 3) = Wks.Range(MyArray(j, 1)).Value
                If Len(MyArray(j, 3)) > 249 Then GoTo StringTooLong
            Case "ListBox"
                iListIndex = Wks.DrawingObjects(MyArray(j, 1)).ListIndex
                If iListIndex <> 0 Then
                    MyArray(j, 3) = Wks.DrawingObjects(MyArray(j, 1)) _
                    .List(Wks.DrawingObjects(MyArray(j, 1)).ListIndex)
                Else
                    MyArray(j, 3) = ""
                End If
            Case "DropDown"
                iListIndex = Wks.DrawingObjects(MyArray(j, 1)).ListIndex
                If iListIndex <> 0 Then
                    MyArray(j, 3) = Wks.DrawingObjects(MyArray(j, 1)) _
                    .List(Wks.DrawingObjects(MyArray(j, 1)).ListIndex)
                Else
                    MyArray(j, 3) = ""
                End If
            Case "CheckBox"
                If Wks.DrawingObjects(MyArray(j, 1)).Value = 1 Then
                    MyArray(j, 3) = "on"
                Else
                    MyArray(j, 3) = "off"
                End If
            Case "OptionButton"
                If Wks.DrawingObjects(MyArray(j, 1)).Value = 1 _
                   Then MyArray(j, 3) = MyArray(j, 1)
            Case Else
                MyArray(j, 3) = Wks.DrawingObjects(MyArray(j, 1)).Value
        End Select
        Next j

    fDoneFirst = False
    sInfoToSubmit = ""
    For j = LBound(aControl, 1) To UBoundaControl
        If Len(CStr(MyArray(j, 3))) > 0 Then
            sThisField = URLEncodeString(CStr(MyArray(j, 2))) & -_
               "=" & URLEncodeString(CStr(MyArray(j, 3)))

            If fDoneFirst Then
                sInfoToSubmit = sInfoToSubmit & "&" & sThisField
            Else
                sInfoToSubmit = sThisField
                fDoneFirst = True
            End If
        End If
    Next j

    sInfoToSubmit = sURL & "?" & sInfoToSubmit

    On Error GoTo BadURLOrSheetDamaged
        With ThisWorkbook
            .Saved = True
            .FollowHyperlink Address:=sInfoToSubmit
        End With
    On Error GoTo 0


    Exit Sub

StringTooLong:
   MsgBox "One or more responses are too long. To continue, shorten any" _
      & " response than is more than 249 characters. No information has" _
      & " been submitted."
    Exit Sub

SheetDamaged:
   MsgBox "This form has been modified or damaged. No information has " _
     & "been submitted. Please report this problem to the administrator" _
     & " of the form."
   Exit Sub

BadURLOrSheetDamaged:
   MsgBox "No information has been submitted. The reason might be one" _
     & " of the following:" & Chr(13) & "* One or more files used in" _
     & " this process seems to have been damaged." & Chr(13) & "* The" _
     & " URL address which is saved in a defined name in this worksheet" _
     & " might be wrong." & Chr(13) & Chr(13) & "Please contact the" _
     & " administrator of this file."
    Exit Sub
End Sub

Function URLEncodeString(ByVal Sin As String) As String
    Dim sOut As String
    Dim iLen As Integer
    Dim i As Integer
    Dim c As Integer

    iLen = Len(Sin)
    For i = 1 To iLen
        c = Asc(Mid(Sin, i, 1))
        Select Case c
        ' a to z, A to Z, 0 to 9, <period>, <underscore>, <minus>
        Case 97 To 122, 65 To 90, 48 To 57, 46, 95, 45
            sOut = sOut & Chr(c)

        Case 32             ' space
            sOut = sOut & "+"

        Case Else
            sOut = sOut & MakeHexSubstitution(c)
        End Select
    Next
    URLEncodeString = sOut
End Function

Function MakeHexSubstitution(c As Integer) As String
    Dim sResult As String

    sResult = Hex(c)
    If Len(sResult) < 2 Then
        sResult = "0" & sResult
    End If
    MakeHexSubstitution = "%" & sResult
End Function 

REFERENCES

For more information about the Web Form Wizard, click the Index tab in Microsoft Excel Help, type the following text

   web form wizard 

Additional query words: 97 XL97

Keywords : kbprg kbtool kbdta kbdtacode xlwiz KbVBA xlweb
Version : WINDOWS:97
Platform : WINDOWS
Issue type :