VB读取EXCEL数据转化为自定义格式控件.docx

1、VB读取EXCEL数据转化为自定义格式控件实现读取EXCEL数据转化为格式字符串，并实现格式字符串的分配使用Option ExplicitPublic BaseX0 As Single 起始位置Public BaseY0 As SinglePublic xyScale As SinglePublic B_Ti As Single 磅值到绨的转化值Public ChoseColor As String 选择颜色Public StatView As ObjectDim Mycell As CellsDim Ft As New StdFontDim BCtl As PictureBox 绑定的显示控

2、件Dim Viewable As BooleanDim TmpLine As myLineDim TmpData As CellDataDim MyImages() As Image 附加的图片Dim MyImagesSta() As Image 附加图片的位置信息Dim OldArea As String 原始选择区域Dim TxtInput As TextBox 输入控件Dim inputFg As BooleanPrivate Type myLine 线条结构-26字节 NoVIsable As Boolean 可显示否 color As Long 颜色 Style As Integer

3、 线型06 Weight As Integer 线宽 x1 As Single y1 As Single x2 As Single y2 As SingleEnd TypePrivate Type CellData 单元格的数据22lenb(text) NoVIsable As Boolean 可见否 color As Long 颜色 alignment As Integer 对齐方式 WrapText As Boolean 自动换行 Nfont As New StdFont 字体 Style As Integer 线型 Text As String 文本字符号 x1 As Single 区域

4、 y1 As Single 左边位置 width As Single height As Single MergRange As String 包含区域End TypePrivate Type Baseinfo Rol As Integer 行 col As Integer 列 width As Single 总宽 height As Single 总高 PaperSize As Integer LeftMargn As Single -页边距单位cm TopMargn As Single BottomMargn As Single RightMargn As Single Orientati

5、on As IntegerEnd TypePrivate Type Cells 单元集合 Binf As Baseinfo Lines() As myLine DataS() As CellDataEnd Type处理结构的函数 Private Function GetLineString(L As myLine, Optional Spt As String = ) As String 获取线的 If (Spt = ) Then Spt = Chr(8) Dim t As String t = L.color & Spt t = t & L.NoVIsable & Spt t = t & L

6、.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 End Function Private Function GetStringLine(ByVal str As String, Optional Spt As String = ) As myLine 获取线的 If (Spt = ) Then Spt = Chr(8) Dim L As myLine Dim t As Variant

7、t = Split(str, Spt) L.color = t(0) If UCase(t(1) = TRUE Then L.NoVIsable = True Else L.NoVIsable = False End If 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 End Function Private Function GetFontString(Ft As StdFont, Optional Spt As

8、String = ) As String 获取字体的 If (Spt = ) Then Spt = Chr(7) Dim t As String 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 End Function Pri

9、vate Sub GetStringFont(ByVal str As String, Optional Spt As String = ) As StdFont 获取字体的 If (Spt = ) Then Spt = Chr(7) Dim t As Variant Dim Ft As New StdFont 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)

10、 Ft.Weight = t(7) GetStringFont = Ft End Sub Private Function GetBaseInfoString(bf As Baseinfo, Optional Spt As String = ) As String 基础信息的 If (Spt = ) Then Spt = Chr(8) Dim t As String t = bf.BottomMargn & Spt t = t & bf.col & Spt t = t & bf.height & Spt t = t & bf.LeftMargn & Spt t = t & bf.PaperSi

11、ze & 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 End Function Private Function GetStringBaseInfo(ByVal str As String, Optional Spt As String = ) As Baseinfo 基础信息的 If (Spt = ) Then Spt = Chr(8

12、) Dim t As Variant Dim bf As Baseinfo 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 End Function Private Function GetD

13、ataString(D As CellData, Optional Spt As String = ) As String 获取数据的 If (Spt = ) Then Spt = Chr(6) Dim t As String 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

14、.width & Spt t = t & D.WrapText & Spt t = t & D.x1 & Spt t = t & D.y1 & Spt t = t & D.Style & Spt GetDataString = t End Function Private Function GetStringData(ByVal str As String, Optional Spt As String = ) As CellData 获取字符串对应的数据的 If (Spt = ) Then Spt = Chr(6) Dim t As Variant Dim D As CellData On

