util.lss

最新推荐文章于 2021-10-13 10:22:45 发布

daluoboequalto

最新推荐文章于 2021-10-13 10:22:45 发布

阅读量816

点赞数

分类专栏： Domino 文章标签： function integer string class query dictionary

本文链接：https://blog.csdn.net/daluoboequalto/article/details/458255

版权

Domino 专栏收录该内容

6 篇文章 0 订阅

订阅专栏

'Option Public
'Option Explicit
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Lib com.OnceATime.LS.UTIL
'  ---- By FangZeYu(OnceATime@163.com)
'  ---- By LuHong(ChongBugLH@163.com)
'  ---- 2003-10 BeiJing
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 版权声明：
' 软件可以自由传播修改，亦默认有商业行为允许。
'  但任何时候，请保留原始作者信息。
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 功能列表：
' 类： ListEx：  有点类似其它高级语言中的collection list功能，需增强
'   ArrayEx：  简单的增强数组
'   QueryURL：  解析query_string
   MyCollection： collection类
' 函数： UtilSplit：拆分字符串
'   UtilJoin：合并字符串
'   UtilReplace：查找替换
'   UtilEscape：编码
'   UtilUnescape：解码
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 修订历史：
' 1、2003年10月，草拟
' 2、2004年09月，整理修订
' 3、2004年12月，添加了以前做的MyCollection类
'
'
'
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Class BObject

Public Property Get ClassName As String
  ClassName=Typename(Me)
End Property

Private Function m_ShowError(strSubName)
  Msgbox "(Class "+Me.ClassName+" -> "+strSubName+") Error On Line " & Erl & " With Code Of " & Err & " Msg Is " & Error
End Function
End Class
Dim UTIL_EMPTY    '定义一个可以使用的empty变量，在程序中使用：）
Const UTIL_NULL=Null
Public Class URLQuery
Private m_query As String
Public Sub new(strQuery As String)
  m_query=strQuery+"&OnceATime.Com.Cn"
End Sub
Public Function GetAttribute(strAttName ) As String
  Dim pos1 As Integer,pos2 As Integer
  pos1=Instr(Lcase(m_query) , "&"+Lcase(strAttName)+"=")
  If pos1=0 Then Exit Function  ' 如果没有找到，则当做是空字符串
  pos2=Instr( pos1+Len("&"+strAttName+"="),m_query,"&")
  GetAttribute=Mid(m_query , pos1+Len("&"+strAttName+"=") , pos2-pos1-Len("&"+strAttName+"="))
End Function
Public Function GetParameter(strParName) As String
  GetParameter=GetAttribute(strParName)
End Function

Public Function HasAttribute(strAttName) As Long
  ' tobe : &par1= or &par1&
  ' true
  HasAttribute=True
  Dim str1 As String
  str1="&" & strAttName & "="
  If Instr(m_query , str1) > 0 Then Exit Function

  str1="&" & strAttName & "&"
  If Instr(m_query , str1) > 0 Then Exit Function

  HasAttribute=False
End Function
Public Function HasParameter(strParName) As Long
  HasParameter=HasAttribute(strParName)
End Function
End Class

Public Class ListEx
'
' 一个类js中的list array （主要体现的是list功能，array没有体现，可以在以后加）
' 放弃了错误处理，原因是……    所有这些，再次让我厌倦！
' 简单约束，function返回true false的时候，使用integer ，一般的-1为true ，0为false，这样做的原因也无需说明
'   null为无效值和空值，没有考虑object
'
Private m_data List As Variant
Public Sub New()
' 因为在ls中实现多态或者类似效果比较复杂，得不偿失，所以这里放弃Init Data内容
%REM
其实也可以这么做： Sub New(initData)
      if isempty(initData)
     end sub
引用的时候：对于无initData，这样的初始化，New ListEx(UTIL_EMPTY)
%END REM
End Sub
Public Property Set Item(strName As String) As Variant
  If Isnull(Item) Then
   Me.DeleteItem strName
   Exit Property
  End If
  m_data(strName)=Item
End Property
Public Property Get Item(strName As String ) As Variant
  If Me.HasItem(strName)=False Then
   Item=UTIL_NULL
   Exit Property
  End If
  Item=m_data(strName)
End Property
Public Function DeleteItem(strName As String) As Integer
  Erase m_data(strName)
End Function
Public Function HasItem(strName As String) As Integer
  If Iselement(m_data(strName)) Then
   HasItem=True
  Else
   HasItem=False
  End If
End Function
Public Function GetItem(strName As String) As Variant
  GetItem=Me.Item(strName)
End Function
Public Function SetItem(strName As String , vValue As Variant ) As Integer
  Me.Item(strName)=vValue
End Function
End Class

Public Class ArrayEx
Private m_SizeStep As Long
Private m_Size As Long
Private m_Top As Long
Private m_Data() As Variant
Public Sub new(lngSizeStep)
  If Isempty(lngSizeStep) Then
   m_SizeStep=1000
  Else
   m_SizeStep=Clng(lngSizeStep)
  End If
  Me.SizeStep=m_SizeStep
End Sub
Public Property Set SizeStep As Long
  m_SizeStep=SizeStep
  Redim m_Data(m_SizeStep)
  m_Top=m_SizeStep
  m_Size=-1
End Property
Public Property Get Data
  If m_Size < 0 Then m_Size=0
  If m_Top<>m_Size Then
   Redim Preserve m_Data(m_Size)
   m_Top=m_Size
  End If
  Data=m_Data
End Property
Public Function Add(v1)
  m_Size=m_Size+1
  If m_Size > m_Top Then
   m_Top=m_Top+m_SizeStep
   Redim Preserve m_Data(m_Top)
  End If
  m_Data(m_Size)=v1
End Function
End Class
Function UtilSplit(Byval str1 As String , strSep As String)
If strSep="" Then
  Dim arrRet() As String
  Dim i As Long
  Redim arrRet(Len(str1)-1)
  For i=1 To Len(str1)
   arrRet(i-1)=Mid(str1 , i , 1)
  Next
  UtilSplit=arrRet
  Exit Function
End If
Dim arr1 As New ArrayEx(100)
str1=str1+strSep
While Len(str1) > 0
  arr1.Add Strleft(str1 , strSep)
  str1=Strright(str1 , strSep)
Wend
UtilSplit=arr1.Data()
End Function
Function UtilJoin(arr1 , strSep As String) As String
Dim strT As String
Forall a1 In arr1
  strT=strT+strSep+a1
End Forall
If Len(strT)>0 And Len(strSep)>0 Then
  UtilJoin=Mid(strT , Len(strSep)+1)
Else
  UtilJoin=strT
End If
End Function
Function UtilReplace(str1 As String , strFind As String , strReplace As String) As String
Dim v1
v1=UtilSplit(str1 , strFind)
UtilReplace=UtilJoin(v1 , strReplace)
End Function
Function UtilEscape(Byval strIn As String) As String
Const cstEsps="0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,44,58,59,60,61,62,63,91,92,93,94,96"
Dim vEsps
vEsps=Evaluate(|@Explode("|+cstEsps+|";",")|)
Dim str1,int1,strRet As String
Dim i As Integer
For i=1 To Len(strIn)
  str1=Mid(strIn,i,1)
  int1=Uni(str1)
  If int1>255 Then
   strRet=strRet+"%u"+Right("0000"+Hex$(int1),4)
  Elseif int1>122 Then
   strRet=strRet+"%"+Right("00"+Hex$(int1),2)
  Elseif Not Isnull(Arraygetindex(vEsps,Cstr(int1))) Then
   strRet=strRet+"%"+Right("00"+Hex$(int1),2)
  Else
'normal chars
   strRet=strRet+str1
  End If
