I'm getting an error everytime I try to upload a XML file to an specific server.
It returns "Invalid character in a Base-64 string". Here the code I'm using to sign:
Public Sub Assinar03(ByVal strArqXMLAssinar As String, ByVal strUri As String, ByVal x509Certificado As X509Certificate2, ByVal strArqXMLAssinado As String)
Dim SR As StreamReader = Nothing
SR = File.OpenText(strArqXMLAssinar)
Dim vXMLString As String = SR.ReadToEnd()
SR.Close()
Dim _xnome As String = String.Empty
Dim _serial As String = String.Empty
If x509Certificado IsNot Nothing Then
_xnome = x509Certificado.Subject.ToString()
_serial = x509Certificado.SerialNumber
End If
Dim _X509Cert As New X509Certificate2()
Dim store As New X509Store("MY", StoreLocation.CurrentUser)
store.Open(OpenFlags.[ReadOnly] Or OpenFlags.OpenExistingOnly)
Dim collection As X509Certificate2Collection = DirectCast(store.Certificates, X509Certificate2Collection)
Dim collection1 As X509Certificate2Collection = DirectCast(collection.Find(X509FindType.FindBySerialNumber, _serial, False), X509Certificate2Collection)
If collection1.Count > 0 Then
_X509Cert = Nothing
For i As Integer = 0 To collection1.Count - 1
If DateTime.Now < collection1(i).NotAfter OrElse Not _X509Cert Is Nothing AndAlso _X509Cert.NotAfter < collection1(i).NotAfter Then
_X509Cert = collection1(i)
End If
Next
If _X509Cert Is Nothing Then _X509Cert = collection1(0)
Dim doc As New XmlDocument()
doc.PreserveWhitespace = False
doc.LoadXml(vXMLString)
Dim qtdeRefUri As Integer = doc.GetElementsByTagName(strUri).Count
Dim reference As New Reference()
Dim keyInfo As New KeyInfo()
Dim signedXml As New SignedXml(doc)
signedXml.SigningKey = _X509Cert.PrivateKey
Dim _Uri As XmlAttributeCollection = doc.GetElementsByTagName(strUri).Item(0).Attributes
For Each _atributo As XmlAttribute In _Uri
If _atributo.Name.ToLower.Trim = "Id".ToLower.Trim Then
reference.Uri = "#" + _atributo.InnerText
End If
Next
If reference.Uri Is Nothing Then reference.Uri = ""
reference.DigestMethod = SignedXml.XmlDsigSHA1Url
'--------------------------------------------------
Dim env As New XmlDsigEnvelopedSignatureTransform()
env.Algorithm = "http://www.w3.org/2000/09/xmldsig#enveloped-signature"
reference.AddTransform(env)
'--------------------------
Dim c14 As New XmlDsigC14NTransform(False)
c14.Algorithm = "http://www.w3.org/TR/2001/REC-xml-c14n-20010315"
reference.AddTransform(c14)
'--------------------------
signedXml.AddReference(reference)
keyInfo.AddClause(New KeyInfoX509Data(_X509Cert))
'--------------------------
signedXml.KeyInfo = keyInfo
signedXml.ComputeSignature()
'--
Dim xmlDigitalSignature As XmlElement = signedXml.GetXml()
doc.DocumentElement.AppendChild(doc.ImportNode(xmlDigitalSignature, True))
XMLDoc = New XmlDocument()
XMLDoc.PreserveWhitespace = False
XMLDoc = doc
Me.vXMLStringAssinado = XMLDoc.OuterXml
'-----------
Dim SW_2 As StreamWriter = File.CreateText(strArqXMLAssinado)
SW_2.Write(Me.vXMLStringAssinado)
SW_2.Close()
'-----------
End If
SR.Close()
End Sub
Is there something else I should add to the code?
The manual tells me to follow the instructions from https://www.w3.org/TR/xmldsig-core/
Turns out it was a line break when saving the document. I set the .PreserveWhitespace property to true before saving the .xml file and not it seems to be working.
Related
I'm posting this to help others that may be going through the struggle I went through when trying to add simple notes or threaded comments to an excel spreadsheet using the DocumentFormat.OpenXML library using VB.Net.
I've added my own answer.
Imports System.Text
Imports DocumentFormat.OpenXml
Imports DocumentFormat.OpenXml.Packaging
Imports DocumentFormat.OpenXml.Spreadsheet
Imports System.Runtime.CompilerServices
Imports System.Xml
Imports System.IO
Imports System.Text.RegularExpressions
Imports DocumentFormat.OpenXml.Office2019.Excel.ThreadedComments
Public Class ExcelDocInfo
Public Property WBPart As WorkbookPart = Nothing
Public Property WSPart As WorksheetPart = Nothing
Public Property SData As SheetData = Nothing
End Class
Public Class CellReferenceIndexes
Public ColumnIndex As Integer? = Nothing
Public RowIndex As Integer? = Nothing
Public Sub New()
End Sub
End Class
Public Class OpenXML
Public Shared Function GetThreadedCommentVMLShapeXML(CellReference As String, CommentCount As Integer)
Dim commentVmlXml As String = String.Empty
commentVmlXml = <![CDATA[
<v:shape id="[ShapeID]" type="#_x0000_t202" style='position:absolute; margin-left:59.25pt;margin-top:1.5pt;width:108pt;height:59.25pt;z-index:1; visibility:hidden' fillcolor="infoBackground [80]" strokecolor="none [81]" o:insetmode="auto">
<v:fill color2="infoBackground [80]"/>
<v:shadow color="none [81]" obscured="t"/>
<v:path o:connecttype="none"/>
<v:textbox style='mso-direction-alt:auto'>
<div style='text-align:left'></div>
</v:textbox>
<x:ClientData ObjectType="Note">
<x:MoveWithCells/>
<x:SizeWithCells/>
<x:Anchor>[CoordinatesForVMLCommentShape]</x:Anchor>
<x:AutoFill>False</x:AutoFill>
<x:Row>[RowIndex]</x:Row>
<x:Column>[ColumnIndex]</x:Column>
</x:ClientData>
</v:shape>
]]>.Value.Trim()
Dim ShapeId As String = "_x0000_s" & (1109 + CommentCount + 1).ToString()
commentVmlXml = commentVmlXml.Replace("[ShapeID]", ShapeId)
commentVmlXml = commentVmlXml.Replace("[CoordinatesForVMLCommentShape]", GetAnchorCoordinatesForVMLCommentShape(CellReference))
commentVmlXml = commentVmlXml.Replace("[RowIndex]", (GetIndexesFromCellReference(CellReference).RowIndex - 1).ToString())
commentVmlXml = commentVmlXml.Replace("[ColumnIndex]", (GetIndexesFromCellReference(CellReference).ColumnIndex - 1).ToString())
Return commentVmlXml
End Function
Public Shared Function GetNoteVMLShapeXML(CellReference As String, CommentCount As Integer)
Dim commentVmlXml As String = String.Empty
commentVmlXml = <![CDATA[
<v:shape id="[ShapeID]" type="#_x0000_t202" style='position:absolute; margin-left:59.25pt; margin-top:1.5pt; width:108pt; height:59.25pt; z-index:1; visibility:hidden' fillcolor="#ffffe1" o:insetmode="auto">
<v:fill color2="#ffffe1" />
<v:shadow on="t" color="black" obscured="t" />
<v:path o:connecttype="none" />
<v:textbox style='mso-fit-shape-to-text:true'>
<div style='text-align:left'></div>
</v:textbox>
<x:ClientData ObjectType="Note">
<x:MoveWithCells />
<x:SizeWithCells />
<x:Anchor>[CoordinatesForVMLCommentShape]</x:Anchor>
<x:AutoFill>False</x:AutoFill>
<x:Row>[RowIndex]</x:Row>
<x:Column>[ColumnIndex]</x:Column>
</x:ClientData>
</v:shape>
]]>.Value.Trim()
Dim ShapeId As String = "_x0000_s" & (1109 + CommentCount + 1).ToString()
commentVmlXml = commentVmlXml.Replace("[ShapeID]", ShapeId)
commentVmlXml = commentVmlXml.Replace("[CoordinatesForVMLCommentShape]", GetAnchorCoordinatesForVMLCommentShape(CellReference))
commentVmlXml = commentVmlXml.Replace("[RowIndex]", (GetIndexesFromCellReference(CellReference).RowIndex - 1).ToString())
commentVmlXml = commentVmlXml.Replace("[ColumnIndex]", (GetIndexesFromCellReference(CellReference).ColumnIndex - 1).ToString())
Return commentVmlXml
End Function
Public Shared Function GetAnchorCoordinatesForVMLCommentShape(CellReference As String) As String
Dim coordinates As String = String.Empty
Dim startingRow As Integer = 0
Dim startingColumn As Integer = GetIndexesFromCellReference(CellReference).ColumnIndex - 1
'From upper right coordinate of a rectangle
'[0] Left column
'[1] Left column offset
'[2] Left row
'[3] Left row offset
'To bottom right coordinate of a rectangle
'[4] Right column
'[5] Right column offset
'[6] Right row
'[7] Right row offset
Dim coordList As List(Of Integer) = {0, 0, 0, 0, 0, 0, 0, 0}.ToList()
If Integer.TryParse(GetIndexesFromCellReference(CellReference).RowIndex, startingRow) Then
startingRow -= 1
coordList(0) = startingColumn + 1
coordList(1) = 15
coordList(2) = startingRow
coordList(4) = startingColumn + 3
coordList(5) = 15
coordList(6) = startingRow + 3
If startingRow = 0 Then
coordList(3) = 2
coordList(7) = 16
Else
coordList(3) = 10
coordList(7) = 4
End If
coordinates = String.Join(",", coordList.ConvertAll(Of String)(Function(X) X.ToString()).ToArray())
End If
Return coordinates
End Function
Public Shared Function GetIndexesFromCellReference(CellReference As String) As CellReferenceIndexes
Dim CellReferenceInfo As New CellReferenceIndexes
Dim ColRef As String = ""
For Each C As Char In CellReference
If Not IsNumeric(C) Then
ColRef &= C
Else
Exit For
End If
Next
ColRef = ColRef.ToUpper()
CellReferenceInfo.RowIndex = Strings.Right(CellReference, CellReference.Length - ColRef.Length)
Dim ColIndex As Integer = 0
For Idx As Integer = 0 To ColRef.Length - 1
ColIndex *= 26
Dim charA As Integer = Asc("A")
Dim charColLetter As Integer = Asc(ColRef(Idx))
ColIndex += (charColLetter - charA) + 1
Next
CellReferenceInfo.ColumnIndex = ColIndex
Return CellReferenceInfo
End Function
Public Shared Sub AddNote(DocInfo As ExcelDocInfo, XCell As Cell, XAuthor As String, Comment As String, Optional XFontName As String = "Tahoma", Optional FontSize As Double = 11, Optional FontBold As Boolean = False, Optional FontItalic As Boolean = False, Optional TextColor As System.Drawing.Color = Nothing, Optional HighlightColor As System.Drawing.Color = Nothing)
If DocInfo Is Nothing Then
Exit Sub
End If
If XCell Is Nothing Then
Exit Sub
End If
If String.IsNullOrEmpty(XAuthor) Then
Exit Sub
End If
If String.IsNullOrEmpty(Comment) Then
Exit Sub
End If
If TextColor = Nothing Then TextColor = System.Drawing.Color.Black
Dim CommentsPart As WorksheetCommentsPart = Nothing
If DocInfo.WSPart.WorksheetCommentsPart Is Nothing Then
CommentsPart = DocInfo.WSPart.AddNewPart(Of WorksheetCommentsPart)
Else
CommentsPart = DocInfo.WSPart.WorksheetCommentsPart()
End If
Dim XComments As Comments = CommentsPart.Comments
If XComments Is Nothing Then
XComments = New Comments() With {.MCAttributes = New MarkupCompatibilityAttributes() With {.Ignorable = "xr"}}
XComments.AddNamespaceDeclaration("mc", "http://schemas.openxmlformats.org/markup-compatibility/2006")
XComments.AddNamespaceDeclaration("xr", "http://schemas.microsoft.com/office/spreadsheetml/2014/revision")
CommentsPart.Comments = XComments
End If
Dim XAuthors As Authors = XComments.GetFirstChild(Of Authors)
If XAuthors Is Nothing Then
XAuthors = New Authors()
XComments.Append(XAuthors)
End If
Dim XLAuthor As Author = (From A As Author In XAuthors.ToList() Where A.Text = XAuthor).FirstOrDefault()
If XLAuthor Is Nothing Then
XLAuthor = New Author() With {.Text = XAuthor}
XAuthors.Append(XLAuthor)
End If
Dim AuthorID As UInt32 = Convert.ToUInt32(XAuthors.AsEnumerable.ToList().IndexOf(XLAuthor))
Dim CommList As CommentList = XComments.GetFirstChild(Of CommentList)
If CommList Is Nothing Then
CommList = New CommentList()
XComments.Append(CommList)
End If
Dim XComment As Comment = XComments.CommentList.AppendChild(Of Comment)(New Spreadsheet.Comment() With {
.AuthorID = New UInt32Value(AuthorID),
.Reference = XCell.CellReference,
.ShapeId = New UInt32Value(Convert.ToUInt32(0))
})
Dim XCommentText As New CommentText()
Dim XRun As New Run()
Dim XRunProperties As New RunProperties()
Dim XFontSize As New FontSize() With {.Val = New DoubleValue(Convert.ToDouble(FontSize))}
Dim XColor As New Color() With {.Rgb = New HexBinaryValue With {.Value = System.Drawing.ColorTranslator.ToHtml(System.Drawing.Color.FromArgb(TextColor.ToArgb())).Replace("#", "")}}
Dim XFillColor As Color = Nothing
If HighlightColor <> Nothing Then
XFillColor = New Color() With {.Rgb = New HexBinaryValue With {.Value = System.Drawing.ColorTranslator.ToHtml(System.Drawing.Color.FromArgb(HighlightColor.ToArgb())).Replace("#", "")}}
End If
Dim XRunFont As New RunFont With {.Val = New StringValue(XFontName)}
Dim XRunBold As New Bold() With {.Val = New BooleanValue(FontBold)}
Dim XRunItalic As New Italic() With {.Val = New BooleanValue(FontItalic)}
Dim xRunPropertyCharSet As New RunPropertyCharSet() With {.Val = New Int32Value(Convert.ToInt32(1))}
XRunProperties.Append(XFontSize)
XRunProperties.Append(XColor)
If XFillColor IsNot Nothing Then
XRunProperties.Append(XFillColor)
End If
XRunProperties.Append(XRunFont)
XRunProperties.Append(XRunBold)
XRunProperties.Append(XRunItalic)
XRunProperties.Append(xRunPropertyCharSet)
Dim XText As New Text() With {.Space = SpaceProcessingModeValues.Preserve, .Text = Comment}
XRun.Append(XRunProperties)
XRun.Append(XText)
XCommentText.Append(XRun)
XComment.Append(XCommentText)
Dim DrawingPartList As List(Of VmlDrawingPart) = DocInfo.WSPart.VmlDrawingParts.ToList()
Dim CommentCount As Integer = 0
Dim DrawingPart As VmlDrawingPart = DocInfo.WSPart.GetPartsOfType(Of VmlDrawingPart)().FirstOrDefault()
Dim Writer As XmlTextWriter = Nothing
Dim DrawingPartStream As Stream = Nothing
Dim SR As StreamReader = Nothing
If DrawingPart Is Nothing Then
DrawingPart = DocInfo.WSPart.AddNewPart(Of VmlDrawingPart)()
DrawingPartStream = DrawingPart.GetStream(IO.FileMode.Create)
SR = New StreamReader(DrawingPartStream)
Writer = New XmlTextWriter(DrawingPartStream, Encoding.UTF8)
Dim XMLText As String = <![CDATA[
<xml xmlns:v="urn:schemas-microsoft-com:vml" xmlns:o=\"urn:schemas-microsoft-com:office:office" xmlns:x="urn:schemas-microsoft-com:office:excel">
<o:shapelayout v:ext="edit">
<o:idmap v:ext="edit" data="1" />
</o:shapelayout>
<v:shapetype id="_x0000_t202" coordsize="21600,21600" o:spt="202" path="m,l,21600r21600,l21600,xe">
<v:stroke joinstyle="miter"/>
<v:path gradientshapeok="t" o:connecttype="rect" />
</v:shapetype>
]]>.Value.Trim()
Writer.WriteRaw(XMLText)
Writer.Flush()
DocInfo.WSPart.Worksheet.AddNamespaceDeclaration("xdr", "http://schemas.openxmlformats.org/drawingml/2006/spreadsheetDrawing")
DocInfo.WSPart.Worksheet.AddNamespaceDeclaration("x14", "http://schemas.microsoft.com/office/spreadsheetml/2009/9/main")
Dim PartID As String = DocInfo.WSPart.GetIdOfPart(DrawingPart)
Dim XLegacyDrawing As LegacyDrawing = New LegacyDrawing() With {.Id = PartID}
DocInfo.WSPart.Worksheet.Append(XLegacyDrawing)
Else
DrawingPartStream = DrawingPart.GetStream()
SR = New StreamReader(DrawingPartStream)
Dim ReadText As String = SR.ReadToEnd()
Dim MatchColl As MatchCollection = Nothing
Dim MatchPattern As New Regex("\<v:shape ")
MatchColl = MatchPattern.Matches(ReadText)
CommentCount = MatchColl.Count
MatchColl = Nothing
MatchPattern = Nothing
Writer = New XmlTextWriter(DrawingPartStream, Encoding.UTF8)
End If
Dim commentsVmlXml As String = String.Empty
commentsVmlXml = GetNoteVMLShapeXML(XCell.CellReference.Value, CommentCount)
Writer.WriteRaw(commentsVmlXml)
Writer.Flush()
Writer.Close()
Writer.Dispose()
Writer = Nothing
SR.Close()
SR.Dispose()
DrawingPartStream.Close()
DrawingPartStream.Dispose()
End Sub
Public Shared Sub AddThreadedComment(DocInfo As ExcelDocInfo, XCell As Cell, XAuthor As String, Comment As String)
If DocInfo Is Nothing Then
Exit Sub
End If
If XCell Is Nothing Then
Exit Sub
End If
If String.IsNullOrEmpty(XAuthor) Then
Exit Sub
End If
If String.IsNullOrEmpty(Comment) Then
Exit Sub
End If
Dim CommentsPart As WorksheetCommentsPart = Nothing
If DocInfo.WSPart.WorksheetCommentsPart Is Nothing Then
CommentsPart = DocInfo.WSPart.AddNewPart(Of WorksheetCommentsPart)
Else
CommentsPart = DocInfo.WSPart.WorksheetCommentsPart()
End If
Dim XComments As Comments = CommentsPart.Comments
If XComments Is Nothing Then
XComments = New Comments() With {.MCAttributes = New MarkupCompatibilityAttributes() With {.Ignorable = "xr"}}
XComments.AddNamespaceDeclaration("mc", "http://schemas.openxmlformats.org/markup-compatibility/2006")
XComments.AddNamespaceDeclaration("xr", "http://schemas.microsoft.com/office/spreadsheetml/2014/revision")
CommentsPart.Comments = XComments
End If
Dim PersPart As WorkbookPersonPart = DocInfo.WBPart.GetPartsOfType(Of WorkbookPersonPart).FirstOrDefault()
If PersPart Is Nothing Then
PersPart = DocInfo.WBPart.AddNewPart(Of WorkbookPersonPart)
End If
Dim PersList As PersonList = PersPart.PersonList
If PersList Is Nothing Then
PersList = New PersonList
PersList.AddNamespaceDeclaration("x", "http://schemas.openxmlformats.org/spreadsheetml/2006/main")
PersPart.PersonList = PersList
End If
Dim Pers As Person = (From P As Person In PersList.AsEnumerable() Where P.DisplayName.Value = XAuthor Select P).FirstOrDefault()
If Pers Is Nothing Then
Pers = New Person() With {.DisplayName = New StringValue(XAuthor), .Id = New StringValue("{" & Guid.NewGuid().ToString().ToUpper() & "}"), .UserId = New StringValue(XAuthor), .ProviderId = New StringValue("None")}
PersList.Append(Pers)
End If
Dim XAuthors As Authors = XComments.GetFirstChild(Of Authors)
If XAuthors Is Nothing Then
XAuthors = New Authors()
XComments.Append(XAuthors)
End If
Dim AuthorGUID As String = "{" & Guid.NewGuid().ToString() & "}"
Dim XLAuthor As Author = New Author() With {.Text = "tc=" & AuthorGUID}
XAuthors.Append(XLAuthor)
Dim WSThreadedCommentsPart As WorksheetThreadedCommentsPart = DocInfo.WSPart.WorksheetThreadedCommentsParts.FirstOrDefault()
If WSThreadedCommentsPart Is Nothing Then
WSThreadedCommentsPart = DocInfo.WSPart.AddNewPart(Of WorksheetThreadedCommentsPart)
End If
Dim XThreadedComments As ThreadedComments = WSThreadedCommentsPart.ThreadedComments
If XThreadedComments Is Nothing Then
XThreadedComments = New ThreadedComments()
WSThreadedCommentsPart.ThreadedComments = XThreadedComments
End If
Dim XThreadedComment As ThreadedComment = New ThreadedComment() With {.Ref = New StringValue(XCell.CellReference), .DT = New DateTimeValue(Now().ToUniversalTime()), .PersonId = Pers.Id, .Id = New StringValue(AuthorGUID)}
Dim XThreadedCommentText As New ThreadedCommentText(Comment)
XThreadedComment.Append(XThreadedCommentText)
XThreadedComments.Append(XThreadedComment)
Dim AuthorID As UInt32 = Convert.ToUInt32(XAuthors.ToList().IndexOf(XLAuthor))
Dim CommList As CommentList = XComments.GetFirstChild(Of CommentList)
If CommList Is Nothing Then
CommList = New CommentList()
XComments.Append(CommList)
End If
Dim XComment As Comment = XComments.CommentList.AppendChild(Of Comment)(New Spreadsheet.Comment() With {
.AuthorID = New UInt32Value(AuthorID),
.Reference = XCell.CellReference,
.ShapeId = New UInt32Value(Convert.ToUInt32(0))
})
XComment.SetAttribute(New OpenXmlAttribute("uid", "http://schemas.microsoft.com/office/spreadsheetml/2014/revision", Pers.Id.Value))
Dim Prepend As String = "[Threaded comment]
Your version of Excel allows you to read this threaded comment; however, any edits to it will get removed if the file is opened in a newer version of Excel. Learn more: https://go.microsoft.com/fwlink/?linkid=870924
Comment:
"
Dim XCommentText As New CommentText()
Dim XText As New Text() With {.Text = Prepend & Comment}
XCommentText.Append(XText)
XComment.Append(XCommentText)
Dim DrawingPartList As List(Of VmlDrawingPart) = DocInfo.WSPart.VmlDrawingParts.ToList()
Dim CommentCount As Integer = 0
Dim DrawingPart As VmlDrawingPart = DocInfo.WSPart.GetPartsOfType(Of VmlDrawingPart)().FirstOrDefault()
Dim Writer As XmlTextWriter = Nothing
Dim DrawingPartStream As Stream = Nothing
Dim SR As StreamReader = Nothing
If DrawingPart Is Nothing Then
DrawingPart = DocInfo.WSPart.AddNewPart(Of VmlDrawingPart)()
DrawingPartStream = DrawingPart.GetStream(IO.FileMode.Create)
SR = New StreamReader(DrawingPartStream)
Writer = New XmlTextWriter(DrawingPartStream, Encoding.UTF8)
Dim XMLText As String = <![CDATA[
<xml xmlns:v="urn:schemas-microsoft-com:vml" xmlns:o=\"urn:schemas-microsoft-com:office:office" xmlns:x="urn:schemas-microsoft-com:office:excel">
<o:shapelayout v:ext="edit">
<o:idmap v:ext="edit" data="1" />
</o:shapelayout>
<v:shapetype id="_x0000_t202" coordsize="21600,21600" o:spt="202" path="m,l,21600r21600,l21600,xe">
<v:stroke joinstyle="miter"/>
<v:path gradientshapeok="t" o:connecttype="rect" />
</v:shapetype>
]]>.Value.Trim()
Writer.WriteRaw(XMLText)
Writer.Flush()
DocInfo.WSPart.Worksheet.AddNamespaceDeclaration("xdr", "http://schemas.openxmlformats.org/drawingml/2006/spreadsheetDrawing")
DocInfo.WSPart.Worksheet.AddNamespaceDeclaration("x14", "http://schemas.microsoft.com/office/spreadsheetml/2009/9/main")
Dim PartID As String = DocInfo.WSPart.GetIdOfPart(DrawingPart)
Dim XLegacyDrawing As LegacyDrawing = New LegacyDrawing() With {.Id = PartID}
DocInfo.WSPart.Worksheet.Append(XLegacyDrawing)
Else
DrawingPartStream = DrawingPart.GetStream()
SR = New StreamReader(DrawingPartStream)
Dim ReadText As String = SR.ReadToEnd()
Dim MatchColl As MatchCollection = Nothing
Dim MatchPattern As New Regex("\<v:shape ")
MatchColl = MatchPattern.Matches(ReadText)
CommentCount = MatchColl.Count
MatchColl = Nothing
MatchPattern = Nothing
Writer = New XmlTextWriter(DrawingPartStream, Encoding.UTF8)
End If
Dim commentsVmlXml As String = String.Empty
commentsVmlXml = GetThreadedCommentVMLShapeXML(XCell.CellReference.Value, CommentCount)
Writer.WriteRaw(commentsVmlXml)
Writer.Flush()
Writer.Close()
Writer.Dispose()
Writer = Nothing
SR.Close()
SR.Dispose()
DrawingPartStream.Close()
DrawingPartStream.Dispose()
End Sub
Public Shared Sub FinalizeComments(DocInfo As ExcelDocInfo)
Dim DrawingPart As VmlDrawingPart = DocInfo.WSPart.GetPartsOfType(Of VmlDrawingPart)().FirstOrDefault()
If DrawingPart IsNot Nothing Then
Using DrawingPartStream As Stream = DrawingPart.GetStream()
Using SR As StreamReader = New StreamReader(DrawingPartStream)
Dim ReadText As String = SR.ReadToEnd()
If Not ReadText.ToLower().EndsWith("</xml>") Then
Using Writer As XmlTextWriter = New XmlTextWriter(DrawingPartStream, Encoding.UTF8)
Writer.WriteRaw("</xml>")
Writer.Flush()
Writer.Close()
End Using
End If
SR.Close()
End Using
DrawingPartStream.Close()
End Using
End If
End Sub
Public Shared Function GetCell(ExcelRow As Row, ColumnNumber As Integer) As Cell
Dim WSCell As Cell = Nothing
If (From C As Cell In ExcelRow.Elements(Of Cell) Where C.CellReference.Value = ExcelColToName(ColumnNumber) & ExcelRow.RowIndex.ToString()).Count > 0 Then
WSCell = (From C As Cell In ExcelRow.Elements(Of Cell) Where C.CellReference.Value = ExcelColToName(ColumnNumber) & ExcelRow.RowIndex.ToString()).FirstOrDefault()
Else
WSCell = New Cell() With {.CellReference = ExcelColToName(ColumnNumber) & ExcelRow.RowIndex.ToString()}
ExcelRow.InsertAt(Of Cell)(WSCell, ExcelRow.Elements(Of Cell).Count)
End If
Return WSCell
End Function
Public Shared Function GetRow(SData As SheetData, RowNumber As Integer) As Row
Dim R As Row = Nothing
Dim RIdx As UInt32Value = Convert.ToUInt32(RowNumber)
If SData.Elements(Of Row).Count > 0 Then
R = (From ERow As Row In SData.Elements(Of Row) Where ERow.RowIndex = RIdx).FirstOrDefault()
End If
If R Is Nothing Then
R = New Row() With {.RowIndex = RIdx}
SData.Append(R)
End If
Return R
End Function
End Class
Public Class TestCase
Public Sub RunTest()
'This sample does not dive into the creation of the spreadsheet. This example focuses strictly on notes and threaded comments.
'In a production example, there would be another sub in the OpenXML class that would populate this ExcelDocInfo object.
'Note that this code will fail as the objects within the DocInfo object currently have no reference to actual objects
Dim DocInfo As New ExcelDocInfo
Dim RowIdx As Integer = 1
Dim ColIdx As Integer = 1
Dim XRow As Row = OpenXML.GetRow(DocInfo.SData, RowIdx)
Dim XCell As Cell = OpenXML.GetCell(XRow, ColIdx)
OpenXML.AddThreadedComment(DocInfo, XCell, "Author Name", "Comment Text Goes Here")
OpenXML.FinalizeComments(DocInfo)
End Sub
End Class
Great post - I was going through that struggle. :-)
I had to make the following changes for the code to work in my case.
Without these changes Excel was unable to open the resulting document.
What is still failing is starting off from a ClosedXML generated document that contains old-school notes.
Remove the backslash in 2 locations of xmlns:o=\"urn:schemas-microsoft-com
Add ToUpper here, a GUID needs to be uppercase:
Dim AuthorGUID As String = "{" & Guid.NewGuid().ToString().ToUpper() & "}"
Ensure the x:tableParts element is after the x:legacyDrawing element in the sheet xml
Dim PartID As String = DocInfo.WSPart.GetIdOfPart(DrawingPart)
Dim XLegacyDrawing As LegacyDrawing = New LegacyDrawing() With {.Id = PartID}
Dim tableXMLElement = DocInfo.WSPart.Worksheet.ChildElements().Where(Function(x) x.GetType Is GetType(TableParts)).FirstOrDefault
If tableXMLElement IsNot Nothing Then
tableXMLElement.InsertBeforeSelf(Of OpenXmlElement)(XLegacyDrawing)
Else
DocInfo.WSPart.Worksheet.Append(XLegacyDrawing)
End If
I can get file from template which passing templateid and documentid, when retrun from api , i will get as base64string format, and when i try to convert as byte,
I get an error "Additional information: The input is not a valid Base-64 string as it contains a non-base 64 character, more than two padding characters, or an illegal character among the padding characters."
Here the code which i used to download file from template
Dim rest As New Chilkat.Rest
Dim success As Boolean
Dim bTls As Boolean = True
Dim port As Integer = 443
Dim bAutoReconnect As Boolean = True
success = rest.Connect("demo.docusign.net", port, bTls, bAutoReconnect)
If (success <> True) Then
Debug.WriteLine("ConnectFailReason: " & rest.ConnectFailReason)
Debug.WriteLine(rest.LastErrorText)
Exit Sub
End If
rest.AddHeader("X-DocuSign-Authentication", "{ ""Username"": ""DocuSign#example.com"", ""Password"":""DocuSign_password"", ""IntegratorKey"":""DocuSign_Integrator_Key"" }")
Dim sbResponseBody As New Chilkat.StringBuilder
success = rest.FullRequestNoBodySb("GET", "/restapi/v2.1/accounts/xxxx/templates/xxxx-xxxx-xxxx-xxxx-xxxx/documents/x", sbResponseBody)
If (success <> True) Then
Debug.WriteLine(rest.LastErrorText)
Exit Sub
End If
Dim respStatusCode As Integer = rest.ResponseStatusCode
If (respStatusCode >= 400) Then
Debug.WriteLine("Response Status Code = " & respStatusCode)
Debug.WriteLine("Response Header:")
Debug.WriteLine(rest.ResponseHeader)
Debug.WriteLine("Response Body:")
Debug.WriteLine(sbResponseBody.GetAsString())
Exit Sub
End If
Dim jsonResponse As New Chilkat.JsonObject
jsonResponse.LoadSb(sbResponseBody)
Dim pdfBytes As Byte() = Convert.FromBase64String(sbResponseBody.ToString)
Regards,
Aravind
i changed my code from chilkat dll to Docusing dll 3.0.0 , using docusing dll i can download file from envelope, here i past my code , it will useful to some other developer.I am used .net framework code download file from file stream.
Private Function DoWnload(ByVal accessToken As String, ByVal basePath As String, ByVal accountId As String, ByVal envelopeId As String, ByVal documents As List(Of EnvelopeDocItem), ByVal docSelect As String) As String
Dim config = New Configuration(New ApiClient(basePath))
config.AddDefaultHeader("Authorization", "Bearer " & accessToken)
Dim envelopesApi As EnvelopesApi = New EnvelopesApi(config)
Dim results As System.IO.Stream = envelopesApi.GetDocument(accountId, envelopeId, docSelect)
Dim docItem As EnvelopeDocItem = documents.FirstOrDefault(Function(d) docSelect.Equals(d.DocumentId))
Dim docName As String = docItem.Name
Dim hasPDFsuffix As Boolean = docName.ToUpper().EndsWith(".PDF")
Dim pdfFile As Boolean = hasPDFsuffix
Dim docType As String = docItem.Type
If ("content".Equals(docType) OrElse "summary".Equals(docType)) AndAlso Not hasPDFsuffix Then
docName += ".pdf"
pdfFile = True
End If
If "zip".Equals(docType) Then
docName += ".zip"
End If
Dim mimetype As String
If pdfFile Then
mimetype = "application/pdf"
ElseIf "zip".Equals(docType) Then
mimetype = "application/zip"
Else
mimetype = "application/octet-stream"
End If
Dim bytesRead As Integer
Dim buffer(4096) As Byte
Using outFile As New System.IO.FileStream("C:\File.pdf", IO.FileMode.Create, IO.FileAccess.Write)
Do
bytesRead = results.Read(buffer, 0, buffer.Length)
If bytesRead > 0 Then
outFile.Write(buffer, 0, bytesRead)
End If
Loop While bytesRead > 0
End Using
Return ""
End Function
Dim envelopeDocItems As List(Of EnvelopeDocItem) = New List(Of EnvelopeDocItem) From {
New EnvelopeDocItem With {
.Name = "Combined",
.Type = "content",
.DocumentId = "combined"
},
New EnvelopeDocItem With {
.Name = "Zip archive",
.Type = "zip",
.DocumentId = "archive"
}
Thanks to Inbar Gazit...
Thanks and Regards,
Aravind
Here is an example: https://www.example-code.com/vbnet/docusign_download_envelope_document.asp
Also see the other VB.NET DocuSign examples: https://www.example-code.com/vbnet/docusign.asp
I have a Public class with a Public Shared Dictionary in vb.net. The constructor does not seem to be running. I have a breakpoint in the constructor which does not break. Also when I make a database update, the new values do not show up in the dictionary.
Public Class SkywalkerPolicy
Public Shared CustomPolicies As Dictionary(Of String, String)
Shared Sub New()
CustomPolicies = New Dictionary(Of String, String)
Dim bvin As String = String.Empty
Dim title As String = String.Empty
Dim poldescr As String = String.Empty
Dim dtResult As New DataTable("Result")
dtResult.Locale = System.Globalization.CultureInfo.InvariantCulture
Dim request As New DataRequest
request.Command = "sky_PolicyDictionary_s"
request.CommandType = CommandType.StoredProcedure
request.Transactional = False
Dim result As DataSet
result = SqlDataHelper.ExecuteDataSet(request)
If Not result Is Nothing Then
If result.Tables.Count() > 0 Then
dtResult = result.Tables(0)
For Each row In dtResult.AsEnumerable
bvin = row.Item(1)
title = row.Item(0)
poldescr = row.Item(2)
If CustomPolicies.ContainsKey(title) Then
CustomPolicies(title) += poldescr
Else
CustomPolicies.Add(title, poldescr)
End If
Next
End If
End If
End Sub
End Class
When I access the dictionary, any changes I've made to the data do not show up.
Dim pol As String = SkywalkerPolicy.CustomPolicies("Orders and Shipping Details")
Does anyone have any suggestions as to how I can get the constructor to work?
Or should I have an additional Sub which duplicates initializing the dictionary before I use it?
Thanks
I have a workaround with an Update routine which I call just before accessing the dictionary. But I am still unclear why I can't step through the constructor. So if anyone can answer the original question, I would appreciate an update. Thank you.
Public Class SkywalkerPolicy
Public Shared CustomPolicies As Dictionary(Of String, String)
Shared Sub New()
CustomPolicies = New Dictionary(Of String, String)
Dim bvin As String = String.Empty
Dim title As String = String.Empty
Dim poldescr As String = String.Empty
Dim dtResult As New DataTable("Result")
dtResult.Locale = System.Globalization.CultureInfo.InvariantCulture
Dim request As New DataRequest
request.Command = "sky_PolicyDictionary_s"
request.CommandType = CommandType.StoredProcedure
request.Transactional = False
Dim result As DataSet
result = SqlDataHelper.ExecuteDataSet(request)
If Not result Is Nothing Then
If result.Tables.Count() > 0 Then
dtResult = result.Tables(0)
For Each row In dtResult.AsEnumerable
bvin = row.Item(1)
title = row.Item(0)
poldescr = row.Item(2)
If CustomPolicies.ContainsKey(title) Then
CustomPolicies(title) += poldescr
Else
CustomPolicies.Add(title, poldescr)
End If
Next
End If
End If
End Sub
Public Shared Sub UpdateDictionary()
CustomPolicies.Clear()
Dim bvin As String = String.Empty
Dim title As String = String.Empty
Dim poldescr As String = String.Empty
Dim dtResult As New DataTable("Result")
dtResult.Locale = System.Globalization.CultureInfo.InvariantCulture
Dim request As New DataRequest
request.Command = "sky_PolicyDictionary_s"
request.CommandType = CommandType.StoredProcedure
request.Transactional = False
Dim result As DataSet
result = SqlDataHelper.ExecuteDataSet(request)
If Not result Is Nothing Then
If result.Tables.Count() > 0 Then
dtResult = result.Tables(0)
For Each row In dtResult.AsEnumerable
bvin = row.Item(1)
title = row.Item(0)
poldescr = row.Item(2)
If CustomPolicies.ContainsKey(title) Then
CustomPolicies(title) += poldescr
Else
CustomPolicies.Add(title, poldescr)
End If
Next
End If
End If
End Sub
End Class
I am looking at monitors list in
HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Enum\DISPLAY
In Windows 7, there are a subkey under each screen node named "Control" that indicate if the screen is active or not.
In Windows 8 there are no such subkey.
How can determine if a monitor is active or not from the Windows 8 registry?
Try this code (I verified this):
Public Function GetMonitorDetails() As List(Of WSGetLoginData.Monitor)
'Open the Display Reg-Key
Dim wmiPNPID As New List(Of String)
Dim mc As System.Management.ManagementClass
Dim moc As ManagementObjectCollection
Dim PathPNPID As String
mc = New ManagementClass("Win32_DesktopMonitor")
moc = mc.GetInstances()
For Each mo In moc
PathPNPID = mo.Item("PNPDeviceID")
If PathPNPID.Trim <> "" AndAlso PathPNPID.Contains("\") Then
PathPNPID = PathPNPID.Substring(PathPNPID.LastIndexOf("\") + 1)
wmiPNPID.Add(PathPNPID.ToUpper)
End If
Next
Dim Display As RegistryKey = Registry.LocalMachine
Dim bFailed As [Boolean] = False
Dim obj_ListMonitor As New List(Of WSGetLoginData.Monitor)
Try
Display = Registry.LocalMachine.OpenSubKey("SYSTEM\CurrentControlSet\Enum\DISPLAY")
Catch
bFailed = True
End Try
If Not bFailed And (Display IsNot Nothing) Then
'Get all MonitorIDss
For Each sMonitorID As String In Display.GetSubKeyNames()
Dim MonitorID As RegistryKey = Display.OpenSubKey(sMonitorID)
If MonitorID IsNot Nothing Then
'Get all Plug&Play ID's
For Each sPNPID As String In MonitorID.GetSubKeyNames()
Dim PnPID As RegistryKey = MonitorID.OpenSubKey(sPNPID)
If PnPID IsNot Nothing Then
Dim sSubkeys As String() = PnPID.GetSubKeyNames()
'Check if Monitor is active
'If Array.IndexOf(sSubkeys, "Control") > -1 Then
If Not wmiPNPID Is Nothing AndAlso wmiPNPID.Count > 0 AndAlso wmiPNPID.Contains(sPNPID.ToUpper) Then
If Array.IndexOf(sSubkeys, "Device Parameters") > -1 Then
Dim DevParam As RegistryKey = PnPID.OpenSubKey("Device Parameters")
Dim sSerial As String = ""
Dim sModel As String = ""
'Define Search Keys
Dim sSerFind As New String(New Char() {ChrW(0), ChrW(0), ChrW(0), ChrW(&HFF)})
Dim sModFind As New String(New Char() {ChrW(0), ChrW(0), ChrW(0), ChrW(&HFC)})
'Get the EDID code
Dim bObj As Byte() = TryCast(DevParam.GetValue("EDID", Nothing), Byte())
If bObj IsNot Nothing Then
'Get the 4 Vesa descriptor blocks
Dim sDescriptor As String() = New String(3) {}
sDescriptor(0) = Encoding.[Default].GetString(bObj, &H36, 18)
sDescriptor(1) = Encoding.[Default].GetString(bObj, &H48, 18)
sDescriptor(2) = Encoding.[Default].GetString(bObj, &H5A, 18)
sDescriptor(3) = Encoding.[Default].GetString(bObj, &H6C, 18)
'Search the Keys
For Each sDesc As String In sDescriptor
If sDesc.Contains(sSerFind) Then
sSerial = sDesc.Substring(4).Replace(vbNullChar, "").Trim()
End If
If sDesc.Contains(sModFind) Then
sModel = sDesc.Substring(4).Replace(vbNullChar, "").Trim()
End If
Next
End If
If Not String.IsNullOrEmpty(sSerial) AndAlso sSerial.Trim <> "" Then
Dim insertar As Boolean = True
If Not obj_ListMonitor Is Nothing AndAlso obj_ListMonitor.Count > 0 Then
For k As Integer = 0 To obj_ListMonitor.Count - 1
If obj_ListMonitor(k).SerialNumber.Trim = sSerial Then
insertar = False
Exit For
End If
Next
End If
If insertar Then
Dim obj_monitor As New WSGetLoginData.Monitor
obj_monitor.UUID = Security.FingerPrint.Value(sModel & sSerial)
obj_monitor.Modelo = sModel
obj_monitor.SerialNumber = sSerial
obj_ListMonitor.Add(obj_monitor)
End If
End If
End If
End If
End If
Next
End If
Next
End If
Return obj_ListMonitor
End Function
I have a report already setup on the ReportServer. And its subscription as well. What I'm trying to do is add the ParameterValue "CC" and some email addresses then send the email out. It doesn't seem to work.
My code:
Dim emailReader As SqlDataReader = selCount.ExecuteReader
Dim emailsTest As List(Of String) = New List(Of String)
emailsTest.Add("test1#pen.com")
emailsTest.Add("test2#pen.com")
emailsTest.Add("test3#pen.com")
emailsTest.Add("test4#pen.com")
If emailReader.HasRows() Then 'checks to see if there any quotes in query
For Each subscrp As rs.Subscription In subscr
Dim allValues = subscrp.DeliverySettings.ParameterValues
Dim allValuesList As List(Of ReportTriggerTemplate1.rs.ParameterValueOrFieldReference) = allValues.ToList()
Dim CCParameter As ReportTriggerTemplate1.rs.ParameterValue = New ReportTriggerTemplate1.rs.ParameterValue()
CCParameter.Name = "CC"
CCParameter.Value = String.Empty
allValuesList.Add(CCParameter)
Dim toValue = CType(allValuesList.Item(7), ReportTriggerTemplate1.rs.ParameterValue)
For Each testEmail As String In emailsTest
Dim ownerEmail As String = testEmail
If toValue.Value.Contains(ownerEmail) Then
'skip
ElseIf toValue.Value = String.Empty Then
toValue.Value += ownerEmail
Else
toValue.Value += "; " & ownerEmail
End If
Next
subscrp.DeliverySettings.ParameterValues = allValuesList.ToArray()
Dim hello As String = "hi"
tr.FireEvent(EventType, subscrp.SubscriptionID) 'forces subscription to be sent
Next
What I'm adding to toValue.Value doesn't seem to be adding to the report's CC subscription field at all. So what am I missing?
http://msdn.microsoft.com/en-us/library/ms154020%28v=SQL.100%29.aspx
http://msdn.microsoft.com/en-us/library/reportservice2005.reportingservice2005.getsubscriptionproperties.aspx
http://msdn.microsoft.com/en-us/library/reportservice2005.reportingservice2005.setsubscriptionproperties%28v=SQL.105%29.aspx
Try
tr = New rs.ReportingService2005
Dim extSettings As ExtensionSettings = Nothing
Dim desc As String = Nothing
Dim active As ActiveState = Nothing
Dim status As String = Nothing
Dim matchData As String = Nothing
Dim values As ParameterValue() = Nothing
Dim extensionParams As ParameterValueOrFieldReference() = Nothing
Dim mainLogin As System.Net.NetworkCredential = New System.Net.NetworkCredential("ADUser", "Password", "NetworkName")
If mainLogin Is Nothing Then
tr.Credentials = System.Net.CredentialCache.DefaultCredentials
Else
tr.Credentials = mainLogin
End If
'skip to relevant code
For Each subscrp As rs.Subscription In subscr
Dim allValues = subscrp.DeliverySettings.ParameterValues
Dim allValuesList As List(Of ReportTriggerTemplate1.rs.ParameterValueOrFieldReference) = allValues.ToList()
If CType(allValuesList.Item(0), ReportTriggerTemplate1.rs.ParameterValue).Value = "test#pen.com" Then
Dim subsID = subscrp.SubscriptionID
'important code just below
tr.GetSubscriptionProperties(subsID, extSettings, desc, active, status, EventType, matchData, extensionParams)
''''add change to CC here
Dim extSettingsList As List(Of ReportTriggerTemplate1.rs.ParameterValueOrFieldReference) = extSettings.ParameterValues.ToList()
If CType(extSettingsList.Item(1), ReportTriggerTemplate1.rs.ParameterValue).Name = "CC" Then
If CType(extSettingsList.Item(1), ReportTriggerTemplate1.rs.ParameterValue).Value = String.Empty Then
CType(extSettingsList.Item(1), ReportTriggerTemplate1.rs.ParameterValue).Value = emailsTest.Item(0) & ";" & emailsTest.Item(1)
Else
CType(extSettingsList.Item(1), ReportTriggerTemplate1.rs.ParameterValue).Value += ";" & emailsTest.Item(0) & ";" & emailsTest.Item(1)
End If
Else
Dim CCParameter As ReportTriggerTemplate1.rs.ParameterValue = New ReportTriggerTemplate1.rs.ParameterValue()
CCParameter.Name = "CC"
CCParameter.Value = emailsTest.Item(0) & ";" & emailsTest.Item(1)
extSettingsList.Insert(1, CCParameter)
extSettings.ParameterValues = extSettingsList.ToArray
End If
'important code just below
tr.SetSubscriptionProperties(subsID, extSettings, desc, EventType, matchData, extensionParams)
tr.FireEvent(EventType, subscrp.SubscriptionID) 'forces subscription to be sent
Else
End If
Next