📄 crtfdocument.cls
字号:
'
End Select
Next
'页眉页脚替换
Dim strPgHd As String
Dim strAlignment As String
Select Case mvarPageNumberAlign
Case alm1_左端对齐
strAlignment = "\posxl"
Case alm2_居中对齐
strAlignment = "\posxc"
Case Else
strAlignment = "\posxr"
End Select
Dim strAlignTMP As String
'页眉对齐方式：
Select Case mvarPageHeadAlign
Case alm1_左端对齐
strAlignTMP = "\ql"
Case alm3_居右对齐
strAlignTMP = "\qr"
Case alm4_两端对齐
strAlignTMP = "\qj"
Case alm5_分散对齐
strAlignTMP = "\qd"
Case Else '默认居中
strAlignTMP = "\qc"
End Select
If mvarPageHead <> "" Then
strPgHd = "{\header \pard\plain \s15" & strAlignTMP & " \li0\ri0\nowidctlpar\brdrb\brdrs\brdrw15\brsp20 " & _
"\tqc\tx4153\tqr\tx8306\aspalpha\aspnum\faauto\nosnaplinegrid\adjustright\rin0\lin0\itap0 \fs18\lang1033\langfe2052\kerning2\loch\af0\hich\af0\dbch\af13\cgrid\langnp1033\langfenp2052 {\insrsid13047022 \loch\af0\hich\af0\dbch\f13 " & StrToASC(mvarPageHead) & "}{" & _
"\insrsid13047022\par}}"
End If
If mvarPageFooter <> "" Then
strPgHd = strPgHd & "{\footer \pard\plain \s16\ql \li0\ri0\nowidctlpar\tqc\tx4153\tqr\tx8306\pvpara\phmrg" & strAlignment & "\posy0\aspalpha\aspnum\faauto\nosnaplinegrid\adjustright\rin0\lin0\itap0"
If mvarPageNumber Then
strPgHd = strPgHd & "\pararsid2622169 \fs18\lang1033\langfe2052\kerning2\loch\af0\hich\af0\dbch\af13\cgrid\langnp1033\langfenp2052 -\chpgn -{\cs17\insrsid13047022 \par }"
End If
'页脚对齐方式：
Select Case mvarPageFooterAlign
Case alm1_左端对齐
strAlignTMP = "\ql"
Case alm3_居右对齐
strAlignTMP = "\qr"
Case alm4_两端对齐
strAlignTMP = "\qj"
Case alm5_分散对齐
strAlignTMP = "\qd"
Case Else '默认居中
strAlignTMP = "\qc"
End Select
strPgHd = strPgHd & "\pard \s16" & strAlignTMP & " \li0\ri360\nowidctlpar\tqc\tx4153\tqr\tx8306\aspalpha\aspnum\faauto\nosnaplinegrid\adjustright\rin360\lin0\itap0\pararsid13047022 {\insrsid13047022 \loch\af0\hich\af0\dbch\f13 " & StrToASC(mvarPageFooter) & "}{\insrsid13047022 \par }}"
End If
'页眉页脚处理
mRTFHead = Replace(mRTFHead, "<页眉页脚>", strPgHd)
'文档属性处理
Dim strDoc As String
If mvarPaperWidth <= 0 And mvarPaperHeight <= 0 Then
'没有定义页面宽度与高度，则看其PaperSize是否存在，否则为默认值。
'逻辑上一英寸约为 1440 缇，一厘米为 567 缇 ( 在显示时，屏幕项目的长度是用英寸或厘米测量的 )。
Select Case mvarPaperSize
Case 1
strDoc = "\paperw" & CLng(21.59 * 567) & "\paperh" & CLng(27.94 * 567)
Case 2
strDoc = "\paperw" & CLng(27.94 * 567) & "\paperh" & CLng(43.17 * 567)
Case 3
strDoc = "\paperw" & CLng(21.59 * 567) & "\paperh" & CLng(35.56 * 567)
Case 4
strDoc = "\paperw" & CLng(29.7 * 567) & "\paperh" & CLng(42 * 567)
Case 5
strDoc = "\paperw" & CLng(21 * 567) & "\paperh" & CLng(29.7 * 567)
Case 6
strDoc = "\paperw" & CLng(14.8 * 567) & "\paperh" & CLng(21 * 567)
Case 7
strDoc = "\paperw" & CLng(25.7 * 567) & "\paperh" & CLng(36.4 * 567)
Case 8
strDoc = "\paperw" & CLng(18.2 * 567) & "\paperh" & CLng(25.7 * 567)
Case Else
strDoc = "\paperw11906\paperh16838" '默认值
End Select
Else
If mvarPaperWidth > 0 Then
strDoc = "\paperw" & mvarPaperWidth
Else '默认宽度11906
strDoc = "\paperw11906"
End If
If mvarPaperHeight > 0 Then
strDoc = strDoc & "\paperh" & mvarPaperHeight
Else '默认宽高16838
strDoc = strDoc & "\paperh16838"
End If
End If
If mvarMarginLeft > 0 Then
strDoc = strDoc & "\margl" & mvarMarginLeft
Else '默认1800
strDoc = strDoc & "\margl1800"
End If
If mvarMarginRight > 0 Then
strDoc = strDoc & "\margr" & mvarMarginRight
Else '默认1800
strDoc = strDoc & "\margr1800"
End If
If mvarMarginTop > 0 Then
strDoc = strDoc & "\margt" & mvarMarginTop
Else '默认1440
strDoc = strDoc & "\margt1440"
End If
If mvarMarginBottom > 0 Then
strDoc = strDoc & "\margb" & mvarMarginBottom
Else '默认1440
strDoc = strDoc & "\margb1440"
End If
If mvarMarginGutter > 0 Then
strDoc = strDoc & "\gutter" & mvarMarginGutter
Else '默认0
strDoc = strDoc & "\gutter0"
End If
'窗体标题
If mvarCaption <> "" Then strDoc = strDoc & "{\windowcaption" & StrToASC(mvarCaption) & "}"
If mvarDefaultTabWidth > 0 Then
strDoc = strDoc & "\deftab" & mvarDefaultTabWidth
Else
strDoc = strDoc & "\deftab420"
End If
strDoc = strDoc & "\ftnbj\aenddoc\hyphcaps0\formshade"
If mvarDrawingDirection = dwd1_垂直绘图 Then
strDoc = strDoc & "\vertsect"
Else
strDoc = strDoc & "\horzsect"
End If
strDoc = strDoc & "\dgmargin\dghspace180\dgvspace156\dghorigin1797\dgvorigin1440\dghshow1\dgvshow2\jcompress\lnongrid"
If mvarViewKind > 0 Then
strDoc = strDoc & "\viewkind" & mvarViewKind
Else
strDoc = strDoc & "\viewkind1"
End If
If mvarViewScale > 0 Then
strDoc = strDoc & "\viewscale" & mvarViewScale
Else
strDoc = strDoc & "\viewscale100"
End If
strDoc = strDoc & "\pgbrdrhead\pgbrdrfoot\pgbrdrsnap\splytwnine\ftnlytwnine\htmautsp\useltbaln\alntblind\lytcalctblwd\lyttblrtgr\lnbrkrule\nobrkwrptbl\snaptogridincell\allowfieldendsel\wrppunct\asianbrkrule\rsidroot10699452\newtblstyruls\nogrowautofit "
'替换文档属性文本
mRTFHead = Replace(mRTFHead, "<文档属性>", strDoc)
'节格式处理（边框处理）
Dim strSect As String
Dim strBorderStyle As String, strBorderWidth As String, strBorderColor As String
If mvarPageBorderArt > 0 Then '艺术边框，1～165
If mvarPageBorderArt <= 165 Then
strBorderStyle = "\brdrart" & mvarPageBorderArt
Else
strBorderStyle = "\brdrnone"
End If
Else
Select Case mvarPageBorderStyle
Case cbs01_无边框
strBorderStyle = "\brdrnone"
Case cbs02_单倍厚度边框
strBorderStyle = "\brdrs"
Case cbs03_双倍厚度边框
strBorderStyle = "\brdrth"
Case cbs04_阴影边框
strBorderStyle = "\brdrsh"
Case cbs05_双边框
strBorderStyle = "\brdrdb"
Case cbs06_点线边框
strBorderStyle = "\brdrdot"
Case cbs07_虚线边框
strBorderStyle = "\brdrdash"
Case cbs08_细线边框
strBorderStyle = "\brdrhair"
Case cbs09_插入式边框
strBorderStyle = "\brdrinset"
Case cbs10_虚线细边框
strBorderStyle = "\brdrdashsm"
Case cbs11_点划线边框
strBorderStyle = "\brdrdashd"
Case cbs12_点点划线边框
strBorderStyle = "\brdrdashdd"
Case cbs13_初始边框
strBorderStyle = "\brdroutset"
Case cbs14_三重边框
strBorderStyle = "\brdrtriple"
Case cbs15_厚薄叠加细边框
strBorderStyle = "\brdrtnthsg"
Case cbs16_薄厚叠加细边框
strBorderStyle = "\brdrthtnsg"
Case cbs17_薄厚薄叠加细边框
strBorderStyle = "\brdrtnthtnsg"
Case cbs18_厚薄叠加中边框
strBorderStyle = "\brdrtnthmg"
Case cbs19_薄厚叠加中边框
strBorderStyle = "\brdrthtnmg"
Case cbs20_薄厚薄叠加中边框
strBorderStyle = "\brdrtnthtnmg"
Case cbs21_厚薄叠加粗边框
strBorderStyle = "\brdrtnthlg"
Case cbs22_薄厚叠加粗边框
strBorderStyle = "\brdrthtnlg"
Case cbs23_薄厚薄叠加粗边框
strBorderStyle = "\brdrtnthtnlg"
Case cbs24_波浪线边框
strBorderStyle = "\brdrwavy"
Case cbs25_双波浪线边框
strBorderStyle = "\brdrwavydb"
Case cbs26_条纹边框
strBorderStyle = "\brdrdashdotstr"
Case cbs27_浮雕边框
strBorderStyle = "\brdremboss"
Case cbs28_雕刻边框
strBorderStyle = "\brdrengrave"
Case Else '默认单边框
strBorderStyle = "\brdrs"
End Select
End If
'边框宽度
If mvarPageBorderWidth <> 0 Then
strBorderWidth = "\brdrw" & mvarPageBorderWidth
Else '默认宽度15
strBorderWidth = "\brdrw15"
End If
If mvarPageBorderColor <> clr00_默认 Then
strBorderColor = "\brdrcf" & mvarPageBorderColor
End If
strSect = "\fet0\sectd \linex0\headery851\footery992\colsx425\endnhere"
Dim strPgBrdSpc As String
If mvarPageBorderSpace > 0 Then
strPgBrdSpc = "\brsp" & mvarPageBorderSpace
Else
strPgBrdSpc = "\brsp480"
End If
'生成单元格边框定义语句
If mvarPageBorderArt > 0 Then '艺术型边框的宽度默认为50，间距为480，颜色为空
strSect = strSect & "\pgbrdrt" & strBorderStyle & "\brdrw50" & strPgBrdSpc & vbCrLf
strSect = strSect & "\pgbrdrb" & strBorderStyle & "\brdrw50" & strPgBrdSpc & vbCrLf
strSect = strSect & "\pgbrdrl" & strBorderStyle & "\brdrw50" & strPgBrdSpc & vbCrLf
strSect = strSect & "\pgbrdrr" & strBorderStyle & "\brdrw50" & strPgBrdSpc & vbCrLf
ElseIf mvarPageBorderStyle <> cbs00_默认边框样式 Then
strSect = strSect & "\pgbrdrt" & strBorderStyle & strBorderWidth & strBorderColor & strPgBrdSpc & vbCrLf
strSect = strSect & "\pgbrdrb" & strBorderStyle & strBorderWidth & strBorderColor & strPgBrdSpc & vbCrLf
strSect = strSect & "\pgbrdrl" & strBorderStyle & strBorderWidth & strBorderColor & strPgBrdSpc & vbCrLf
strSect = strSect & "\pgbrdrr" & strBorderStyle & strBorderWidth & strBorderColor & strPgBrdSpc & vbCrLf
End If
strSect = strSect & "\sectlinegrid312\sectspecifyl\sectrsid11756820\sftnbj "
'替换节格式属性文本
mRTFHead = Replace(mRTFHead, "<节属性>", strSect)
TextRTF = LinkRTF(mRTFHead, mRTFBody, "}")
If Me.FileName = "" Then
Save = False
Exit Function
End If
Const ForReading = 1, ForWriting = 2, ForAppending = 3
Dim fs As FileSystemObject, f As TextStream
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.OpenTextFile(FileName, ForWriting, TristateUseDefault)
f.Write Me.TextRTF
f.Close
Save = True
Exit Function
LL:
Save = False
End Function
Public Function AddText(Optional Text As String, Optional sKey As String, _
Optional Alignment As AlignTypeEnum = alm0_默认对齐, _
Optional Bold As Boolean = False, _
Optional Italic As Boolean = False, Optional ForeColor As ColorEnum = clr00_默认, _
Optional FontSize As FontSizeEnum = fs00_默认, Optional FontStyle As FontStyleEnum = ft0_正文, _
Optional CharStyle As CharStyleEnum = cs默认, Optional AnimType As AnimTypeEnum = ani0_无, _
Optional ScaleX As Long = 100, Optional Embo As EmboEnum = emb0_无, _
Optional Expand As Long = 0, Optional OutLine As Boolean = False, _
Optional Shadow As Boolean = False, Optional Strike As Boolean = False, _
Optional StrikeD As Boolean = False, Optional SubChar As Boolean = False, _
Optional SuperChar As Boolean = False, Optional UnderLineType As UnderLineTypeEnum = udl00_无, _
Optional UnderLineColor As ColorEnum = clr00_默认, Optional Hided As Boolean = False, _
Optional WebHidden As Boolean = False, Optional CharBorder As Boolean = False, _
Optional CharShadow As Long = 100, Optional CharPatForeColor As ColorEnum = clr00_默认, _
Optional CharPatBackColor As ColorEnum = clr00_默认, Optional PatType As PatTypeEnum = ptt00_无, _
Optional Highlight As Boolean = False, Optional HighlightColor As ColorEnum = clr00_默认, _
Optional ListType As ListTypeEnum = ltp00_无, _
Optional IsInTable As Boolean = False) As Long
Attribute AddText.VB_Description = "向文档中添加一段文本。"
Dim i As Long
i = Texts.Add(Text, sKey, Alignment, Bold, Italic, ForeColor, FontSize, FontStyle, CharStyle, _
AnimType, ScaleX, Embo, Expand, OutLine, Shadow, Strike, StrikeD, _
SubChar, SuperChar, UnderLineType, UnderLineColor, Hided, WebHidden, CharBorder, _
CharShadow, CharPatForeColor, CharPatBackColor, PatType, Highlight, HighlightColor, ListType, IsInTable)
AddText = i
Nodes.Add i, "文本"
End Function
Public Function AddParagraph(Optional sKey As String, Optional IsInTable As Boolean = False, _
Optional SpaceBefore As Long = 0, Optional SpaceAfter As Long = 0, _
Optional SpaceLine As Long = 0, Optional SpaceFirstLine As Long = 0, _
Optional FontSizeDefault As Long = 0) As Long
Dim i As Long
i = Paragraphs.Add(sKey, IsInTable, SpaceBefore, SpaceAfter, SpaceLine, SpaceFirstLine, FontSizeDefault)
AddParagraph = i
Nodes.Add i, "段落"
End Function
Public Function AddPicture(Optional FileName As String, _
Optional Width As Long = 0, _
Optional Height As Long = 0, _
Optional Alignment As AlignTypeEnum = alm0_默认对齐, _
Optional sKey As String, _
Optional ScaleX As Long = 100, _
Optional ScaleY As Long = 100, _
Optional CropLeft As Long = 0, _
Optional CropRight As Long = 0, _
Optional CropTop As Long = 0, _
Optional CropBottom As Long = 0, _
Optional WidthOld As Long = 100, _
Optional HeightOld As Long = 100, _
Optional PicType As PicTypeEnum = pic_JPG, _
Optional AddCRLF As Boolean = True) As Long
Attribute AddPicture.VB_Description = "向文档中添加一幅图片。"
Dim i As Long
Dim picSize As ImageSizeInf
Dim lngWidth As Long, lngHeight As Long
picSize = GetImageSize(FileName)
lngWidth = picSize.Width * Screen.TwipsPerPixelX
lngHeight = picSize.Height * Screen.TwipsPerPixelY
If Width = 0 Then Width = lngWidth
If Height = 0 Then Height = lngHeight
i = Pictures.Add(FileName, Width, Height, Alignment, sKey, ScaleX, ScaleY, CropLeft, CropRight, _
CropTop, CropBottom, lngWidth, lngHeight, PicType, AddCRLF)
AddPicture = i
Nodes.Add i, "图片"
End Function
Public Function AddTable(Optional RowCount As Long = 1, Optional ColCount As Long = 1, _
Optional Alignment As RowAlignTypeEnum = ral0_默认对齐, _
Optional sKey As String) As Long
Attribute AddTable.VB_Description = "向文档中添加一个表格。"
Dim i As Long
i = Tables.Add(RowCount, ColCount, Alignment, sKey)
AddTable = i
Nodes.Add i, "表格"
End Function
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -