写了几个类，希望对大家有用。

网络编程 2024/9/30 佚名

3 2 1

无为清净楼资源网 Design By www.qnjia.com

1.日历

[Ctrl+A 全选注:引入外部Js需再刷新一下页面才能执行]
2.简单的下拉菜单

[Ctrl+A 全选注:引入外部Js需再刷新一下页面才能执行]
3. QQ菜单效果

[Ctrl+A 全选注:引入外部Js需再刷新一下页面才能执行]
4.对联效果

[Ctrl+A 全选注:引入外部Js需再刷新一下页面才能执行]
5.图片轮换

[Ctrl+A 全选注:引入外部Js需再刷新一下页面才能执行]
6.listView类

[Ctrl+A 全选注:引入外部Js需再刷新一下页面才能执行]
7.表单多文件上传类 [ASP]

<%     Class Upload         Public  Form, Finished         Private bVBCrlf, bSeparate, formData, cFields, folderPath, itemCount, sErrors, sAuthor, sVersion         Private itemStart(), itemLength(), dataStart(), dataLength(), itemName(), itemData(), extenArr()         Private Sub Class_Initialize                   formData = Request.BinaryRead(Request.TotalBytes)             Set Form = Server.CreateObject("Scripting.Dictionary")             sAuthor = "51JS.COM-ZMM"             sVersion = "Upload Class 1.0"         End Sub                   Public Property Get ErrMessage             ErrMessage = sErrors         End Property           Public Property Get Author             Author = sAuthor         End Property         Public Property Get Version             Version = sVersion         End Property         Public Property Let CheckFields(byVal sCheck)             cFields = sCheck         End Property         Public Property Let Folder(byVal sFolder)             folderPath = sFolder         End Property         Public Function Start             Finished = False             bVBCrlf = StrToByte(vbCrlf & vbCrlf)             bSeparate = StrToByte("-----------------------------")             itemCount = 0             sErrors = ""             Call ItemPosition          End Function         Private Function ItemPosition             Dim iStart, iLength : iStart = 1                     Do Until InStrB(iStart, formData, bSeparate) = 0                iStart = InStrB(iStart, formData, bSeparate) + LenB(bSeparate) + 14                iLength = InStrB(iStart, formData, bSeparate) - iStart - 2                If Abs(iStart + 2 - LenB(formData)) > 2 Then                   ReDim Preserve itemStart(itemCount)                   ReDim Preserve itemLength(itemCount)                   itemStart(itemCount) = iStart                   itemLength(itemCount) = iLength                   itemCount = itemCount + 1                End If             Loop             Call FillItemValue         End Function         Private Function FillItemValue             Dim dataPart, bInfor             Dim iStart : iStart = 1             Dim iCount : iCount = 0             Dim iCheck : iCheck = StrToByte("filename")             For i = 0 To itemCount - 1                 ReDim Preserve itemName(iCount)                 ReDim Preserve itemData(iCount)                 ReDim Preserve extenArr(iCount)                 ReDim Preserve dataStart(iCount)                 ReDim Preserve dataLength(iCount)                 dataPart = MidB(formData, itemStart(i), itemLength(i))                 iStart = InStrB(1, dataPart, ChrB(34)) + 1                 iLength = InStrB(iStart, dataPart, ChrB(34)) - iStart                 itemName(iCount) = FormItemName(MidB(dataPart, iStart, iLength))                 iStart = InStrB(1, dataPart, bVBCrlf) + 4                 iLength = LenB(dataPart) - iStart + 1                 If InStrB(1, dataPart, iCheck) > 0 Then                    bInfor = MidB(dataPart, 1, iStart - 5)                    extenArr(iCount) = FileExtenName(bInfor)                    If Mid(folderPath, Len(folderPath) - 1) = "/" Then                       itemData(iCount) = folderPath & GetRndName(6) & extenArr(iCount)                    Else                       itemData(iCount) = folderPath & "/" & GetRndName(6) & extenArr(iCount)                      End If                    dataStart(iCount) = itemStart(i) + iStart - 2                    dataLength(iCount) = iLength                 Else                    extenArr(iCount) = ""                    itemData(iCount) = ByteToStr(MidB(dataPart, iStart, iLength))                    dataStart(iCount) = ""                    dataLength(iCount) = ""                 End If                 iCount = iCount + 1             Next             Call SaveUpload         End Function         Private Function FormItemName(byVal bName)             FormItemName = ByteToStr(bName)         End Function         Private Function FileExtenName(byVal bInfor)             Dim pStart, pLength, pContent, regEx             pStart = InStr(1, ByteToStr(bInfor), "filename=" & Chr(34)) + 10             pLength = InStr(pStart, ByteToStr(bInfor), Chr(34)) - pStart             pContent = Mid(ByteToStr(bInfor), pStart, pLength)             If pContent = "" Then                FileExtenName = ""             Else                Set regEx = New RegExp                regEx.Pattern = "^.*(\.[^\.]*)$"                regEx.Global = False                regEx.IgnoreCase = True                FileExtenName = regEx.Replace(pContent, "$1")                Set regEx = Nothing                             End If                 End Function         Private Function GetRndName(byVal sLen)             Dim regEx, sTemp, arrFields, n : n = 0             Set regEx = New RegExp             regEx.Pattern = "[^\d]*"             regEx.Global = True             regEx.IgnoreCase = True             sTemp = regEx.Replace(Now, "") & "-"             Set regEx = Nothing                      arrFields = Array("0", "1", "2", "3", "4", "5", "6", "7", "8", "9", _                                "a", "b", "c", "d", "e", "f", "g", "h", "i", "j", _                                "k", "l", "m", "n", "o", "p", "q", "r", "s", "t", _                               "u", "v", "w", "x", "y", "z", "A", "B", "C", "D", _                               "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", _                               "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", _                               "Y", "Z")             Randomize             Do While n < sLen                sTemp = sTemp & CStr(arrFields(61 * Rnd))                n = n + 1             Loop             GetRndName = sTemp         End Function         Private Function SaveUpload             Dim isValidate             Dim filePath, oStreamGet, oStreamPut             isValidate = CheckFile             If isValidate Then                For i = 0 To itemCount - 1                    If (dataStart(i) <> "") And (dataLength(i) <> "") Then                        If dataLength(i) = 0 Then                           itemData(i) = ""                         Else                           filePath = Server.MapPath(itemData(i))                           If CreateFolder("|", ParentFolder(filePath)) Then                                                        Set oStreamGet = Server.CreateObject("ADODB.Stream")                              oStreamGet.Type = 1                              oStreamGet.Mode = 3                              oStreamGet.Open                              oStreamGet.Write formData                              oStreamGet.Position = dataStart(i)                              Set oStreamPut = Server.CreateObject("ADODB.Stream")                              oStreamPut.Type = 1                              oStreamPut.Mode = 3                              oStreamPut.Open                              oStreamPut.Write oStreamGet.Read(dataLength(i))                              oStreamPut.SaveToFile(filePath)                              oStreamGet.Close                              Set oStreamGet = Nothing                              oStreamPut.Close                              Set oStreamPut = Nothing                           End If                          End If                                       End If                Next                Finished = True                Call ItemToColl             Else                               Finished = False             End If         End Function         Private Function CheckFile             Dim oBoolean : oBoolean = True             If cFields = "" Then                oBoolean = oBoolean And True             Else                For i = 0 To itemCount - 1                    If extenArr(i) <> "" Then                       If InStr(1, Ucase(cFields), "|" & Ucase(Mid(extenArr(i), 2)) & "|") > 0 Then                          oBoolean = oBoolean And True                       Else                          sErrors = sErrors & "表单[ " & itemName(i) & " ]的文件格式错误！\n" & _                                              "支持的格式为：" & Replace(Mid(cFields, 2, Len(cFields) - 1), "|", " ") & "\n\n"                          oBoolean = oBoolean And False                            End If                    End If                 Next             End If             CheckFile = oBoolean         End Function         Private Function CreateFolder(byVal sLine, byVal sPath)             Dim oFso             Set oFso = Server.CreateObject("Scripting.FileSystemObject")             If Not oFso.FolderExists(sPath) Then                Dim regEx                Set regEx = New RegExp                regEx.Pattern = "^(.*)\\([^\\]*)$"                regEx.Global = False                regEx.IgnoreCase = True                   sLine = sLine & regEx.Replace(sPath, "$2") & "|"                sPath = regEx.Replace(sPath, "$1")                     If CreateFolder(sLine, sPath) Then CreateFolder = True                 Set regEx = Nothing             Else                If sLine = "|" Then                   CreateFolder = True                Else                   Dim sTemp : sTemp = Mid(sLine, 2, Len(sLine) - 2)                   If InStrRev(sTemp, "|") = 0 Then                      sLine = "|"                      sPath = sPath & "\" & sTemp                                Else                      Dim Folder : Folder = Mid(sTemp, InStrRev(sTemp, "|") + 1)                      sLine = "|" & Mid(sTemp, 1, InStrRev(sTemp, "|") - 1) & "|"                      sPath = sPath & "\" & Folder                   End If                   oFso.CreateFolder sPath                   If CreateFolder(sLine, sPath) Then CreateFolder = True                             End if             End If             Set oFso = Nothing           End Function         Function ParentFolder(byVal sPath)             Dim regEx             Set regEx = New RegExp             regEx.Pattern = "^(.*)\\[^\\]*$"             regEx.Global = True             regEx.IgnoreCase = True             ParentFolder = regEx.Replace(sPath, "$1")             Set regEx = Nothing                      End Function         Private Function StrToByte(byVal sText)              For i = 1 To Len(sText)                               StrToByte = StrToByte & ChrB(Asc(Mid(sText, i, 1)))                Next         End Function         Private Function ByteToStr(byVal sByte)             Dim oStream             Set oStream = Server.CreateObject("ADODB.Stream")             oStream.Type = 2             oStream.Mode = 3             oStream.Open             oStream.WriteText sByte             oStream.Position = 0             oStream.CharSet = "gb2312"             oStream.Position = 2             ByteToStr = oStream.ReadText             oStream.Close              Set oStream = Nothing                  End Function         Private Function ItemToColl             For i = 0 To itemCount - 1                 If Not Form.Exists(itemName(i)) Then                    Form.Add itemName(i), itemData(i)                 End If             Next         End Function         Private Sub Class_Terminate             Form.RemoveAll             Set Form = Nothing         End Sub     End Class     If Request.ServerVariables("REQUEST_METHOD") = "POST" Then        Rem 建立上传类实例               Set oUpload = New Upload        Rem 指定允许上传文件的类型        oUpload.CheckFields = "|GIF|BMP|JPG|"        Rem 指定上传文件所存储的相对路径        oUpload.Folder = "51JS.COM-ZMM/UploadFile"        Rem 开始上传处理        oUpload.Start        If oUpload.Finished Then           Rem 上传成功，显示上传信息           Dim sHtml : sHtml = ""           sHtml = sHtml & "<center>"           sHtml = sHtml & ""           sHtml = sHtml & "<center style=""font-size: 15pt;color: red;"">上传表单数据</center>"           sHtml = sHtml & "标题：" & oUpload.Form("P_title") & ""           sHtml = sHtml & "类型：" & oUpload.Form("P_assort") & ""           sHtml = sHtml & "小图：服务器端路径：" & oUpload.Form("P_image_s") & "<a href="javascript:;" onclick="showimg('/UploadFiles/2021-04-02/');"><img src="/UploadFiles/2021-04-02/" alt="写了几个类，希望对大家有用。" onmousewheel="return bbimg(this)" onload="javascript:resizepic(this)" border="0"/></a>"           sHtml = sHtml & "中图：服务器端路径：" & oUpload.Form("P_image_m") & "<img src="">"           sHtml = sHtml & "大图：服务器端路径：" & oUpload.Form("P_image_b") & "<img src="">"           sHtml = sHtml & "介绍：" & oUpload.Form("P_content") & ""                              sHtml = sHtml & ""           sHtml = sHtml & "</center>"           Response.Write sHtml           Response.End        Else           Rem 上传失败，显示错误信息           Call ShowMsg(oUpload.ErrMessage, Request.ServerVariables("SCRIPT_NAME"))        End If        Rem 对话框提示函数        Function ShowMsg(byVal sText, byVal sTarget)            Dim sScript : sScript = ""            sScript = sScript & ""            Response.Write sScript            Response.End        End Function               End If %> <html> <head> <title>多文件、表单混合上传类</title> <meta http-equiv="Content-Type" content="text/html; charset=gb2312"> <style type="text/css">     body {            margin: 0px;            border: 0px;            font-size: 10pt;     }     table {            border-collapse: collapse;            font-size: 10pt;     }     td {            font-size: 10pt;     } </style>  </head> <body>         </body> </html>

[Ctrl+A 全选注:引入外部Js需再刷新一下页面才能执行]
8.TabPage类

[Ctrl+A 全选注:引入外部Js需再刷新一下页面才能执行]

写了几个类，希望对大家有用。