Next
UtilEscape=strRet
End Function
Function UtilUnescape(strEscape As String) As String
On Error Goto error_handle
Dim pos1,pos2
Dim strT As String,str1 ,strRet As String
strT=strEscape
While strT<>""
  pos1=Instr(strT,"%")
  If pos1>0 Then
   strRet=strRet+Left(strT,pos1-1) '将%前的原义字符加入
    '处理转义字符
   pos2=Instr(strT,"%u") '%u
   If pos2=pos1 Then
    '如果是一个255以上的编码
    str1=Mid(strT,pos2+2,4)
    If Len(str1)<4 Then
     '不合法的字符串
     Goto error_handle
    End If
    strRet=strRet+Uchr(Clng("&H"+str1))
    strT=Right(strT,Len(strT)-pos2-5)
   Else
    str1=Mid(strT,pos1+1,2)
    If Len(str1)<2 Then
     '不合法的字符串
     Goto error_handle
    End If
    strRet=strRet+Uchr(Clng("&H"+str1))
    strT=Right(strT,Len(strT)-pos1-2)
   End If
  Else
   strRet=strRet+strT
   strT=""
  End If
Wend
UtilUnescape=strRet
Exit Function
error_handle:
UtilUnescape=""
Exit Function
End Function

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 本lib实现collection功能
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Const ArrayTop=400
Public Class MyCollection
Private mCount As Integer '所有的已经分配空间数量
Private mCountUnused As Integer '已分配空间中被回收部分数量
Private mCountUsed As Integer '已分配空间中使用部分数量
Private mIndexUsed() As Integer 'Index序列号
' Private mKeys() As String 'key键值，使用keys方式，主要为建立dictionary方式
Private mObjects() As Variant '存储分配空间
Private mIndexUnused() As Integer '被回收的序列号空间

Public Sub New()
  mCount=0
  mCountUnused=0
  Redim mIndex(0)
  Redim mKeys(0)
  Redim mObjects(0)
  Redim mIndexUnused(0)
End Sub

Public Property Get Member(intIndex As Integer)
  Set Member=mObjects(mIndexUsed(intIndex))
End Property

Public Property Set Member(intIndex As Integer)
  Set mObjects(mIndexUsed(intIndex))=Member
End Property

Public Function AddMember(vMember,intIndex As Integer)
  Dim CurPos As Integer '如果待插入点在当前的范围之外，那么，将它插入在最后
  Dim i
  If intIndex<0 Then
   CurPos=1
  Elseif intIndex<1 Or intIndex>mCountUsed Then
   CurPos=mCountUsed+1
  Else
   CurPos=intIndex
  End If
  If mCountUnused>0 Then
'从回收的空间分配
   Set mObjects(mIndexUnused(mCountUnused))=vMember
   For i=mCountUsed To CurPos Step -1
    mIndexUsed(i+1)=mIndexUsed(i)
   Next
   mIndexUsed(CurPos)=mIndexUnused(mCountUnused)
   mCountUnused=mCountUnused-1
   mCountUsed=mCountUsed+1
  Else
'新分配空间
   If mCount Mod ArrayTop=0 Then
'如果空间已经使用完毕，创建新的空间
    Redim Preserve mIndexUsed(mCount+ArrayTop)
    Redim Preserve mObjects(mCount+ArrayTop)
    Redim Preserve mIndexUnused(mCount+ArrayTop)
   End If
   For i=mCountUsed To CurPos Step -1
    mIndexUsed(i+1)=mIndexUsed(i)
   Next
   mCountUsed=mCountUsed+1
   mCount=mCount+1
   Set mObjects(mCountUsed)=vMember
   mIndexUsed(CurPos)=mCountUsed
  End If
End Function

Public Function DelMember(intIndex As Integer)
  If intIndex<1 Or intIndex>mCountUsed Then
'如果要删除的序列值在范围之外，则取消本操作
   Exit Function
  End If
  Dim i
  mCountUnused=mCountUnused+1
  mIndexUnused(mCountUnused)=mIndexUsed(intIndex)
  For i= intIndex To mCountUsed
   mIndexUsed(i)=mIndexUsed(i+1)
  Next
  mCountUsed=mCountUsed-1
End Function

Public Property Get Count As Integer
  Count=mCountUsed
End Property
End Class