VB读取EXCEL数据转化为自定义格式控件Word文档下载推荐.docx
- 文档编号:6718202
- 上传时间:2023-05-07
- 格式:DOCX
- 页数:46
- 大小:25.54KB
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
- 配套讲稿:
如PPT文件的首页显示word图标,表示该PPT已包含配套word讲稿。双击word图标可打开word文档。
- 特殊限制:
部分文档作品中含有的国旗、国徽等图片,仅作为作品整体效果示例展示,禁止商用。设计者仅对作品中独创性部分享有著作权。
- 关 键 词:
- VB 读取 EXCEL 数据 转化 自定义 格式 控件