0

この .Net クラスで documentFormat.OpenXML を使用して、既存の Excel ワークシートの Excel セルを読み書きします。WriteCell メソッドを使用する場合、オプションの背景色属性を渡すことができます。背景色がない場合、WriteCell メソッドに背景が提供されます。WriteCell が呼び出されたセルに既存の背景色がある場合は、その既存の色を保持する必要があります。つまり、Excel を介して元の Excel ファイルで A1 の背景色が青に設定されている場合、背景色属性を渡さずに WriteCell が呼び出されたときに背景の青を保持する必要がありますか? ただし、このクラスでは、新しい背景色を渡さずに WriteCell が呼び出されると、Excel で設定されたすべての既存の塗りつぶしが黒に変わります。

    Imports DocumentFormat.OpenXml
    Imports DocumentFormat.OpenXml.Spreadsheet
    Imports DocumentFormat.OpenXml.Packaging

    Imports System.IO

    Public Class ExcelByOpenXML

        Dim sDocName As String
        Dim sDocNameTemp As String
        Dim sSheetName As String
        Dim sDocNameToReopen As String = "" 
        Dim oDocument As SpreadsheetDocument
        Dim oDocumentOrg As SpreadsheetDocument
        Dim oSheet As Sheet
        Dim oWorkbookPart As WorkbookPart
        Dim oWorksheetPart As WorksheetPart
        Dim oStylesheet As Stylesheet
        Dim iLastCreatedFont As Integer
        Dim sLastCreatedFont As String
        Dim iLastCreatedFill As Integer
        Dim sLastCreatedFill As String
        Dim iLastCreatedStyle As Integer
        Dim sLastCreatedStyle As String

        Public Function OpenDoc(ByVal Doc As String) As Boolean
            Try
                sDocName = Doc
                sDocNameTemp = Path.GetTempPath + Doc.Substring(Doc.LastIndexOf("\") + 1)
                FileCopy(IIf(sDocNameToReopen.Length > 0, sDocNameToReopen, sDocName), sDocNameTemp)
                oDocumentOrg = SpreadsheetDocument.Open(sDocName, True)
                oDocument = SpreadsheetDocument.Open(sDocNameTemp, True)
                Return True
            Catch
                Return False
            End Try

        End Function

        Public Function opensheet(ByVal Sheet As String) As Boolean
            Dim oSheets As Sheets
            Dim oTmpSheet As Sheet

            Try
                sSheetName = Sheet
                oWorkbookPart = oDocument.WorkbookPart
                oSheets = oWorkbookPart.Workbook.Sheets

                For Each oTmpSheet In oSheets
                    If oTmpSheet.Name = Sheet Then
                        oSheet = oTmpSheet
                        Exit For
                    End If
                Next

                If IsNothing(oSheet) Then
                    Return False
                End If

                oWorksheetPart = CType(oWorkbookPart.GetPartById(oSheet.Id), WorksheetPart)
                oStylesheet = oWorkbookPart.WorkbookStylesPart.Stylesheet
                iLastCreatedFont = 0
                sLastCreatedFont = ""
                iLastCreatedFill = 0
                sLastCreatedFill = ""
                iLastCreatedStyle = 0
                sLastCreatedStyle = ""
                Return True

            Catch ex As Exception
                Return False
            End Try
        End Function


        Public Function SaveDocAs(ByVal Name As String, ByVal Path As String) As Boolean

            If IsNothing(oDocument) Then
                Return False
            End If
            oDocument.Close()
            oDocumentOrg.Close()
            FileCopy(sDocNameTemp, Path + Name)
            sDocNameToReopen = ""
            Return True
        End Function

        Public Function SaveDoc() As Boolean

            If IsNothing(oDocument) Then
                Return False
            End If
            oDocument.Close()
            oDocumentOrg.Close()
            FileCopy(sDocNameTemp, sDocName)
            Return True
        End Function

        Public Function WriteCell(ByVal Col As String, ByVal Row As Integer, ByVal Val As String, Optional ByVal halign As Integer = 1, Optional ByVal Valign As Integer = 0, Optional ByVal fnt As String = "Calibri", Optional ByVal fntSize As Integer = 10, Optional ByVal foreColor As String = "00000000", Optional ByVal backColor As String = "", Optional ByVal isFormula As Boolean = False) As Boolean
            If IsNothing(oDocument) Then
                Return False
            End If

            Dim oCell As Cell
            Dim myCellFormat As CellFormat
            Dim myCellFormat1 As CellFormat
            Dim ct1 As ColorType

            Try
                oCell = CreateSpreadsheetCell(Col, Row)
                Dim cellStyleIndex As Integer           
                Dim sReturnString1(5) As String
                If IsNothing(oCell.StyleIndex) Then
                    cellStyleIndex = 0
                Else
                    cellStyleIndex = oCell.StyleIndex.Value
                End If
                myCellFormat1 = oWorkbookPart.WorkbookStylesPart.Stylesheet.CellFormats.ChildElements(cellStyleIndex)
                Dim myFill1 As Fill = oWorkbookPart.WorkbookStylesPart.Stylesheet.Fills.ChildElements(myCellFormat1.FillId.Value)
                Dim myPatternFill1 As PatternFill = myFill1.PatternFill
                ct1 = myPatternFill1.BackgroundColor

                'This section is new, still does not work.
                If Not IsNothing(ct1.Indexed) Then
                    myCellFormat = New CellFormat()
                    myCellFormat.FillId = CreateFill(System.Drawing.ColorTranslator.FromOle(ct1.Indexed.Value).ToString())               
                End If

                If isFormula Then
                    If Not IsNothing(oCell.CellFormula) Then
                        oCell.CellFormula.Text = Val
                    Else
                        Dim oCellFormula As CellFormula = New CellFormula(Val)
                        oCell.Append(oCellFormula)
                    End If
                Else
                    Dim myCellValue As CellValue
                    oCell.DataType = CellValues.String
                    If Not IsNothing(oCell.CellValue) Then
                        myCellValue = oCell.CellValue
                    Else
                        myCellValue = New CellValue()
                        oCell.Append(myCellValue)
                    End If
                    myCellValue.Text = Val
                End If

                Dim bcolor As String = ""
                Dim fontname As String = ""
                Dim fontsize As Integer = 0
                Dim sTest3() As String
                sTest3 = ReadCell(Col, Row)
                If (sTest3(1).Length > 0) Then fontname = sTest3(1).ToString()
                If (sTest3(2).Length > 0) Then fontsize = Convert.ToInt32(sTest3(2))
                If (sTest3(4).Length > 0) Then bcolor = sTest3(4).ToString()

                Dim chk_flag As Integer = 0

                If sLastCreatedStyle <> fnt + ";;" + fntSize.ToString() + ";;" + foreColor + ";;" + backColor Then
                    myCellFormat = New CellFormat()
                    myCellFormat.FormatId = Convert.ToUInt32(0)

                    If (backColor.Length > 0) Then
                        myCellFormat.FillId = CreateFill(backColor)
                    ElseIf (bcolor.Length > 0) Then
                        myCellFormat.FillId = CreateFill(bcolor)
                    Else
                        myCellFormat.FillId = CreateFill(System.Drawing.ColorTranslator.FromOle(ct1.Indexed.Value).ToString())
                        chk_flag = 1
                    End If
                    myCellFormat.BorderId = Convert.ToUInt32(0)

                    If (fnt <> "Calibri") Then
                        fnt = fnt.ToString()
                    ElseIf (fontname.Length > 0) Then
                        fnt = fontname.ToString()
                    End If

                    If (fntSize <> 10) Then
                        fntSize = fntSize
                    ElseIf (fontsize > 0) Then
                        fntSize = fontsize
                    End If

                    myCellFormat.FontId = CreateFont(fnt, fntSize, foreColor)
                    myCellFormat.NumberFormatId = Convert.ToUInt32(0)

                    Dim value As New Alignment
                    value.Horizontal = halign     'HorizontalAlignmentValues.Left=1
                    myCellFormat.Alignment = value
                    value.Vertical = Valign       'VerticalAlignmentValues.top=0
                    myCellFormat.Alignment = value

                    myCellFormat.ApplyFill = True
                    myCellFormat.ApplyFont = True
                    oStylesheet.CellFormats.Append(myCellFormat)
                    iLastCreatedStyle = oStylesheet.CellFormats.Count.Value
                    oStylesheet.CellFormats.Count.Value += 1

                    sLastCreatedStyle = fnt + ";;" + fntSize.ToString() + ";;" + foreColor + ";;" + backColor

                End If

                If (chk_flag = 0) Then oCell.StyleIndex = Convert.ToUInt32(iLastCreatedStyle)

                Return True
            Catch
                Return False
            End Try
        End Function

        Public Function ReadCell(ByVal Col As String, ByVal Row As Integer) As String()

            Dim oCell As Cell
            Dim sReturnString(6) As String

            If IsNothing(oDocument) Then
                'return empty - the file is not open
                Return sReturnString
            End If

            Try
                oCell = CreateSpreadsheetCell(Col, Row)
                sReturnString(0) = ReadCellValue(oCell)
                Dim iCellStyleIndex As Integer

                If IsNothing(oCell.StyleIndex) Then
                    iCellStyleIndex = 0
                Else
                    iCellStyleIndex = oCell.StyleIndex.Value
                End If

                Dim oCellFormat As CellFormat = oWorkbookPart.WorkbookStylesPart.Stylesheet.CellFormats.ChildElements(iCellStyleIndex)

                Dim iFontId As Integer
                If IsNothing(oCellFormat.FontId) Then
                    iFontId = 0
                Else
                    iFontId = oCellFormat.FontId.Value
                End If

                Dim myFont As Font = oWorkbookPart.WorkbookStylesPart.Stylesheet.Fonts.ChildElements(iFontId)
                sReturnString(1) = myFont.FontName.Val
                sReturnString(2) = myFont.FontSize.Val
                Try
                    sReturnString(3) = myFont.Color.Rgb.ToString()
                Catch
                    sReturnString(3) = ""
                End Try

                'read fore and back color
                Dim myFill As Fill = oWorkbookPart.WorkbookStylesPart.Stylesheet.Fills.ChildElements(oCellFormat.FillId.Value)
                Dim myPatternFill As PatternFill = myFill.PatternFill

                If Not IsNothing(myPatternFill.ForegroundColor) Then sReturnString(4) = PrintColorType(myPatternFill.ForegroundColor)
                'If Not IsNothing(myPatternFill.BackgroundColor) Then sReturnString(6) = PrintColorType(myPatternFill.BackgroundColor)

                'cell is a formula or not
                If Not IsNothing(oCell.CellFormula) Then
                    sReturnString(5) = "True"
                Else
                    sReturnString(5) = "False"
                End If

                Return sReturnString
            Catch
                Return sReturnString
            End Try

        End Function

        Public Function SimpleReadCell(ByVal Col As String, ByVal Row As Integer) As String

            Dim oCell As Cell

            Dim addressName As String = Col + Row.ToString
            Dim sValue As String = ""

            If IsNothing(oDocument) Then
                Return ""
            End If

            Try
                oCell = CreateSpreadsheetCell(Col, Row)
                sValue = ReadCellValue(oCell)

                Return sValue
            Catch
                Return ""
            End Try

        End Function

        Public Function CloseDoc() As Boolean

            Try
                'clear variables
                ClearVariables()
                Return True
            Catch
                Return False
            End Try

        End Function

        Public Function RowHeight(ByVal iRow As Integer, ByVal iHeight As Integer) As Boolean

            Dim myRow As Row
            Dim myRowCopy As Row = Nothing
            Dim isChanged As Boolean = False

            Try
                If IsNothing(oDocument) Then Return False

                Dim rows As IEnumerable(Of Row) = oWorksheetPart.Worksheet.Descendants(Of Row)().Where(Function(r) r.RowIndex.Value = iRow.ToString())
                If (rows.Count = 0) Then
                    myRow = InsertRow(iRow)
                Else
                    myRow = rows.First
                End If
                myRow.Height = iHeight
                myRow.CustomHeight = True

                Return True
            Catch
                Return False
            End Try
        End Function

        Public Function ColumnWidth(ByVal Col As String, ByVal Width As Integer) As Boolean

            Dim myColsObj As Columns
            Dim myColumn As Column
            Dim iCol As Integer

            If IsNothing(oDocument) Then Return False

            Try
                iCol = TranslateColumnNameToIndex(Col)
                Dim myCols As IEnumerable(Of Column) = oWorksheetPart.Worksheet.Descendants(Of Column)()

                If myCols.Count = 0 Then
                    myColsObj = New Columns
                    Dim myCol As Column = New Column

                    myCol.Min = Convert.ToUInt32(1)
                    myCol.Max = Convert.ToUInt32(25)
                    myCol.CustomWidth = False
                    myCol.Width = 15

                    myColsObj.Append(myCol)

                    Dim mySheetData As SheetData = oWorksheetPart.Worksheet.GetFirstChild(Of SheetData)()
                    oWorksheetPart.Worksheet.InsertBefore(myColsObj, mySheetData)
                Else
                    myColsObj = oWorksheetPart.Worksheet.GetFirstChild(Of Columns)()
                End If

                For Each myColumn In oWorksheetPart.Worksheet.Descendants(Of Column)()
                    If (myColumn.Min.Value = iCol And myColumn.Max.Value = iCol) Then
                        myColumn.Width = Width
                        myColumn.CustomWidth = True
                        Exit For
                    ElseIf (myColumn.Min.Value <= iCol And myColumn.Max.Value >= iCol) Then
                        If myColumn.Min.Value = iCol Then
                            Dim cNewColumn As Column
                            cNewColumn = myColumn.Clone
                            cNewColumn.Min.Value = cNewColumn.Min.Value + 1
                            oWorksheetPart.Worksheet.AppendChild(cNewColumn)
                            myColumn.Width = Width
                            myColumn.CustomWidth = True
                            myColumn.Max.Value = iCol
                        End If
                        If myColumn.Max.Value = iCol Then
                            Dim cNewColumn As Column
                            cNewColumn = myColumn.Clone
                            cNewColumn.Max.Value = cNewColumn.Max.Value - 1
                            oWorksheetPart.Worksheet.AppendChild(cNewColumn)
                            myColumn.Width = Width
                            myColumn.CustomWidth = True
                            myColumn.Min.Value = iCol
                        End If
                        If myColumn.Min.Value < iCol And myColumn.Max.Value > iCol Then
                            Dim cNewColumn1 As Column
                            cNewColumn1 = myColumn.Clone
                            cNewColumn1.Max.Value = iCol - 1
                            myColsObj.InsertBefore(cNewColumn1, myColumn)
                            Dim cNewColumn2 As Column
                            cNewColumn2 = myColumn.Clone
                            cNewColumn2.Min.Value = iCol + 1
                            myColsObj.InsertAfter(cNewColumn2, myColumn)
                            myColumn.Width = Width
                            myColumn.CustomWidth = True
                            myColumn.Min.Value = iCol
                            myColumn.Max.Value = iCol
                        End If
                        Exit For
                    End If
                Next
                Return True
            Catch
                Return False
            End Try

        End Function


    #Region "Private methods"

        Private Sub ClearVariables()
            oSheet = Nothing
            oWorkbookPart = Nothing
            oWorksheetPart = Nothing
            oStylesheet = Nothing
            If Not IsNothing(oDocument) Then
                oDocument.Dispose()
                oDocument = Nothing
            End If

            If Not IsNothing(oDocumentOrg) Then
                oDocumentOrg.Dispose()
                oDocumentOrg = Nothing
            End If
            Try
                If Not IsNothing(sDocNameTemp) Then
                    File.Delete(sDocNameTemp)
                End If
            Catch
            End Try
        End Sub

        'convert a column name to index - sometimes is required
        Private Function TranslateColumnNameToIndex(ByVal name As String) As Integer

            Dim iPosition As Integer = 0
            Dim chars() As Char
            chars = name.ToUpperInvariant().ToCharArray().Reverse().ToArray()
            Dim index As Integer
            Dim c As Integer

            For index = 0 To chars.Length - 1
                c = Asc(chars(index)) - 64
                iPosition += IIf(index = 0, c, (c * System.Math.Pow(26, index)))
            Next

            Return iPosition

        End Function

        Private Function CreateSpreadsheetCell(ByVal sCol As String, ByVal iRow As Integer) As Cell
            Dim cellReference As String = (sCol + iRow.ToString())
            Dim rows As IEnumerable(Of Row) = oWorksheetPart.Worksheet.Descendants(Of Row)().Where(Function(r) r.RowIndex.Value = iRow.ToString())
            Dim row As Row
            If (rows.Count = 0) Then
                row = InsertRow(iRow)
                Dim cell As Cell = New Cell()
                cell.CellReference = New StringValue(cellReference)
                row.Append(cell)
                Return cell
            Else
                row = rows.First
            End If

            If (row.Elements(Of Cell).Where(Function(c) c.CellReference.Value = cellReference).Count() > 0) Then
                Return row.Elements(Of Cell).Where(Function(c) c.CellReference.Value = cellReference).First()
            Else
                Dim refCell As Cell = Nothing
                For Each cell As Cell In row.Elements(Of Cell)()
                    If (String.Compare(cell.CellReference.Value, cellReference, True) > 0) Then
                        refCell = cell
                        Exit For
                    End If
                Next

                Dim newCell As Cell = New Cell
                newCell.CellReference = cellReference
                row.InsertBefore(newCell, refCell)
                Return newCell

            End If

        End Function

        'function return the color RGB from colortype object
        Private Function PrintColorType(ByVal ct As ColorType) As String

            Try
                If Not IsNothing(ct.Auto) Then Return ("System auto color")

                If Not IsNothing(ct.Rgb) Then Return ct.Rgb.Value.ToString()
                If Not IsNothing(ct.Theme) Then Return ct.Theme.Value.ToString()
                If Not IsNothing(ct.Tint) Then Return ct.Tint.Value.ToString()

                If Not IsNothing(ct.Indexed) Then
                    Dim a As Spreadsheet.RgbColor = oWorkbookPart.WorkbookStylesPart.Stylesheet.Colors.IndexedColors.ChildElements(ct.Indexed.Value)
                    Return a.Rgb.ToString()
                End If

            Catch

            End Try

            Return ""

        End Function

        Private Function ReadCellValue(ByVal oCell As Cell) As String

            Dim sValue As String = ""

            If oCell IsNot Nothing Then
                sValue = oCell.InnerText
                If oCell.DataType IsNot Nothing Then
                    Select Case oCell.DataType.Value
                        Case CellValues.SharedString
                            ' For shared strings, look up the value in the shared 
                            ' strings table.
                            Dim stringTable = oWorkbookPart.GetPartsOfType(Of SharedStringTablePart).FirstOrDefault()
                            ' If the shared string table is missing, something is wrong.
                            ' Return the index that you found in the cell.
                            ' Otherwise, look up the correct text in the table.
                            If stringTable IsNot Nothing Then
                                sValue = stringTable.SharedStringTable.ElementAt(Integer.Parse(sValue)).InnerText
                            End If
                        Case CellValues.Boolean
                            Select Case sValue
                                Case "0"
                                    sValue = "FALSE"
                                Case Else
                                    sValue = "TRUE"
                            End Select
                    End Select
                End If
                If Not IsNothing(oCell.CellFormula) Then
                    'sValue = oCell.CellFormula.Text
                    sValue = oCell.CellValue.Text
                End If

            End If
            Return sValue

        End Function

        Private Function CreateFont(ByVal sFontName As String, ByVal iFontSize As Integer, ByVal sForeColor As String) As UInt32Value

            If sFontName + ";;" + iFontSize.ToString() + ";;" + sForeColor <> sLastCreatedFont Then
                Dim myFont As Font = New Font()
                'set font size
                Dim myFontSize As FontSize = New FontSize()
                myFontSize.Val = iFontSize
                myFont.Append(myFontSize)
                Dim myColor As Spreadsheet.Color = New Spreadsheet.Color
                myColor.Rgb = sForeColor
                myFont.Append(myColor)
                Dim myFontName As FontName = New FontName()
                myFontName.Val = sFontName
                myFont.Append(myFontName)
                oStylesheet.Fonts.Append(myFont)
                iLastCreatedFont = oStylesheet.Fonts.Count.Value
                oStylesheet.Fonts.Count.Value += 1
                sLastCreatedFont = sFontName + ";;" + iFontSize.ToString() + ";;" + sForeColor
            End If

            Return iLastCreatedFont

        End Function

        Private Function CreateFill(ByVal fillColor As String) As UInt32Value

            If sLastCreatedFill <> fillColor Then

                Dim myFill As Fill = New Fill()
                Dim myPatterFill As PatternFill = New PatternFill()
                Dim myFore As ForegroundColor = New ForegroundColor()
                myFore.Rgb = fillColor
                myPatterFill.Append(myFore)

                'back color
                'Dim myBack As BackgroundColor = New BackgroundColor()
                'myBack.Rgb = fillColor
                'myBack.Indexed = New UInt32Value(Convert.ToUInt32(64))
                'myPatterFill.Append(myBack)

                myPatterFill.PatternType = PatternValues.Solid
                myFill.Append(myPatterFill)
                oStylesheet.Fills.Append(myFill)
                iLastCreatedFill = oStylesheet.Fills.Count.Value
                oStylesheet.Fills.Count.Value += 1
                sLastCreatedFill = fillColor

            End If

            Return iLastCreatedFill

        End Function

        Private Function InsertSharedStringItem(ByVal text As String) As Integer
            If (oWorkbookPart.SharedStringTablePart.SharedStringTable Is Nothing) Then
                oWorkbookPart.SharedStringTablePart.SharedStringTable = New SharedStringTable
            End If

            Dim i As Integer = 0

            For Each item As SharedStringItem In oWorkbookPart.SharedStringTablePart.SharedStringTable.Elements(Of SharedStringItem)()
                If (item.InnerText = text) Then
                    Return i
                End If
                i = (i + 1)
            Next
            oWorkbookPart.SharedStringTablePart.SharedStringTable.AppendChild(New SharedStringItem(New DocumentFormat.OpenXml.Spreadsheet.Text(text)))
            oWorkbookPart.SharedStringTablePart.SharedStringTable.Save()

            Return i
        End Function

        Private Function InsertRow(ByVal iRowIndex As Integer) As Row
            Dim myRow = New Row()
            myRow.RowIndex = New UInt32Value(Convert.ToUInt32(iRowIndex))
            Dim mySheetData As SheetData
            mySheetData = oWorksheetPart.Worksheet.GetFirstChild(Of SheetData)()
            Dim tmpRows As IEnumerable(Of Row) = oWorksheetPart.Worksheet.Descendants(Of Row)()
            If tmpRows.Count = 0 Then
                mySheetData.Append(myRow)
                Return myRow
            End If
            Dim tRow As Row = Nothing
            For Each tRow In tmpRows
                If tRow.RowIndex.Value > iRowIndex Then
                    mySheetData.InsertBefore(myRow, tRow)
                    Return myRow
                End If
            Next
            mySheetData.InsertAfter(myRow, tRow)
            Return myRow
        End Function

    #End Region

    End Class
4

0 に答える 0