15、Error Resume Next t = Split(str, Spt) If (t(5) = True) Then D.NoVIsable = t(5) D.MergRange = t(3) GetStringData = D D.MergRange = t(3) Exit Function End If D.alignment = t(0) D.color = t(1) D.height = Val(t(2) D.MergRange = t(3) Call GetStringFont(t(4) D.Nfont.Bold = Ft.Bold D.Nfont.Charset = Ft.Cha

16、rset 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

17、= D End FunctionPrivate Function GetCellString(Cs As Cells) As String 读取单元格数据字符串 Dim t As String, tmp As String Dim i As Integer, j As Integer Dim lg As Long On Error GoTo erd t = GetBaseInfoString(Cs.Binf) & Chr(3) 基础信息 tmp = GetLineString(Cs.Lines(0) & Chr(4) 线信息 lg = Cs.Binf.Rol * (Cs.Binf.col +

18、1) + (Cs.Binf.Rol + 1) * Cs.Binf.col For i = 1 To lg 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 For i = 1 To lg If (i = 30) Then Debug.Print Cs.DataS(i).MergRange End If tmp = tmp & GetDataStri

19、ng(Cs.DataS(i) & Chr(4) Next t = t & tmp GetCellString = terd:End FunctionPrivate Function GetStringCell(str As String) As Cells 返回字符串对应的单元格数据 Dim t As Variant, tmp As Variant Dim i As Integer, j As Integer, Rol As Integer, col As Integer Dim lg As Long Dim Cs As Cells On Error Resume Next If (str =

20、 ) Then Exit Function 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 (转换失败) Exit Function End If lg = Cs.Binf.Rol * (Cs.Binf.col + 1) +

21、(Cs.Binf.Rol + 1) * Cs.Binf.col For i = 0 To lg Cs.Lines(i) = GetStringLine(tmp(i) Next tmp = Split(t(2), Chr(4) lg = Rol * col For i = 0 To lg If (i = 30) Then Debug.Print Cs.DataS(i).MergRange End If Cs.DataS(i) = GetStringData(tmp(i) Next GetStringCell = CsEnd Function-Private Sub Class_Initializ

22、e() 初始化 BaseX0 = 0 BaseY0 = 0 xyScale = 1 B_Ti = 22 ChoseColor = RGB(32, 32, 32) InitCells Mycell, 1, 1 初始化为1行1列的 Viewable = False inputFg = FalseEnd Sub-Private Function InitCells(ByRef Os As Cells, Rol As Integer, col As Integer) As Boolean 初始化单元格集合 On Error GoTo erd Os.Binf.Rol = Rol Os.Binf.col

23、= col Os.Binf.height = 1 Os.Binf.width = 1 Os.Binf.PaperSize = vbPRPSA4 缺省weiA4纸 ReDim Os.Lines(col * (Rol + 1) + Rol * (col + 1) 每个列加1，每个行加1先横线，再竖线 ReDim Os.DataS(Rol * col) OldArea = 进行初始化需要消除原始选择 InitCells = True If (inputFg) Then TxtInput.Visible = False End If Exit Functionerd: InitCells = Fals

24、eEnd FunctionEXCEL处理-Private Function XlsString(Rol As Integer, col As Integer, Optional R2 As Integer = 0, Optional C2 As Integer = 0) As String 返回指定位置的单元格区域字符串 If (R2 = 0) Then XlsString = $ & Chr(col + 64) & $ & Rol Else XlsString = $ & Chr(col + 64) & $ & Rol & : & $ & Chr(C2 + 64) & $ & R2 End

25、IfEnd FunctionPrivate Function XlsRolCol(RangeS As String) As Variant 返回单元格区域字符串对应的行、列。 Dim tmp As Variant 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) = Xl

26、sRolCol(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) End IfEnd FunctionPrivate Function Style_XLSPic(XlsSty As Long) As Integer Select Case XlsSty Case -4142: Style_XLSPic = 5 Case 1: Style_XLSPi

27、c = 0 Case -4148: Style_XLSPic = 2 Case 5: Style_XLSPic = 4 Case 4: Style_XLSPic = 3 Case -4115: Style_XLSPic = 1 Case Else: Style_XLSPic = 5 End SelectEnd FunctionPrivate Function GetXlsCellLine(Obj As Worksheet, Rol As Integer, col As Integer, sta As Integer) As myLine 获取对应Excel表格的指定行列指定位置的线 sta0底

28、，1L,2-r,3-t Dim XlsSt As String Dim str As String Dim x0 As Single Dim y0 As Single Dim W As Single, H As Single Dim Gl As myLine Select Case sta Case 0: XlsSt = xlEdgeBottom Case 1: XlsSt = xlEdgeLeft Case 2: XlsSt = xlEdgeRight Case 3: XlsSt = xlEdgeTop End Select x0 = 0 y0 = 0 W = Obj.Cells(Rol,

29、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