📄 clscollection.cls
字号:
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "clsCollection"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
Option Explicit
'**************************************************************
'*类模块名称：clsCollection
'*类模块说明：clsText的集合
'*
'*备注：
'*
'*作者：chlf78
'*日期：2002-04-05 14:46:00
'***************************************************************
Private Const ModalName = "clsCollection"
Private dicText As Dictionary '*存入字符串的集合
Public Enum typeAlignMode
tyContent = 0 '*以表体为对齐参照
tyPage = 1 '*以页面为对齐参照
End Enum
Public AlignMode As typeAlignMode '*集合对齐的对象（页面，或是表体）
Public Property Get texts() As Dictionary
Set texts = dicText
End Property
'**************************************************************
'*名称：GetText
'*功能：得到一个字符串对象
'*传入参数：
'* key --关键字
'*返回参数：
'* 字符串
'*作者：chlf78
'*日期：2002-04-05 14:49:51
'**************************************************************
Public Function GetText(key As String) As clsText
If dicText.Exists(key) Then
Set GetText = dicText.item(key)
Else
Set GetText = Nothing
End If
End Function
'**************************************************************
'*名称：AddText
'*功能：添加一个字符串
'*传入参数：
'* key --关键字
'* text --字符串
'*返回参数：
'*
'*作者：chlf78
'*日期：2002-03-27 15:24:18
'***************************************************************
Public Function AddText(key As String, text As clsText) As Boolean
On Error GoTo err_proc:
If dicText.Exists(key) Then
AddText = False
Exit Function
End If
'*使用额外标签存储key值，以用于模板文件的读取和保存
text.tag = key
dicText.Add key, text
AddText = True
Exit Function
err_proc:
AddText = False
End Function
'**************************************************************
'*名称：RemoveText
'*功能：删除一个字符串
'*传入参数：
'* key --关键字
'*返回参数：
'*
'*作者：chlf78
'*日期：2002-03-27 15:24:18
'***************************************************************
Public Function RemoveText(key As String) As Boolean
If dicText.Exists(key) Then
dicText.Remove key
RemoveText = True
Else
RemoveText = False
End If
End Function
'**************************************************************
'*名称：EditText
'*功能：修改一个字符串
'*传入参数：
'* key --关键字
'* text --字符串
'*返回参数：
'* 是否修改成功
'*作者：chlf78
'*日期：2002-03-27 15:24:18
'***************************************************************
Public Function EditText(key As String, text As clsText) As Boolean
On Error GoTo err_proc:
If dicText.Exists(key) Then
Set dicText.item(key) = text
EditText = True
Else
EditText = False
End If
Exit Function
err_proc:
EditText = False
End Function
'**************************************************************
'*名称：GetHeight
'*功能：得到集合占用的高度
'*传入参数：
'*
'*返回参数：
'*
'*作者：chlf78
'*日期：2002-04-05 15:01:14
'***************************************************************
Public Function GetHeight() As Single
Dim cText
GetHeight = 0
For Each cText In dicText.Items
If cText.height = 0 Then
cText.height = cText.GetHeight
End If
GetHeight = GetHeight + cText.height
Next
End Function
'**************************************************************
'*名称：GetWidth
'*功能：得到集合占用的宽度
'*传入参数：
'*
'*返回参数：
'*
'*作者：chlf78
'*日期：2002-05-07 19:46:14
'***************************************************************
Public Function GetWidth() As Single
Dim cText
GetWidth = 0
For Each cText In dicText.Items
If cText.width = 0 Then
cText.width = cText.GetWidthVer
End If
GetWidth = GetWidth + cText.width
Next
End Function
'**************************************************************
'*名称：PrintIt
'*功能：输出此对象
'*传入参数：
'* obj --要输出的对象
'* width --可供打印的宽度
'* left --左起点
'* top --顶起点
'* pages --所有页数
'* cutpages --所有分页数
'* page --页数
'* cutpage --分页数
'*作者：chlf78
'*日期：2002-04-09 21:46:51
'***************************************************************
Public Sub PrintIt(obj As Object, width As Single, _
left As Single, Top As Single, _
pages As Integer, cutpages As Integer, _
page As Integer, cutpage As Integer, _
sRate As Single)
Dim cText
Dim sHeight As Single
Dim str As String
Dim strLeft As String, strMiddle As String, strRight As String
sHeight = 0
For Each cText In dicText.Items
With cText
'*暂存原始字符串
str = .stringX
.stringX = rplStr(.stringX, pages, cutpages, page, cutpage)
'*将字符串分离成左中右三段
SplitStr .stringX, strLeft, strMiddle, strRight
If .rowheight = 0 Then
.rowheight = .GetHeight
End If
If .height = 0 Then
.height = .GetHeight
End If
.Top = Top + sHeight
If strMiddle = "" And strRight = "" Then
.width = CalWidth(.stringX, .fontsize) + 2 * MYSPACE + 0.0001
Select Case .Align
Case tyLeft
.left = left
Case tymiddle
.left = left + (width - .width) / 2
Case tyRight '*如果是右对齐，可以无限制将left向左靠
.left = left + width - .width
End Select
Else
'*输出左段
.left = left
.stringX = strLeft
.width = CalWidth(.stringX, .fontsize) + 2 * MYSPACE + 0.0001
.PrintIt obj, sRate
'*输出中段
.stringX = strMiddle
.width = CalWidth(.stringX, .fontsize) + 2 * MYSPACE + 0.0001
.left = left + (width - .width) / 2
.PrintIt obj, sRate
'*输出右段
.stringX = strRight
.width = CalWidth(.stringX, .fontsize) + 2 * MYSPACE + 0.0001
.left = left + width - .width
.PrintIt obj, sRate
End If
.PrintIt obj, sRate
'*恢复
.stringX = str
sHeight = sHeight + .height
End With
Next
End Sub
'**************************************************************
'*名称：PrintItVer
'*功能：输出此对象(竖向）
'*传入参数：
'* obj --要输出的对象
'* width --可供打印的宽度
'* left --左起点
'* top --顶起点
'* pages --所有页数
'* cutpages --所有分页数
'* page --页数
'* cutpage --分页数
'*作者：chlf78
'*日期：2002-05-07 19:48:51
'***************************************************************
Friend Sub PrintItVer(obj As Object, height As Single, _
left As Single, Top As Single, _
pages As Integer, cutpages As Integer, _
page As Integer, cutpage As Integer, _
sRate As Single)
Dim cText
Dim sWidth As Single
Dim str As String
sWidth = 0
For Each cText In dicText.Items
With cText
str = .stringX
.stringX = rplStr(.stringX, pages, cutpages, page, cutpage)
.left = left + sWidth
.height = CalHeight(.fontsize) * Len(.stringX)
'*如果是底对齐，可以无限制将top向左靠
Select Case .Align
Case tyLeft
.Top = Top
Case tymiddle
.Top = Top + (height - .height) / 2
Case tyRight
.Top = Top + height - .height
End Select
If .rowheight = 0 Then
.rowheight = .GetHeight
End If
If .height = 0 Then
.height = .GetHeight
End If
.PrintItVer obj, sRate
'*恢复
.stringX = str
sWidth = sWidth + .width
End With
Next
End Sub
Private Sub Class_Initialize()
'*初始化对象
Set dicText = New Dictionary
AlignMode = tyContent
End Sub
Private Sub Class_Terminate()
'*销毁对象
Set dicText = Nothing
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -