I am trying to send JSON object from VB.NET app (3.5 Framework).
I am using this code:
Private Function sendSMS()
Dim objHTTP As Object
Dim json As String
Dim result As String
Dim URL As String
json = fJSON()
objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
URL = "https://api.XXXXXXXXX.com/api/3.0/sms/send"
objHTTP.Open("POST", URL, False)
objHTTP.setRequestHeader("Content-type", "application/json")
objHTTP.send(json)
result = objHTTP.responseText
objHTTP = Nothing
End Function
Private Function fJSON() As String
fJSON = "{"
fJSON = fJSON & """api_key"":""XXXXXXXXXXXXXXXXXXX"","
fJSON = fJSON & """concat"":1,"
fJSON = fJSON & """fake"":1,"
fJSON = fJSON & """messages"":["
fJSON = fJSON & "{"
fJSON = fJSON & """from"":""SHOP"","
fJSON = fJSON & """to"":""3400000000"","
fJSON = fJSON & """text"":""LOREM IPSUM"""
fJSON = fJSON & "}]}"
End Function
But I am getting this error in the line code:
Line code:
objHTTP.setRequestHeader("Content-type", "application/json")
Error:
System.Runtime.InteropServices.COMException (0x80004005): Error no especificado
What is wrong?
Sometimes user doesn't have enough privileges to run some COM Methods. Here your exception says "System.Runtime.InteropServices.COMException (0x80004005)" which is based on System.Runtime.InteropServices.COMException. To sort it out, Will you ran Visual Studio as Administrator and check wheather that logic works for you or not?
Related
I need result from this JSON:
{
"access_token": "eyJhbGciOiJSUzI1NiIsImtpZCI6IjBGOTkyNkZFQTUyOTgxRjZDMjBENUMzNUQ0NjUxMzAzQ0QzQzBFMzIiLCJ0eXAiOiJhdCtqd 3QiLCJ4NXQiOiJENWttX3FVcGdmYkNEVncxMUdVVEE4MDhEakkifQ.eyJuYmYiOjE2MjA3NzEyNDEsImV4cCI6MTYyMDc3NDg0MSwiaXNzIjoiaH R0cHM6Ly9pZC5wcmVwcm9kLmV0YS5nb3YuZWciLCJhdWQiOiJJbnZvaWNpbmdBUEkiLCJjbGllbnRfaWQiOiJlZWQ4YWY2MS01ZjRmLTQxM2MtYWZlN S1jYjg0YjBiOTlhOGMiLCJJbnRlcm1lZElkIjoiMCIsIkludGVybWVkUklOIjoiIiwiSW50ZXJtZWRFbmZvcmNlZCI6IjIiLCJuYW1lIjoiMjAyNDY5NzM 1OmVlZDhhZjYxLTVmNGYtNDEzYy1hZmU1LWNiODRiMGI5OWE4YyIsInNpZCI6IjJiYzcxYTlhLWQ1MzAtMzc1ZC0zNjMzLTUwN2E3OWFjY2Y1ZiIsInByZW ZlcnJlZF91c2VybmFtZSI6IkVSUCIsIlRheElkIjoiNTE4MDEiLCJUYXhSaW4iOiIyMDI0Njk3MzUiLCJQcm9mSWQiOiI1NDgxNCIsIklzVGF4QWRtaW4iO
iIwIiwiSXNTeXN0ZW0iOiIxIiwiTmF0SWQiOiIiLCJzY29wZSI6WyJJbnZvaWNpbmdBUEkiXX0.IIxTKWdH0cUInlzrIMON95f7S6vW-CBfRoK8ZxOI6mqp
DbRLBaZQZyNoYl4A6JYQR6FJY4YVIFUsAbkKEKwwB1MaOpMMWmkyySfUmgvBMvEo6EZnT-oewnSd2EPF_bIK7-HTGug7Rjdy__wTpBr-6PH5kzR79xXzNh_s
R7TIPcvjJ-nx7eNZREdk4J7M3X8Mfjzww2RkbizN5zXNpmc5OHh_VLtlkA-4zQrs102HA9VFTxLEIdXhrpBqEBmy9dt-onZpuiKbkioV5iH2uwAkQbDvnM9h
p7EJscL0y0xFjfwbAUxQx3ohcXtA31fwyYazKQVKHCtNm9SPgSsQ-rKevQ",
"expires_in": 3600,
"scope": "Accecc DB"
}
I used:
Dim Mytoken As JObject = JObject.Parse(TextBox1.Text)
TextBox2.Text = Mytoken.SelectToken("access_token").ToString
Now I Need to get the uuid, longId, internalId, and hashKey from the acceptedDocuments like this:
{
"submissionId": "5hfhfgy5653uytyu45fg457",
"acceptedDocuments": [
{
"uuid": "hlg5fdg7ggnjgh",
"longId": "jgjhk78jm,jhk54567ujnfgh7fggh",
"internalId": "477",
"hashKey": "dfgdfhdyjfghryjghjj"
}
],
"rejectedDocuments": []
}
You could use Newtonsoft.Json and deserialize the response into an object:
Imports Newtonsoft.Json
Public Class Submission
Public submissionId As String
Public acceptedDocuments As List(Of AcceptedDocuments)
Public rejectedDocuements As String 'not sure of the type of this property
End Class
Public Class AcceptedDocuments
Public uuid As String
Public longId As String
Public internalId As Integer
Public hashKey As String
End Class
Public Function DeserilizeJson(ByRef json As String) As Submission
Dim doc As Submission = JsonConvert.DeserializeObject(Of Submission)(json)
Return doc
End Function
This should result in a Submission class object being created, to which you can reference all of the members of it, including the List of AcceptedDocuments (you can iterate over the list as needed).
I solved the problem
Dim Mytoken As JObject = JObject.Parse(TextBox1.Text)
TextBox2.Text = "My submissionId IS: " & Mytoken.SelectToken("submissionId").ToString & Environment.NewLine & Environment.NewLine
Dim arrray As JArray = JArray.Parse(Mytoken.SelectToken("acceptedDocuments").ToString)
For Each acceptedDocuments In arrray
TextBox2.Text = TextBox2.Text & "My uuid IS: " & acceptedDocuments.SelectToken("uuid").ToString & Environment.NewLine
TextBox2.Text = TextBox2.Text & "My longId IS: " & acceptedDocuments.SelectToken("longId").ToString & Environment.NewLine
TextBox2.Text = TextBox2.Text & "My internalId IS: " & acceptedDocuments.SelectToken("internalId").ToString & Environment.NewLine
TextBox2.Text = TextBox2.Text & "My hashKey IS: " & acceptedDocuments.SelectToken("hashKey").ToString & Environment.NewLine
Next
Im looking to get a list of all the devices on my work admin teamviewer account using vb.net. I would also like to be able to change the "Alias" of a given device using it's device id. i know very little about API's. i found the following example but i am not sure how to adapt it to get the json response.
instead of the accesstoken, i believe i need to use the client id and secret id along with the authorization code in order to use this. if i run it in it's current start i get a 401 unauthorized error. Any help would be appreciated.
i also have no idea how to use "PUT" to change the Alias using the device id which will both be entered in textboxes. ex alias = textbox1.text and device_id = textbox2.text
Private Sub SurroundingSub()
Dim accessToken As String = "xxxxxxxxxxxxxxxxxxx"
Dim apiVersion As String = "v1"
Dim tvApiBaseUrl As String = "https://webapi.teamviewer.com"
Dim address As String = tvApiBaseUrl & "/api/" & apiVersion & "/devices"
Try
Dim request As HttpWebRequest = TryCast(WebRequest.Create(address), HttpWebRequest)
request.Headers.Add("Bearer", accessToken)
request.Method = "GET"
Dim webResp As WebResponse = request.GetResponse()
Catch __unusedException1__ As Exception
msgbox(__unusedException1__.ToString)
End Try
End Sub
Here is the Get all devices code:
Private Sub get_teamviewer_devices()
Dim accessToken As String = "XXXXXXXXXXXXXXXXXXXXX"
Dim apiVersion As String = "v1"
Dim tvApiBaseUrl As String = "https://webapi.teamviewer.com"
Dim address As String = tvApiBaseUrl & "/api/" & apiVersion & "/devices"
Dim result_json As String = Nothing
Try
Dim request As HttpWebRequest = TryCast(WebRequest.Create(address), HttpWebRequest)
request.Headers.Add("Authorization", "Bearer " & accessToken)
request.Method = "GET"
Dim webResp As WebResponse = request.GetResponse()
Using reader = New StreamReader(webResp.GetResponseStream)
result_json = reader.ReadToEnd()
End Using
TextBox1.Text = result_json
Catch __unusedException1__ As Exception
MsgBox(__unusedException1__.ToString)
End Try
End Sub
Here is the PUT portion to change an alias:
Public Sub change_alias(ByVal device_id As String, ByVal alias_str As String)
Dim accessToken As String = "XXXXXXXXXXXXXXXXXXXXX"
Dim apiVersion As String = "v1"
Dim tvApiBaseUrl As String = "https://webapi.teamviewer.com"
Dim address As String = tvApiBaseUrl & "/api/" & apiVersion & "/devices/" & device_id
Dim result As String
Dim alias_str_ As String = Chr(34) & alias_str & Chr(34)
Try
Dim request As HttpWebRequest = TryCast(WebRequest.Create(address), HttpWebRequest)
request.Headers.Add("Authorization", "Bearer " & accessToken)
request.Method = "PUT"
request.ContentType = "application/json"
Using requestWriter2 As New StreamWriter(request.GetRequestStream())
requestWriter2.Write("{""Alias"" : " & alias_str_ & "}")
End Using
Dim webResp As WebResponse = request.GetResponse()
Using reader = New StreamReader(webResp.GetResponseStream)
result = reader.ReadToEnd()
End Using
TextBox1.Text = (result)
Catch __unusedException1__ As Exception
MsgBox(__unusedException1__.ToString)
End Try
End Sub
I'm working with a coworker's code trying to recreate his REST web service in a console application. I'm very new to web services and VB so it's been quite difficult for me. It will work fine on his but I keep getting an Internal Server Error (500). I have looked this up and some suggestions I found were changing "POST" to "GET" but I received "Cannot get content body with this verb-type". I've seen forums about something like this not working from another person's machine. My coworker and I have tried going through it over and over but getting the same results.
This is the Console App
Imports System
Imports System.Collections.Generic
Imports System.IO
Imports System.Linq
Imports System.Net
Imports System.Reflection
Imports System.Text
Imports System.Threading.Tasks
Imports System.Web
Imports System.Web.UI
Imports System.Xml
Module RestConsoleClient
Private req As HttpWebRequest = Nothing
Private res As HttpWebResponse = Nothing
Private responseText As String = ""
Sub Main(args As String())
Dim url As String = ""
Try
If args.Count < 1 OrElse String.IsNullOrEmpty(args(0)) Then
Console.WriteLine("Endpoint Address is required as commandline argument;" _
& vbCrLf & "Copy/Paste one of the endpoint addresses from My.Settings into the Debug commandline arguments section" _
& vbCrLf & vbCrLf & "Press ENTER to start over...")
Console.ReadKey()
Return
Else
url = args(0)
End If
req = CType(WebRequest.Create(url), HttpWebRequest)
req.Method = "POST"
'** The conditions below allowed for generic raw data to be input as text vs. processing input data as a json object.
'** These conditions became redundant with the addition of config for WebContentTypeMapper and corresponding class to accept
'** a post declared with application/json ContentType as generic raw data, and then SUBSEQUENTLY de/serialize the json data as necessary
'If url.Contains("streamweaver") Then
' req.ContentType = "text"
'ElseIf url.Contains("auth") Then
' req.ContentType = "application/json" '; charset=utf-8"
'Else
' 'No other options are yet determined
'End If
req.Timeout = 30000
Dim sJson As String = "{""Name"":""Ashu"",""Age"":""29"",""Exp"":""7 Years"",""Technology"":"".NET""}"
Dim postBytes = Encoding.UTF8.GetBytes(sJson)
req.ContentLength = postBytes.Length
Dim requestStream As Stream = req.GetRequestStream()
requestStream.Write(postBytes, 0, postBytes.Length)
res = CType(req.GetResponse(), HttpWebResponse)
' I retained the basics for response reception even though it was not integral to this test
Dim responseStream As Stream = res.GetResponseStream()
Dim streamReader = New StreamReader(responseStream)
responseText = streamReader.ReadToEnd()
Console.WriteLine("HTTP Response: " & res.StatusCode & " - " & res.StatusDescription.Trim)
Console.WriteLine("[ Response Data: " & responseText.Trim & " ]")
Console.ReadKey()
Catch ex As Exception
Console.WriteLine(ex.Message)
Console.ReadKey()
End Try
End Sub
End Module
This here is the Interface
Imports System.IO
Imports System.ServiceModel
Imports System.ServiceModel.Web
<ServiceContract> _
Public Interface IRestServiceImpl
'<OperationContract> _
'<WebInvoke(Method:="GET", ResponseFormat:=WebMessageFormat.Xml, BodyStyle:=WebMessageBodyStyle.Wrapped, UriTemplate:="xml/{id}")> _
'Function XMLData(id As String) As String
'<OperationContract> _
'<WebInvoke(Method:="GET", ResponseFormat:=WebMessageFormat.Json, BodyStyle:=WebMessageBodyStyle.Wrapped, UriTemplate:="json/{id}")> _
'Function JSONData(id As String) As String
<OperationContract> _
<WebInvoke(Method:="POST", ResponseFormat:=WebMessageFormat.Json, RequestFormat:=WebMessageFormat.Json, BodyStyle:=WebMessageBodyStyle.Bare, UriTemplate:="auth")> _
Function Auth(rData As Stream) As ResponseData
<OperationContract> _
<WebInvoke(Method:="POST", ResponseFormat:=WebMessageFormat.Json, RequestFormat:=WebMessageFormat.Json, BodyStyle:=WebMessageBodyStyle.Bare, UriTemplate:="streamweaver")> _
Function StreamWeaver(sData As Stream) As String
End Interface
And here is the class
Imports System
Imports System.IO
Imports System.Reflection
Imports System.Security.AccessControl
Imports System.Text
Imports Newtonsoft.Json
Public Class RestServiceImpl
Implements IRestServiceImpl
Private filePathOnServer As String = My.Settings.OutputFolder
'Public Function XMLData(id As String) As String Implements IRestServiceImpl.XMLData
' Return "You requested product " & id
'End Function
'Public Function JSONData(id As String) As String Implements IRestServiceImpl.JSONData
' Return "You requested product " & id
'End Function
Public Function Auth(request As Stream) As ResponseData Implements IRestServiceImpl.Auth
Dim streamReader = New StreamReader(request)
Dim requestText As String = streamReader.ReadToEnd()
Dim rData As RequestData = JsonConvert.DeserializeObject(Of RequestData)(requestText)
Dim response = New ResponseData() With { _
.Name = rData.Name, _
.Age = rData.Age, _
.Exp = rData.Exp, _
.Technology = rData.Technology _
}
Dim fileOutput As String = "As of " & DateTime.Now & ", " _
& response.Name.Trim & " is a person who is " _
& response.Age.Trim & " years old, having " _
& response.Exp.Trim & " of experience with " _
& response.Technology.Trim & " technology."
Console.SetError(New StreamWriter("C:\Users\apearson\Documents\Eureka.txt"))
Console.[Error].WriteLine(fileOutput)
Console.[Error].Close()
Dim ctx As WebOperationContext = WebOperationContext.Current
If rData IsNot Nothing Then
ctx.OutgoingResponse.StatusCode = Net.HttpStatusCode.Accepted
Else
ctx.OutgoingResponse.StatusCode = Net.HttpStatusCode.NotAcceptable
End If
Return response
End Function
Public Function StreamWeaver(reqData As Stream) As String Implements IRestServiceImpl.StreamWeaver
StreamWeaver = Nothing
Dim ctx As WebOperationContext = WebOperationContext.Current
If reqData IsNot Nothing Then
ctx.OutgoingResponse.StatusCode = Net.HttpStatusCode.Accepted
Else
ctx.OutgoingResponse.StatusCode = Net.HttpStatusCode.NotAcceptable
End If
Dim streamReader As StreamReader = New StreamReader(reqData)
StreamWeaver = streamReader.ReadToEnd()
Console.SetError(New StreamWriter(filePathOnServer.Trim & "\RestServiceJSONRaw.txt"))
Console.[Error].WriteLine(DateTime.Now & ": " & vbCrLf & StreamWeaver.Trim)
Console.[Error].Close()
Return StreamWeaver
End Function
End Class
If there is anymore information needed, let me know. Again, this is kind of new to me.
I have a form in Access 2010 that allows the user to find an Excel file and map it so that it can easily be accessed from another form. The simplest way to explain it, I think, is with a picture:
The form has this On Load event:
Private Sub Form_Load()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim sSQL As String
Dim sPath As String
Set db = CurrentDb
On Error GoTo Error_Handler
sPath = Application.CurrentProject.Path
sSQL = "Select Setting from tblBackendFiles where Code = 'SourceVerification'"
Set rs = db.OpenRecordset(sSQL)
Me.tVerificationPath = Nz(rs!Setting, "")
If Len(Me.tVerificationPath) = 0 Then
Me.tExcelPath = sPath
End If
Me.cmdAcceptPath.SetFocus
rs.Close
GoTo exit_sub
Error_Handler:
MsgBox Err.number & ": " & Err.Description, vbInformation + vbOKOnly, "Error!"
exit_sub:
Set rs = Nothing
Set db = Nothing
End Sub
What I want is to have the current path of the Excel file displayed in the textbox, which is currently unbound. I've looked around online but I'm having a hard time finding how to actually get the path to show up.
What would be the best way to do this? I'd prefer to do it without VBA if at all possible, but I'm not 100% opposed to it.
I have done this many times. You will have to create a form. On that form, place a textbox called "tbFile", another called "tbFileName" (which is invisible) and a button called "bBrowse".
Then, behind your form, put this:
Option Compare Database
Option Explicit
Private Sub bBrowse_Click()
On Error GoTo Err_bBrowse_Click
Dim strFilter As String
Dim lngFlags As Long
Dim varFileName As Variant
Me.tbHidden.SetFocus
' strFilter = "Access (*.mdb)" & vbNullChar & "*.mdb" _
' & vbNullChar & "All Files (*.*)" & vbNullChar & "*.*"
' strFilter = "Access Files (*.mdb)" & vbNullChar & "*.mdb*"
strFilter = "All Files (*.*)" & vbNullChar & "*.*"
lngFlags = tscFNPathMustExist Or tscFNFileMustExist Or tscFNHideReadOnly
varFileName = tsGetFileFromUser( _
fOpenFile:=True, _
strFilter:=strFilter, _
rlngflags:=lngFlags, _
strInitialDir:="C:\Windows\", _
strDialogTitle:="Find File (Select The File And Click The Open Button)")
'remove the strInitialDir:="C:\Windows\", _ line if you do not want the Browser to open at a specific location
If IsNull(varFileName) Or varFileName = "" Then
Debug.Print "User pressed 'Cancel'."
Beep
MsgBox "File selection was canceled.", vbInformation
Exit Sub
Else
'Debug.Print varFileName
tbFile = varFileName
End If
Call ParseFileName
Exit_bBrowse_Click:
Exit Sub
Err_bBrowse_Click:
MsgBox Err.Number & " - " & Err.Description
Resume Exit_bBrowse_Click
End Sub
Private Function ParseFileName()
On Error GoTo Err_ParseFileName
Dim sFullName As String
Dim sFilePathOnly As String
Dim sDrive As String
Dim sPath As String
Dim sLocation As String
Dim sFileName As String
sFullName = tbFile.Value
' Find the final "\" in the path.
sPath = sFullName
Do While Right$(sPath, 1) <> "\"
sPath = Left$(sPath, Len(sPath) - 1)
Loop
' Find the Drive.
sDrive = Left$(sFullName, InStr(sFullName, ":") + 1)
'tbDrive = sDrive
' Find the Location.
sLocation = Mid$(sPath, Len(sDrive) - 2)
'tbLocation = sLocation
' Find the Path.
sPath = Mid$(sPath, Len(sDrive) + 1)
'tbPath = sPath
' Find the file name.
sFileName = Mid$(sFullName, Len(sPath) + 4)
tbFileName = sFileName
Exit_ParseFileName:
Exit Function
Err_ParseFileName:
MsgBox Err.Number & " - " & Err.Description
Resume Exit_ParseFileName
End Function
Then, create a new Module and paste this into it:
Option Compare Database
Option Explicit
Private Declare Function ts_apiGetOpenFileName Lib "comdlg32.dll" _
Alias "GetOpenFileNameA" (tsFN As tsFileName) As Boolean
Private Declare Function ts_apiGetSaveFileName Lib "comdlg32.dll" _
Alias "GetSaveFileNameA" (tsFN As tsFileName) As Boolean
Private Declare Function CommDlgExtendedError Lib "comdlg32.dll" () As Long
Private Type tsFileName
lStructSize As Long
hwndOwner As Long
hInstance As Long
strFilter As String
strCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
strFile As String
nMaxFile As Long
strFileTitle As String
nMaxFileTitle As Long
strInitialDir As String
strTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
strDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
' Flag Constants
Public Const tscFNAllowMultiSelect = &H200
Public Const tscFNCreatePrompt = &H2000
Public Const tscFNExplorer = &H80000
Public Const tscFNExtensionDifferent = &H400
Public Const tscFNFileMustExist = &H1000
Public Const tscFNPathMustExist = &H800
Public Const tscFNNoValidate = &H100
Public Const tscFNHelpButton = &H10
Public Const tscFNHideReadOnly = &H4
Public Const tscFNLongNames = &H200000
Public Const tscFNNoLongNames = &H40000
Public Const tscFNNoChangeDir = &H8
Public Const tscFNReadOnly = &H1
Public Const tscFNOverwritePrompt = &H2
Public Const tscFNShareAware = &H4000
Public Const tscFNNoReadOnlyReturn = &H8000
Public Const tscFNNoDereferenceLinks = &H100000
Public Function tsGetFileFromUser( _
Optional ByRef rlngflags As Long = 0&, _
Optional ByVal strInitialDir As String = "", _
Optional ByVal strFilter As String = "All Files (*.*)" & vbNullChar & "*.*", _
Optional ByVal lngFilterIndex As Long = 1, _
Optional ByVal strDefaultExt As String = "", _
Optional ByVal strFileName As String = "", _
Optional ByVal strDialogTitle As String = "", _
Optional ByVal fOpenFile As Boolean = True) As Variant
On Error GoTo tsGetFileFromUser_Err
Dim tsFN As tsFileName
Dim strFileTitle As String
Dim fResult As Boolean
' Allocate string space for the returned strings.
strFileName = Left(strFileName & String(256, 0), 256)
strFileTitle = String(256, 0)
' Set up the data structure before you call the function
With tsFN
.lStructSize = Len(tsFN)
.hwndOwner = Application.hWndAccessApp
.strFilter = strFilter
.nFilterIndex = lngFilterIndex
.strFile = strFileName
.nMaxFile = Len(strFileName)
.strFileTitle = strFileTitle
.nMaxFileTitle = Len(strFileTitle)
.strTitle = strDialogTitle
.flags = rlngflags
.strDefExt = strDefaultExt
.strInitialDir = strInitialDir
.hInstance = 0
.strCustomFilter = String(255, 0)
.nMaxCustFilter = 255
.lpfnHook = 0
End With
' Call the function in the windows API
If fOpenFile Then
fResult = ts_apiGetOpenFileName(tsFN)
Else
fResult = ts_apiGetSaveFileName(tsFN)
End If
' If the function call was successful, return the FileName chosen
' by the user. Otherwise return null. Note, the CancelError property
' used by the ActiveX Common Dialog control is not needed. If the
' user presses Cancel, this function will return Null.
If fResult Then
rlngflags = tsFN.flags
tsGetFileFromUser = tsTrimNull(tsFN.strFile)
Else
tsGetFileFromUser = Null
End If
tsGetFileFromUser_End:
On Error GoTo 0
Exit Function
tsGetFileFromUser_Err:
Beep
MsgBox Err.Description, , "Error: " & Err.Number _
& " in function basBrowseFiles.tsGetFileFromUser"
Resume tsGetFileFromUser_End
End Function
' Trim Nulls from a string returned by an API call.
Private Function tsTrimNull(ByVal strItem As String) As String
On Error GoTo tsTrimNull_Err
Dim I As Integer
I = InStr(strItem, vbNullChar)
If I > 0 Then
tsTrimNull = Left(strItem, I - 1)
Else
tsTrimNull = strItem
End If
tsTrimNull_End:
On Error GoTo 0
Exit Function
tsTrimNull_Err:
Beep
MsgBox Err.Description, , "Error: " & Err.Number _
& " in function basBrowseFiles.tsTrimNull"
Resume tsTrimNull_End
End Function
Public Sub tsGetFileFromUserTest()
On Error GoTo tsGetFileFromUserTest_Err
Dim strFilter As String
Dim lngFlags As Long
Dim varFileName As Variant
' strFilter = "Access (*.mdb)" & vbNullChar & "*.mdb" _
' & vbNullChar & "All Files (*.*)" & vbNullChar & "*.*"
strFilter = "All Files (*.*)" & vbNullChar & "*.*"
lngFlags = tscFNPathMustExist Or tscFNFileMustExist Or tscFNHideReadOnly
varFileName = tsGetFileFromUser( _
fOpenFile:=True, _
strFilter:=strFilter, _
rlngflags:=lngFlags, _
strDialogTitle:="GetFileFromUser Test (Please choose a file)")
If IsNull(varFileName) Then
Debug.Print "User pressed 'Cancel'."
Else
Debug.Print varFileName
'Forms![Form1]![Text1] = varFileName
End If
If varFileName <> "" Then MsgBox "You selected the '" & varFileName & "' file.", vbInformation
tsGetFileFromUserTest_End:
On Error GoTo 0
Exit Sub
tsGetFileFromUserTest_Err:
Beep
MsgBox Err.Description, , "Error: " & Err.Number _
& " in sub basBrowseFiles.tsGetFileFromUserTest"
Resume tsGetFileFromUserTest_End
End Sub
VOILA! Easy as that. ;o)
Sorry for being newbie on this . But Im having an error when it comes to parsing part of my codes.Please help me. The version of my itextsharp is version 4.1.6
Unable to cast object of type 'iTextSharp.text.html.simpleparser.IncTable' to type 'iTextSharp.text.IElement'.
this is my vb codes:
Dim strHTMLContent As StringBuilder = New StringBuilder()
Dim strFinalHTML As String
Dim output = New MemoryStream()
Dim document = New iTextSharp.text.Document(PageSize.A4, 50, 50, 25, 25)
Dim dsRcpComp As New DataSet
Dim dtDetails As New DataTable
Dim RecipeName As String = ""
Dim RecipeIngredients As String = ""
dsRcpComp = GetRcpCompStandard(conStr, CodeListe, CodeTrans)
dtDetails = dsRcpComp.Tables(0)
RecipeName = Replace(dtDetails.Rows(0).Item("Name"), vbCr, "<br>")
RecipeIngredients = Replace(dtDetails.Rows(0).Item("Ingredients"), vbCr, "<br>")
strHTMLContent.Append("<table width=700 align='center' Border='0' cellspacing='50' fontsize='1' class='pdfFont'")
strHTMLContent.Append("<tr>")
'*** GERMAN COLUMN ***
strHTMLContent.Append("<td valign=top><table width=210 align='left'>")
strHTMLContent.Append("<tr><td><font size='2' >" & RecipeName & "</font></td></tr>")
strHTMLContent.Append("<tr><td></td></tr>")
strHTMLContent.Append("<tr><td>")
strHTMLContent.Append(RecipeIngredients & "<br><br>")
strHTMLContent.Append("</td></tr>")
strHTMLContent.Append("</tr></table>")
Dim styles As StyleSheet = New StyleSheet
styles.LoadStyle("pdfFont", "face", "courier")
strFinalHTML = Replace(strHTMLContent.ToString, "& ", "& ")
document.SetPageSize(iTextSharp.text.PageSize.A4.Rotate())
Dim parsedHtmlElements = HTMLWorker.ParseToList(New StringReader(strFinalHTML), styles)
Dim writer = PdfWriter.GetInstance(document, output)
document.Open()
For Each htmlElement In parsedHtmlElements
document.Add(TryCast(htmlElement, IElement))
Next
document.Close()
Return output
I'm getting the error in this line:
Dim parsedHtmlElements = HTMLWorker.ParseToList(New StringReader(strFinalHTML), styles)