I am designing a vba code that allows users to input a set of technical drawing numbers and create a packet from it. I have run into a problem when dealing with autocad files. Because our company has AutoCAD LT I am unable to utilize the api, thus I am using adobe's PDFMaker api to convert the files directly to pdf. Unfortunately the settings for pdfMaker are rather limited so I need to parse through the outputted pdf packet and print it in black and white (monochrome). I currently have a subroutine that opens the packet and prints the necessary pages, however, it only prints black and white if I specifically open up acrobat and select my "Monochrome" configuration in the advanced settings. Is there a way to send the command (I believe it's in javascript?) to set this color configuration and set the size option to fit? Here is my code.
Public xlBook As Workbook
Public xlSheet As Worksheet
Public LastRow As Integer
Public ItemNumber As String
Public Vin5 As String
Public Vin As String
Public FullPath As String
Sub PdfFormat()
Dim strMakeFile As String
Dim LastRow As Integer
Set xlBook = ActiveWorkbook
Set xlSheet = xlBook.Sheets(1)
ItemNumber = Range("E1")
Vin5 = Range("F1")
Vin = ItemNumber & "0" & Vin5
FullPath = "\\eastfile\Departments\Engineering\MACROS\New Packet Output\" & Vin & "\"
strMakeFile = FullPath & Vin & ".pdf"
LastRow = Range("A" & xlSheet.Rows.Count).End(-4162).Row
Dim AcroExchApp As New Acrobat.AcroApp
Dim AcroExchAVDoc As New Acrobat.AcroAVDoc
Dim AcroExchPDDoc As Acrobat.AcroPDDoc
Dim OpenError As Boolean
Dim PrintError As Boolean
OpenError = AcroExchAVDoc.Open(strMakeFile, "")
!!!!!CODE FOR PRINTER SETTINGS HERE!!!!!
PrintError = AcroExchAVDoc.PrintPagesSilentEx(0, 5, 3, 1, 1, 0, 0, 0, -5)
Debug.Print "Open Error: " & Not (OpenError)
Debug.Print "Print Error: " & Not (PrintError)
Debug.Print Vin
AcroExchApp.CloseAllDocs
End Sub
Thank you for your time
The print parameters in Acrobat you can find in the Acro-js helpfile for example here: Acro JS setting print options
With VBS/VBA there are 2 ways to use it. With the help of Acro-Form API you can execute js-code more or less direkt. Here I gave a simple example: Execute Acro js from VBA/VBS
The other way is to use the JS-Object, which lets you use transformed js-code via VBA/VBS Ole connection. That's documented in the Adobe Acrobat IAC Reference.
How that works you can see in the following example, where I use jso for setting some print parameters. Change the given print parameters to that what you need or search in the Acro JS helfile for some other example and execute it via above described way direct. Good luck, Reinhard
'// print dropped files with printParameter
set WshShell = CreateObject ("Wscript.Shell")
set fs = CreateObject("Scripting.FileSystemObject")
Set objArgs = WScript.Arguments
if objArgs.Count < 1 then
msgbox("Please drag a file on the script")
WScript.quit
end if
'contact Acrobat
Set gApp = CreateObject("AcroExch.App")
gApp.show 'comment or take out to work in hidden mode
'open via Avdoc and print
for i=0 to objArgs.Count - 1
FileIn = ObjArgs(i)
Set AVDoc = CreateObject("AcroExch.AVDoc")
If AVDoc.Open(FileIn, "") Then
Set PDDoc = AVDoc.GetPDDoc()
Set JSO = PDDoc.GetJSObject
jso.print false, 0, 0, true
set pp = jso.getPrintParams
pp.printerName = "hp deskjet 990c"
pp.firstPage = 0 '-> Zero based (firstPage = 0)
pp.lastPage = 5 '-> Zero based (pageCount - 1)
pp.interactive = pp.constants.interactionLevel.automatic '-> no print dialog
pp.pageHandling = pp.constants.handling.booklet
pp.booklet.duplexMode = pp.constants.bookletDuplexModes.BothSides
pp.booklet.binding = pp.constants.bookletBindings.LeftTall
jso.print(pp)
gApp.CloseAllDocs
end if
next
gApp.hide
gApp.exit
MsgBox "Done!"
Quit()
Sub Quit()
Set JSO = Nothing
Set PDDoc = Nothing
Set gApp = Nothing
Wscript.quit
End Sub
Related
So when I visit my page and I set the video mode using this:
$("#pushStreamButton").click(function () {
if (initialized) {
var channelSelected = $("#channelSelect").val();
var gameNameEntered = $("#gameName").val();
var channelNameEntered = $("#channelName").val();
if (gameNameEntered.length < 1) return;
$("#goLiveWindow").dialog("close");
serverHub.server.setVideoMode(channelSelected, gameNameEntered, "", channelNameEntered);
}
});
and this is in the backend
Public Sub setVideoMode(ByVal mode As String, ByVal details As String, ByVal socialMessage As String, ByVal channel As String)
Dim user As FrontPageUser = Connections.matchFirst(Connections.frontPageUsers, Context.ConnectionId)
If user Is Nothing Then Return
If mode = "youtube" Then
Try
My.Computer.FileSystem.DeleteFile(HttpContext.Current.Server.MapPath("/images/streamavatar.gif"))
Catch Ex As Exception
Console.Write(Ex)
End Try
End If
This functions as expected, it does it's job, however I have a button that reverts the channel back to the default youtube
$("#stopStreamButton").click(function () {
serverHub.server.setVideoMode("youtube", "", "", "");
});
After changing the channel using the first button, clicking the second button doesn't do anything, it doesn't even seem to attempt to execute the command, which is bizarre. However if I reload the page the button functions correctly and the channel is reverted.
This issue also isn't present when using SSE/longpolling/foreverframe, only when using websockets as the transport. I'm treading relatively unknown waters with websockets, and I've tried debugging the javascript and the backend code - the javascript doesn't seem to execute correctly, but it doesn't spout any errors, and it never reaches the backend.
If anybody knows why this happens and could explain where I'm going wrong, it'd be appreciated.
Additional: after digging further, it actually appears to stop all functions from the java side and after a while it seems to disconnect and force a refresh, not sure what is causing it, but I know it has to be related to websockets.
edit --
Upon debugging cause, it appears to be linked to another function which sends a push notification to subscribers, when I disable this function it works without hanging and blocking commands, but when this function is initialized it hangs, seemingly after the function has completed
Shared Function sendPushFox(username, pushDetails) As String
Dim avatar = Utils.getAvatarPath(username)
If avatar.Contains("/forum/download/file.php?avatar=") OrElse avatar.Contains("/images/solaire.png") Then
Try
My.Computer.Network.DownloadFile("https://foo.com" & avatar, HttpContext.Current.Server.MapPath("/images/streamavatar.gif"))
Catch ex As Exception
ChatProcessor.postNewMessage(Nothing, Nothing, ChatMessage.MessageType.Channel_Mod, "Problem downloading streamer avatar." & ex.ToString)
End Try
Else
Try
My.Computer.Network.DownloadFile(avatar, HttpContext.Current.Server.MapPath("/images/streamavatar.gif"))
Catch ex As Exception
ChatProcessor.postNewMessage(Nothing, Nothing, ChatMessage.MessageType.Channel_Mod, "Problem downloading streamer avatar." & ex.ToString)
End Try
End If
Dim query As String = "SELECT subscribeid FROM custom_user_data WHERE NOT subscribeid = ' ';"
Dim connection As New MySqlConnection(Utils.connectionString) : connection.Open()
Dim command As MySqlCommand = New MySqlCommand(query, connection)
Dim reader As MySqlDataReader = command.ExecuteReader()
Dim regList As New List(Of String)
Do While reader.Read
regList.Add(reader.GetString(0))
' IO.File.AppendAllText(Utils.serverPath & "errorlog.txt", reg1)
Loop
connection.Close()
Dim query2 As String = "SELECT p256dh FROM custom_user_data WHERE NOT p256dh = ' ';"
Dim connection2 As New MySqlConnection(Utils.connectionString) : connection2.Open()
Dim command2 As MySqlCommand = New MySqlCommand(query2, connection2)
Dim reader2 As MySqlDataReader = command2.ExecuteReader()
Dim regList2 As New List(Of String)
Do While reader2.Read
regList2.Add(reader2.GetString(0))
' IO.File.AppendAllText(Utils.serverPath & "errorlog.txt", reg1)
Loop
connection2.Close()
Dim query3 As String = "SELECT authsecret FROM custom_user_data WHERE NOT authsecret = ' ';"
Dim connection3 As New MySqlConnection(Utils.connectionString) : connection3.Open()
Dim command3 As MySqlCommand = New MySqlCommand(query3, connection3)
Dim reader3 As MySqlDataReader = command3.ExecuteReader()
Dim regList3 As New List(Of String)
Do While reader3.Read
regList3.Add(reader3.GetString(0))
' IO.File.AppendAllText(Utils.serverPath & "errorlog.txt", reg1)
Loop
connection3.Close()
Dim reg1 = regList.ToArray
Dim reg2 = regList2.ToArray
Dim reg3 = regList3.ToArray
Dim payload = "{ ""title"": ""foo bar"", ""body"": """ & username.name.ToString & " playing " & pushDetails.ToString & """, ""icon"" : ""https://foo.com/images/streamavatar.gif"" }"
For i As Integer = 0 To reg1.Length - 1
Dim webPushClient = New WebPushClient()
Dim subject = "https://foo.com"
Dim vapidKeys As VapidDetails = VapidHelper.GenerateVapidKeys()
Dim vapidDetails = New VapidDetails(subject, vapidKeys.PublicKey, vapidKeys.PrivateKey)
Try
Console.WriteLine("Public {0}", vapidKeys.PublicKey)
Console.WriteLine("Private {0}", vapidKeys.PrivateKey)
Dim subscription = New PushSubscription(reg1(i), reg2(i), reg3(i))
webPushClient.SetGCMAPIKey("key here")
webPushClient.SendNotification(subscription, payload, vapidDetails)
Catch Ex As Exception
Console.Write(Ex)
End Try
Next
Return Nothing
End Function
So, it's a clash with websockets, since it functions on longpolling and etc but I'm still not sure why, and it only affects the user who calls the function.
Strangely enough this appears to hang after the "next" which happens here
For i As Integer = 0 To reg1.Length - 1
webPushClient.SetGCMAPIKey("key here")
webPushClient.SendNotification(subscription, payload, vapidDetails)
Next
it functions completely fine, but once it reaches the end of the for, it just never continues, it does literally nothing after Next, no errors, nothing happens, set breaks and results are as expected, I'm just baffled as to why it doesn't continue, and only using websockets trasports, longpolling and etc is fine
I actually figured this out, it turns out that websockets don't like the non asynchronous communication made from the command
webPushClient.SendNotification(subscription, payload, vapidDetails)
Fortunately the webPush lib has an async and changing it to
webPushClient.SendNotificationAsync(subscription, payload, vapidDetails)
fixed everything.
I am currently working on a VBA code that retrieves the top file from this website (http://infopost.bwpmlp.com/Posting/default.aspx?Mode=Display&Id=27&tspid=100000). I am able to click on the button using Javascript in my code, and I am able to click on open after the download is kicked off. However, I am having trouble saving the file. Because the workbook is being pulled from a website there really isn't a way to set it to the active workbook that I can think of. Currently when I do ActiveWorkbook.SaveAs the code is saving the blank workbook that I am testing the code out of. The file I downloaded seems to not open until the entire code is done running even after I try putting in breaks. Anyone have any ideas? My code is below. Thanks!
Option Explicit
Dim ie As InternetExplorer
Dim h As LongPtr
Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
Sub Texas_Gas()
Application.DisplayAlerts = True
Dim ie As Object
Dim IeHandle As Long, FileDownloadHandle As Long, OpenButtonHandle As Long, IePopupBarHandle As Long
Dim AutoMode As Boolean, FileDownloadClassicPopup As Boolean, DownloadComplete As Boolean
Dim Timeout As Date
Dim strSPICE As String, strLink As String
Dim PopupGap As Integer, i As Integer
Set ie = CreateObject("InternetExplorer.Application")
DownloadComplete = False
FileDownloadClassicPopup = False
FileDownloadHandle = 0
IePopupBarHandle = 0
With ie
.Visible = True
.navigate "http://infopost.bwpmlp.com/Posting/default.aspx? Mode=Display&Id=27&tspid=100000"
Do While .Busy: DoEvents: Loop
Do While .readyState <> 4: DoEvents: Loop
End With
ie.document.parentWindow.execScript "javascript:WebForm_DoPostBackWithOptions(new WebForm_PostBackOptions(""dgITMatrix:0:lnkBtnDownload"", """", true, """", """", false, true))"
Dim o As IUIAutomation
Dim e As IUIAutomationElement
Dim iCnd As IUIAutomationCondition
Set o = New CUIAutomation
h = ie.Hwnd
h = FindWindowEx(h, 0, "Frame Notification Bar", vbNullString)
If h = 0 Then Exit Sub
Set e = o.ElementFromHandle(ByVal h)
Set iCnd = o.CreatePropertyCondition(UIA_NamePropertyId, "Open")
Dim Button As IUIAutomationElement
Set Button = e.FindFirst(TreeScope_Subtree, iCnd)
Dim InvokePattern As IUIAutomationInvokePattern
Set InvokePattern = Button.GetCurrentPattern(UIA_InvokePatternId)
InvokePattern.Invoke
ActiveWorkbook.SaveAs "I:\Cap_Rel\raw_scrapes\Texas_Gas_Transmission\parsed\Texas_Gas_Transmission_CapRel" & Format(Date - 1, "yyyymmdd") & "MACRO", FileFormat:=xlCSV
End Sub
I have a piece of code that loads a website and clicks a link that opens a popup. The contents of this popup is what I need to be imported into Excel (VBA) so I can manipulate that data. The issue is that this link's web address always changes, but the link is always in the same place.
The following code defines the currently active IE instance's URL as "IEURL". I would like to use the code to import the table but I get an error "Run-time error '1004': The address of this site is not valid. Check the address and try again".
Sub Button1_Click()
Dim objIE As SHDocVw.InternetExplorer
Dim IEURL As String
LastRow = Range("A" & Rows.Count).End(xlUp).Offset(1).Row
Set objIE = New InternetExplorerMedium
'apiShowWindow objIE.hwnd, SW_MAXIMIZE
objIE.navigate "http://www.youtube.com"
objIE.Visible = True
Do While objIE.READYSTATE <> 4 And objIE.Busy
DoEvents
Loop
'Call Sleep
Application.Wait (Now + TimeValue("0:00:5"))
IEURL = objIE.LocationURL
ThisWorkbook.Sheets("Sheet1").Activate
Rows("6:250").Delete
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;IEURL", _
Destination:=Range("a6"))
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = False
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingAll
.WebPreFormattedTextToColumns = False
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
End Sub
Can anyone help me out here?
P.S. I just used YouTube as an example here, as it demonstrates the same problem as the actual website I am trying to import
The objIE.LocationURL property returns a string which you are storing in a string variable. When you later try to use that variable you should append it to a string rather than just putting the name of the variable inside the string. So change
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;IEURL", _
to
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;" & IEURL, _
btw, in Excel 2013, your sample code fails at IEURL = objIE.LocationURL
I am running a simple program in which you enter a user number into a text box, click the submit button, and then the program is supposed to go to a database look up the number you entered and display that rows information. Simple enough.
The problem is I keep getting the error that Xml.XmlDataDocument() is obsolete. I've googled this issue, which led me to here, but the replacements suggested do not work within my program.
Also, I have not studied VB and this is for an XML class.
I've double checked my code for any errors and do not see anything. But, I could be missing the forest for the trees. Would like to have another set of eyes take a look at my code to see if I've missed something, or to offer up a replacement for the Xml.XmlDataDocument() line.
Thank you in advance for any help you can offer.
Here is the code I am using:
Javascript for the onClick event
<script language="javascript" type="text/javascript">
function btnSearch_onclick() {
var docSubmit = new ActiveXObject("MSXML2.DOMDocument");
docSubmit.loadXML("<?xml version='1.0'?><request><customerID>" + txtCustID.value + "</customerID></request>")
var objSocket = new ActiveXObject("MSXML2.XMLHTTP");
objSocket.open("POST", "Lookup.aspx", false)
objSocket.send(docSubmit)
alert(objSocket.responseXML.xml)
lblFirstName.innerHTML = objSocket.responseXML.selectSingleNode("//FirstName").firstChild.nodeValue
lblLastName.innerHTML = objSocket.responseXML.selectSingleNode("//LastName").firstChild.nodeValue
lblAddress.innerHTML = objSocket.responseXML.selectSingleNode("//Address").firstChild.nodeValue
lblCity.innerHTML = objSocket.responseXML.selectSingleNode("//City").firstChild.nodeValue
lblState.innerHTML = objSocket.responseXML.selectSingleNode("//State").firstChild.nodeValue
lblZip.innerHTML = objSocket.responseXML.selectSingleNode("//Zip").firstChild.nodeValue
}
</script>
And here is the VB code:
Protected Sub Page_Load(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.Load
Dim docReceived As New System.Xml.XmlDataDocument()
docReceived.Load(Request.InputStream)
Dim CustomerID = docReceived.SelectSingleNode("//customerID").FirstChild.Value
Dim myConnection As New System.Data.OleDb.OleDbConnection
Dim myConnectionString As String
myConnectionString = "Provider = Microsoft.Jet.OLEDB.4.0;Data Source = " & _
Server.MapPath("customer.mbd")
myConnection.ConnectionString = myConnectionString
Dim strSQL As String
strSQL = "Select * From CustomerInfo where CustomerID = " & CustomerID
Dim myAdapter As New System.Data.OleDb.OleDbDataAdapter(strSQL, myConnection)
Dim myDataSet As New System.Data.DataSet("CustomerInfo")
Dim intRecords As Integer
intRecords = myAdapter.Fill(myDataSet, "Customer")
Response.ContentType = "text/xml"
If intRecords > 0 Then
myDataSet.WriteXml(Response.OutputStream)
Else
Response.Write("<?xml version='1.0'?><customer><FirstName>Not Found</FirstName><LastName>***</LastName><Address>***</Address><City>***</City><State>***</State><Zip>***</Zip><Phone>***</Phone><Email>***</Email></customer>")
End If
myDataSet.WriteXml(Response.OutputStream)
myConnection.Close()
myAdapter.Dispose()
myConnection.Dispose()
End Sub
XmlDataSet is obsolete. As you can see on the msdn it may even be removed in the next version of the .NET Framework ([ObsoleteAttribute("XmlDataDocument class will be removed in a future release.")]
). In your case I don't think you need it at all. The easies fix seems to be to use just XmlDocument. I believe you won't have to change anything else in your code but this line
Dim docReceived As New System.Xml.XmlDataDocument()
to:
Dim docReceived As New System.Xml.XmlDocument()
I just got the compare word in command line solution.
And try to compare two word file by TortoiseSVN diff scripts (diff-doc.js), but I found it shows to many differences about font or paragraph settings.
Is there any code sample about how to modify the diff-doc.js to ignore font change and ignore paragraph format change? I just want to focus on the text content at first time.
Im not 100% sure what you are asking, but you can do something like this in vbscript:
strPath1 = [the location of the first file]
strPath2 = [the location of the second file]
strLog = [the location of a log file]
set ofs = CreateObject("Scripting.FileSystemObject")
'create a log file
If Not oFs.FileExists(strLog) Then
set logFile = oFs.CreateTextFile(strLog, true)
else
set logFile = oFs.openTextFile (strLog, 8, True)
End if
set file1 = ofs.openTextFile (strPath1)
strFile1Buffer = file1.readAll
file1.close
set file2 = ofs.openTextFile (strPath2)
do while not file2.atEndOfStream
strLine = file2.readLine
If InStr(strFile1Buffer, strLine) = 0 Then
strLogEntry = strLogEntry & strLine & vbCrLf
End If
Loop
file2.Close
strLogEntry = "Lines that are in file1 but not in file2:" & vbCrLf & strLogEntry
logFile.WriteLine strLogEntry
objFile3.Close
Check out this: http://blogs.technet.com/b/heyscriptingguy/archive/2007/05/24/how-can-i-compare-the-contents-of-two-text-files.aspx