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
升级会员 