VB读取EXCEL数据转化为自定义格式控件.docx
- 文档编号:10827230
- 上传时间:2023-02-23
- 格式:DOCX
- 页数:46
- 大小:25.54KB
VB读取EXCEL数据转化为自定义格式控件.docx
《VB读取EXCEL数据转化为自定义格式控件.docx》由会员分享,可在线阅读,更多相关《VB读取EXCEL数据转化为自定义格式控件.docx(46页珍藏版)》请在冰豆网上搜索。
VB读取EXCEL数据转化为自定义格式控件
'实现读取EXCEL数据转化为格式字符串,并实现格式字符串的分配使用
OptionExplicit
PublicBaseX0AsSingle'起始位置
PublicBaseY0AsSingle
PublicxyScaleAsSingle
PublicB_TiAsSingle'磅值到绨的转化值
PublicChoseColorAsString'选择颜色
'PublicStatViewAsObject
DimMycellAsCells
DimFtAsNewStdFont
DimBCtlAsPictureBox'绑定的显示控件
DimViewableAsBoolean
DimTmpLineAsmyLine
DimTmpDataAsCellData
DimMyImages()AsImage'附加的图片
DimMyImagesSta()AsImage'附加图片的位置信息
DimOldAreaAsString'原始选择区域
DimTxtInputAsTextBox'输入控件
DiminputFgAsBoolean
PrivateTypemyLine'线条结构--26字节
NoVIsableAsBoolean'可显示否
colorAsLong'颜色
StyleAsInteger'线型0~6
WeightAsInteger'线宽
x1AsSingle
y1AsSingle
x2AsSingle
y2AsSingle
EndType
PrivateTypeCellData'单元格的数据=22+lenb(text)
NoVIsableAsBoolean'可见否
colorAsLong'颜色
alignmentAsInteger'对齐方式
WrapTextAsBoolean'自动换行
NfontAsNewStdFont'字体
StyleAsInteger'线型
TextAsString'文本字符号
x1AsSingle'区域
y1AsSingle'左边位置
widthAsSingle
heightAsSingle
MergRangeAsString'包含区域
EndType
PrivateTypeBaseinfo
RolAsInteger'行
colAsInteger'列
widthAsSingle'总宽
heightAsSingle'总高
PaperSizeAsInteger
LeftMargnAsSingle'---页边距-单位cm
TopMargnAsSingle
BottomMargnAsSingle
RightMargnAsSingle
OrientationAsInteger
EndType
PrivateTypeCells'单元集合
BinfAsBaseinfo
Lines()AsmyLine
DataS()AsCellData
EndType
'----------------处理结构的函数
PrivateFunctionGetLineString(LAsmyLine,OptionalSptAsString="")AsString'获取线的
If(Spt="")ThenSpt=Chr(8)
DimtAsString
t=L.color&Spt
t=t&L.NoVIsable&Spt
t=t&L.Style&Spt
t=t&L.Weight&Spt
t=t&L.x1&Spt
t=t&L.x2&Spt
t=t&L.y1&Spt
t=t&L.y2&Spt
GetLineString=t
EndFunction
PrivateFunctionGetStringLine(ByValstrAsString,OptionalSptAsString="")AsmyLine'获取线的
If(Spt="")ThenSpt=Chr(8)
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
EndFunction
PrivateFunctionGetFontString(FtAsStdFont,OptionalSptAsString="")AsString'获取字体的
If(Spt="")ThenSpt=Chr(7)
DimtAsString
t=Ft.Bold&Spt
t=t&Ft.Charset&Spt
t=t&Ft.Italic&Spt
t=t&Ft.Name&Spt
t=t&Ft.Size&Spt
t=t&Ft.Strikethrough&Spt
t=t&Ft.Underline&Spt
t=t&Ft.Weight&Spt
GetFontString=t
EndFunction
PrivateSubGetStringFont(ByValstrAsString,OptionalSptAsString="")'AsStdFont'获取字体的
If(Spt="")ThenSpt=Chr(7)
DimtAsVariant
'DimFtAsNewStdFont
t=Split(str,Spt)
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="")AsString'基础信息的
If(Spt="")ThenSpt=Chr(8)
DimtAsString
t=bf.BottomMargn&Spt
t=t&bf.col&Spt
t=t&bf.height&Spt
t=t&bf.LeftMargn&Spt
t=t&bf.PaperSize&Spt
t=t&bf.RightMargn&Spt
t=t&bf.Rol&Spt
t=t&bf.TopMargn&Spt
t=t&bf.width&Spt
t=t&bf.Orientation&Spt
GetBaseInfoString=t
EndFunction
PrivateFunctionGetStringBaseInfo(ByValstrAsString,OptionalSptAsString="")AsBaseinfo'基础信息的
If(Spt="")ThenSpt=Chr(8)
DimtAsVariant
DimbfAsBaseinfo
t=Split(str,Spt)
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
EndFunction
PrivateFunctionGetDataString(DAsCellData,OptionalSptAsString="")AsString'获取数据的
If(Spt="")ThenSpt=Chr(6)
DimtAsString
t=D.alignment&Spt
t=t&D.color&Spt
t=t&D.height&Spt
t=t&D.MergRange&Spt
t=t&GetFontString(D.Nfont)&Spt
t=t&D.NoVIsable&Spt
t=t&D.Text&Spt
t=t&D.width&Spt
t=t&D.WrapText&Spt
t=t&D.x1&Spt
t=t&D.y1&Spt
t=t&D.Style&Spt
GetDataString=t
EndFunction
PrivateFunctionGetStringData(ByValstrAsString,OptionalSptAsString="")AsCellData'获取字符串对应的数据的
If(Spt="")ThenSpt=Chr(6)
DimtAsVariant
DimDAsCellData
OnErrorResumeNext
t=Split(str,Spt)
If(t(5)=True)Then
D.NoVIsable=t(5)
D.MergRange=t(3)
GetStringData=D
D.MergRange=t(3)
ExitFunction
EndIf
D.alignment=t(0)
D.color=t
(1)
D.height=Val(t
(2))
D.MergRange=t(3)
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.NoVIsable=t(5)
D.Text=t(6)
D.width=t(7)
D.WrapText=t(8)
D.x1=t(9)
D.y1=t(10)
D.Style=t(11)
GetStringData=D
EndFunction
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
t=t&tmp&Chr(3)
tmp=GetDataString(Cs.DataS(0))&Chr(4)'数据信息
lg=Cs.Binf.Rol*Cs.Binf.col
Fori=1Tolg
If(i=30)Then
Debug.PrintCs.DataS(i).MergRange
EndIf
tmp=tmp&GetDataString(Cs.DataS(i))&Chr(4)
Next
t=t&tmp
GetCellString=t
erd:
EndFunction
PrivateFunctionGetStringCell(strAsString)AsCells'返回字符串对应的单元格数据
DimtAsVariant,tmpAsVariant
DimiAsInteger,jAsInteger,RolAsInteger,colAsInteger
DimlgAsLong
DimCsAsCells
OnErrorResumeNext
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("转换失败")
ExitFunction
EndIf
lg=Cs.Binf.Rol*(Cs.Binf.col+1)+(Cs.Binf.Rol+1)*Cs.Binf.col
Fori=0Tolg
Cs.Lines(i)=GetStringLine(tmp(i))
Next
tmp=Split(t
(2),Chr(4))
lg=Rol*col
Fori=0Tolg
If(i=30)Then
Debug.PrintCs.DataS(i).MergRange
EndIf
Cs.DataS(i)=GetStringData(tmp(i))
Next
GetStringCell=Cs
EndFunction
'--------------------
'------------------
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'初始化单元格集合
OnErrorGoToerd
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
EndIf
ExitFunction
erd:
InitCells=False
EndFunction
'-----------------------------------------------------EXCEL处理------------------
'---------------------------------------------------------
'----------------------------------------------------------
PrivateFunctionXlsString(RolAsInteger,colAsInteger,OptionalR2AsInteger=0,OptionalC2AsInteger=0)AsString'--返回指定位置的单元格区域字符串
If(R2=0)Then
XlsString="$"&Chr(col+64)&"$"&Rol
Else
XlsString="$"&Chr(col+64)&"$"&Rol&":
"&"$"&Chr(C2+64)&"$"&R2
EndIf
EndFunction
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)
Else
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))
EndIf
EndFunction
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:
Style_XLSPic=5
EndSelect
EndFunction
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
Case1:
XlsSt=xlEdgeLeft
Case2:
XlsSt=xlEdgeRight
Case3:
XlsSt=xlEdgeTop
EndSelect
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=0
Else
y0=Obj.Range(XlsString(1,1,Rol-1
- 配套讲稿:
如PPT文件的首页显示word图标,表示该PPT已包含配套word讲稿。双击word图标可打开word文档。
- 特殊限制:
部分文档作品中含有的国旗、国徽等图片,仅作为作品整体效果示例展示,禁止商用。设计者仅对作品中独创性部分享有著作权。
- 关 键 词:
- VB 读取 EXCEL 数据 转化 自定义 格式 控件