VB读取EXCEL数据转化为自定义格式控件Word文档下载推荐.docx
《VB读取EXCEL数据转化为自定义格式控件Word文档下载推荐.docx》由会员分享，可在线阅读，更多相关《VB读取EXCEL数据转化为自定义格式控件Word文档下载推荐.docx（46页珍藏版）》请在冰点文库上搜索。
x1AsSingle
y1AsSingle
x2AsSingle
y2AsSingle
EndType
PrivateTypeCellData'
单元格的数据＝22＋lenb（text）
可见否
alignmentAsInteger'
对齐方式
WrapTextAsBoolean'
自动换行
NfontAsNewStdFont'
字体
线型
TextAsString'
文本字符号
x1AsSingle'
区域
y1AsSingle'
左边位置
widthAsSingle
heightAsSingle
MergRangeAsString'
包含区域
PrivateTypeBaseinfo
RolAsInteger'
行
colAsInteger'
列
widthAsSingle'
总宽
heightAsSingle'
总高
PaperSizeAsInteger
LeftMargnAsSingle'
---页边距－单位cm
TopMargnAsSingle
BottomMargnAsSingle
RightMargnAsSingle
OrientationAsInteger
PrivateTypeCells'
单元集合
BinfAsBaseinfo
Lines（）AsmyLine
DataS（）AsCellData
－－－－－－－－－－－－－－－－处理结构的函数
PrivateFunctionGetLineString（LAsmyLine,OptionalSptAsString="
"
）AsString'
获取线的
If（Spt="
）ThenSpt=Chr（8）
DimtAsString
t=L.color&
Spt
t=t&
L.NoVIsable&
L.Style&
L.Weight&
L.x1&
L.x2&
L.y1&
L.y2&
GetLineString=t
EndFunction
PrivateFunctionGetStringLine（ByValstrAsString,OptionalSptAsString="
）AsmyLine'
DimLAsmyLine
DimtAsVariant
t=Split（str,Spt）
L.color=t（0）
IfUCase（t
（1））="
TRUE"
Then
L.NoVIsable=True
Else
L.NoVIsable=False
EndIf
L.Style=t
（2）
L.Weight=t（3）
L.x1=Val（t（4））
L.x2=Val（t（5））
L.y1=Val（t（6））
L.y2=Val（t（7））
GetStringLine=L
PrivateFunctionGetFontString（FtAsStdFont,OptionalSptAsString="
获取字体的
）ThenSpt=Chr（7）
t=Ft.Bold&
Ft.Charset&
Ft.Italic&
Ft.Name&
Ft.Size&
Ft.Strikethrough&
Ft.Underline&
Ft.Weight&
GetFontString=t
PrivateSubGetStringFont（ByValstrAsString,OptionalSptAsString="
）'
AsStdFont'
'
Ft.Bold=t（0）
Ft.Charset=t
（1）
Ft.Italic=t
（2）
Ft.Name=t（3）
Ft.Size=t（4）
Ft.Strikethrough=t（5）
Ft.Underline=t（6）
Ft.Weight=t（7）
GetStringFont=Ft
EndSub
PrivateFunctionGetBaseInfoString（bfAsBaseinfo,OptionalSptAsString="
基础信息的
t=bf.BottomMargn&
bf.col&
bf.height&
bf.LeftMargn&
bf.PaperSize&
bf.RightMargn&
bf.Rol&
bf.TopMargn&
bf.width&
bf.Orientation&
GetBaseInfoString=t
PrivateFunctionGetStringBaseInfo（ByValstrAsString,OptionalSptAsString="
）AsBaseinfo'
DimbfAsBaseinfo
bf.BottomMargn=t（0）
bf.col=t
（1）
bf.height=t
（2）
bf.LeftMargn=t（3）
bf.PaperSize=t（4）
bf.RightMargn=t（5）
bf.Rol=t（6）
bf.TopMargn=t（7）
bf.width=t（8）
bf.Orientation=t（9）
GetStringBaseInfo=bf
PrivateFunctionGetDataString（DAsCellData,OptionalSptAsString="
获取数据的
）ThenSpt=Chr（6）
t=D.alignment&
D.color&
D.height&
D.MergRange&
GetFontString（D.Nfont）&
D.NoVIsable&
D.Text&
D.width&
D.WrapText&
D.x1&
D.y1&
D.Style&
GetDataString=t
PrivateFunctionGetStringData（ByValstrAsString,OptionalSptAsString="
）AsCellData'
获取字符串对应的数据的
DimDAsCellData
OnErrorResumeNext
If（t（5）=True）Then
D.NoVIsable=t（5）
D.MergRange=t（3）
GetStringData=D
ExitFunction
D.alignment=t（0）
D.color=t
（1）
D.height=Val（t
（2））
CallGetStringFont（t（4））
D.Nfont.Bold=Ft.Bold
D.Nfont.Charset=Ft.Charset
D.Nfont.Italic=Ft.Italic
D.Nfont.Name=Ft.Name
D.Nfont.Size=Ft.Size
D.Nfont.Strikethrough=Ft.Strikethrough
D.Nfont.Underline=Ft.Underline
D.Nfont.Weight=Ft.Weight
D.Text=t（6）
D.width=t（7）
D.WrapText=t（8）
D.x1=t（9）
D.y1=t（10）
D.Style=t（11）
PrivateFunctionGetCellString（CsAsCells）AsString'
读取单元格数据字符串
DimtAsString,tmpAsString
DimiAsInteger,jAsInteger
DimlgAsLong
OnErrorGoToerd
t=GetBaseInfoString（Cs.Binf）&
Chr（3）'
基础信息
tmp=GetLineString（Cs.Lines（0））&
Chr（4）'
线信息
lg=Cs.Binf.Rol*（Cs.Binf.col+1）+（Cs.Binf.Rol+1）*Cs.Binf.col
Fori=1Tolg
tmp=tmp&
GetLineString（Cs.Lines（i））&
Chr（4）
Next
tmp&
Chr（3）
tmp=GetDataString（Cs.DataS（0））&
数据信息
lg=Cs.Binf.Rol*Cs.Binf.col
If（i=30）Then
Debug.PrintCs.DataS（i）.MergRange
GetDataString（Cs.DataS（i））&
tmp
GetCellString=t
erd:
EndFunction
PrivateFunctionGetStringCell（strAsString）AsCells'
返回字符串对应的单元格数据
DimtAsVariant,tmpAsVariant
DimiAsInteger,jAsInteger,RolAsInteger,colAsInteger
DimCsAsCells
If（str="
）ThenExitFunction
t=Split（str,Chr（3））
Cs.Binf=GetStringBaseInfo（t（0））'
基础信息恢复
Rol=Cs.Binf.Rol
col=Cs.Binf.col
tmp=Split（t
（1）,Chr（4））
lg=Rol*（col+1）+col*（Rol+1）
If（InitCells（Cs,Rol,col）=False）Then
MsgBox（"
转换失败"
）
Fori=0Tolg
Cs.Lines（i）=GetStringLine（tmp（i））
tmp=Split（t
（2）,Chr（4））
lg=Rol*col
Cs.DataS（i）=GetStringData（tmp（i））
GetStringCell=Cs
--------------------
------------------
PrivateSubClass_Initialize（）'
初始化
BaseX0=0
BaseY0=0
xyScale=1
B_Ti=22
ChoseColor=RGB（32,32,32）
InitCellsMycell,1,1'
初始化为1行1列的
Viewable=False
inputFg=False
EndSub
---------------------------------------------------------------------------------------------
PrivateFunctionInitCells（ByRefOsAsCells,RolAsInteger,colAsInteger）AsBoolean'
初始化单元格集合
Os.Binf.Rol=Rol
Os.Binf.col=col
Os.Binf.height=1
Os.Binf.width=1
Os.Binf.PaperSize=vbPRPSA4'
缺省weiA4纸
ReDimOs.Lines（col*（Rol+1）+Rol*（col+1））'
每个列加1，每个行加1先横线，再竖线
ReDimOs.DataS（Rol*col）
OldArea="
进行初始化需要消除原始选择
InitCells=True
If（inputFg）Then
TxtInput.Visible=False
InitCells=False
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－EXCEL处理－－－－－－－－－－－－－－－－－－
－--------------------------------------------------------
----------------------------------------------------------
PrivateFunctionXlsString（RolAsInteger,colAsInteger,OptionalR2AsInteger=0,OptionalC2AsInteger=0）AsString'
－－返回指定位置的单元格区域字符串
If（R2=0）Then
XlsString="
$"
&
Chr（col+64）&
"
Rol
Rol&
:
Chr（C2+64）&
R2
PrivateFunctionXlsRolCol（RangeSAsString）AsVariant'
返回单元格区域字符串对应的行、列。
DimtmpAsVariant
XlsRolCol=Split（"
1;
2;
3;
4"
"
;
tmp=Split（RangeS,"
If（UBound（tmp）<
1）Then
XlsRolCol（0）=Val（Mid（RangeS,4））
XlsRolCol
（1）=Val（Mid（RangeS,2,1））
XlsRolCol
（2）=XlsRolCol（0）
XlsRolCol（3）=XlsRolCol
（1）
XlsRolCol（0）=Val（Mid（tmp（0）,4））
XlsRolCol
（1）=Val（Mid（tmp（0）,2,1））
XlsRolCol
（2）=Val（Mid（tmp
（1）,4））
XlsRolCol（3）=Val（Mid（tmp
（1）,2,1））
PrivateFunctionStyle_XLSPic（XlsStyAsLong）AsInteger
SelectCaseXlsSty
Case-4142:
Style_XLSPic=5
Case1:
Style_XLSPic=0
Case-4148:
Style_XLSPic=2
Case5:
Style_XLSPic=4
Case4:
Style_XLSPic=3
Case-4115:
Style_XLSPic=1
CaseElse:
EndSelect
PrivateFunctionGetXlsCellLine（ObjAsWorksheet,RolAsInteger,colAsInteger,staAsInteger）AsmyLine'
获取对应Excel表格的指定行列指定位置的线
sta＝0－底，1－L,2-r,3-t
DimXlsStAsString
DimstrAsString
Dimx0AsSingle
Dimy0AsSingle
DimWAsSingle,HAsSingle
DimGlAsmyLine
SelectCasesta
Case0:
XlsSt=xlEdgeBottom
XlsSt=xlEdgeLeft
Case2:
XlsSt=xlEdgeRight
Case3:
XlsSt=xlEdgeTop
x0=0
y0=0
W=Obj.Cells（Rol,col）.width
H=Obj.Cells（Rol,col）.height
Gl.color=Obj.Cells（Rol,col）.Borders（XlsSt）.color
Gl.Style=Style_XLSPic（Obj.Cells（Rol,col）.Borders（XlsSt）.LineStyle）
Gl.Weight=1'
Obj.Cells（Rol,Col）.Borders（XlsSt）.Weight
Gl.Weight=Obj.Range（XlsString（Rol,col））.Borders（XlsSt）.Weight
Gl.NoVIsable=False
If（Rol=1）Then'
先计算位置
y0=Obj.Range（XlsString（1,1,Rol-1
升级会员 