この .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