Current Code Working fine Saving Images from word through below code
If singleline.Range.InlineShapes.Count > 0 Then
Dim shp4 As InlineShape
Dim mchart4 As Shape
Set shp4 = singleline.Range.InlineShapes(1)
shp4.Select
Selection.Copy
Set mchart4 = ActiveDocument.Shapes.AddChart(xl3DAreaStacked, , , shp4.Width, shp4.Height)
mchart4.Chart.Paste
mchart4.Chart.Export ("c:\here\" + CStr(i) + ".png")
mchart4.Chart.Delete
b64strng = ConvertFileToBase64("c:\here\" + CStr(i) + ".png")
datainbtw = Replace(datainbtw, "<p>", " ")
datainbtw = Replace(datainbtw, "</p>", " ")
datainbtw = datainbtw + "<img src=\'data:image/png;base64," + b64strng + "\' style=\'Display:block\'>"
datainbtw = Replace(datainbtw, "/" & vbCr & " <", "<")
Kill "c:\here\" + CStr(i) + ".png"
End If
Here every Image saving before Excel Opens chart and Getting closed after Image Save.
we don't want excel to open chart, is there any way to save image without opening excel popup
thanks
Related
I am working on SAP Gui Scripting with VBA. I have 200line of information to enter into SAP from excel. However, SAP list hits 23lines max, which you have to than scroll down to enter more lines into the list. Here is my code
i = 0
With session
.findById("wnd[0]").maximize
.findById("wnd[0]/tbar[0]/okcd").Text = "MIGO"
.findById("wnd[0]").sendVKey 0
.findById("wnd[0]/usr/ssubSUB_MAIN_CARRIER:SAPLMIGO:0006/subSUB_HEADER:SAPLMIGO:0101/subSUB_HEADER:SAPLMIGO:0100/tabsTS_GOHEAD/tabpOK_GOHEAD_GENERAL/ssubSUB_TS_GOHEAD_GENERAL:SAPLMIGO:0112/txtGOHEAD-BKTXT").Text = "PKG QTY REF 015835"
While Cells(7 + i, 1).Value <> ""
.findById("wnd[0]/usr/ssubSUB_MAIN_CARRIER:SAPLMIGO:0006/subSUB_ITEMLIST:SAPLMIGO:0200/tblSAPLMIGOTV_GOITEM/ctxtGOITEM-MAKTX[1," & i & "]").Text = Cells(7 + i, 2)
.findById("wnd[0]/usr/ssubSUB_MAIN_CARRIER:SAPLMIGO:0006/subSUB_ITEMLIST:SAPLMIGO:0200/tblSAPLMIGOTV_GOITEM/txtGOITEM-ERFMG[4," & i & "]").Text = Cells(7 + i, 4)
.findById("wnd[0]/usr/ssubSUB_MAIN_CARRIER:SAPLMIGO:0006/subSUB_ITEMLIST:SAPLMIGO:0200/tblSAPLMIGOTV_GOITEM/ctxtGOITEM-ERFME[5," & i & "]").Text = "PC"
.findById("wnd[0]/usr/ssubSUB_MAIN_CARRIER:SAPLMIGO:0006/subSUB_ITEMLIST:SAPLMIGO:0200/tblSAPLMIGOTV_GOITEM/ctxtGOITEM-LGOBE[6," & i & "]").Text = "BORD"
.findById("wnd[0]/usr/ssubSUB_MAIN_CARRIER:SAPLMIGO:0006/subSUB_ITEMLIST:SAPLMIGO:0200/tblSAPLMIGOTV_GOITEM/ctxtGOITEM-NAME1[12," & i & "]").Text = "2S98"
.findById("wnd[0]/usr/ssubSUB_MAIN_CARRIER:SAPLMIGO:0006/subSUB_ITEMLIST:SAPLMIGO:0200/tblSAPLMIGOTV_GOITEM/ctxtGOITEM-UMLGOBE[27," & i & "]").Text = "DMDV"
.findById("wnd[0]/usr/ssubSUB_MAIN_CARRIER:SAPLMIGO:0006/subSUB_ITEMLIST:SAPLMIGO:0200/tblSAPLMIGOTV_GOITEM/ctxtGOITEM-UMBAR[32," & i & "]").Text = "CATNEW"
.findById("wnd[0]/usr/ssubSUB_MAIN_CARRIER:SAPLMIGO:0006/subSUB_ITEMLIST:SAPLMIGO:0200/tblSAPLMIGOTV_GOITEM/ctxtGOITEM-UMBAR[32," & i & "]").SetFocus
.findById("wnd[0]/usr/ssubSUB_MAIN_CARRIER:SAPLMIGO:0006/subSUB_ITEMLIST:SAPLMIGO:0200/tblSAPLMIGOTV_GOITEM/ctxtGOITEM-UMBAR[32," & i & "]").caretPosition = 6
.findById("wnd[0]/usr/ssubSUB_MAIN_CARRIER:SAPLMIGO:0006/subSUB_ITEMLIST:SAPLMIGO:0200/tblSAPLMIGOTV_GOITEM").verticalScrollbar.Position = i
.findById("wnd[0]").sendVKey 0
i = i + 1
Wend
End With
I tried using
.findById("wnd[0]/usr/ssubSUB_MAIN_CARRIER:SAPLMIGO:0006/subSUB_ITEMLIST:SAPLMIGO:0200/tblSAPLMIGOTV_GOITEM").verticalScrollbar.Position = i
to scroll down the list but apparently VBA still stops at line 23. Is there another for all my 200lines to be added inside the list?
Here is a picture of how it looks like when my code ran, There are lines below 23 but vba still stops and doesnt continue. Any help?
Hi Have you tried manually entering data above 23 lines? Are these lines are disabled after 23rd row?
Below should do the job. I usually scroll and set my last row on top. BTW Which t-code are you using?
.findById("wnd[0]/usr/ssubSUB_MAIN_CARRIER:SAPLMIGO:0006/subSUB_ITEMLIST:SAPLMIGO:0200/tblSAPLMIGOTV_GOITEM").verticalScrollbar.Position = i
I routine searches for images and moves the files that are images.
The code works inconsistently.
Sometime, it gives error 75.
Sometimes it works just fine.
The problem is in the following line:
Name MoveFrom as MoveTo
Where MoveFrom is the source file name.
MoveTo is the target file name (in a different folder--subfolder \Exceptions\Images, relateve to the MoveFrom Folder).
Any ideas of how to move this file consistently without this blasted error...
To assist, I have marked the problem line with comments as follows in the code:
'--------------------------------------------------------------------
' ------------PROBLEM HERE
'--------------------------------------------------------------------
...THE CODE:
Public Sub MoveImages()
' ShellCommand = ActiveWorkbook_UNC_Path + "\cpdf.exe -list-fonts " + Chr(34) + ActiveWorkbook_UNC_Path + "\" + t + Chr(34) + " > " + Chr(34) + ActiveWorkbook_UNC_Path + "\" + "fontlist.txt" + Chr(34)
' ShellCommand = ActiveWorkbook_UNC_Path + "\cpdf.exe -missing-fonts " + Chr(34) + ActiveWorkbook_UNC_Path + "\" + t + Chr(34) + " > " + Chr(34) + ActiveWorkbook_UNC_Path + "\" + "fontlist.txt" + Chr(34)
'On Error GoTo 0
Dim FileList As Variant
FileList = GetFileList(ActiveWorkbook_UNC_Path + "\*.pdf")
RunMoveImagesCount = RunMoveImagesCount + 1
Dim t As String
Dim Ndx As Integer
Dim ShellCommand
Dim ReturnCode As Long
Dim WshShell As Variant
Set WshShell = CreateObject("WScript.Shell")
Dim MoveFrom As String
Dim MoveTo As String
If IsArray(FileList) Then
For Ndx = LBound(FileList) To UBound(FileList)
t = FileList(Ndx)
ShellCommand = "cpdf.exe -list-fonts " + Chr(34) + t + Chr(34) + " > fontlist.txt"
ShellCommand = "cmd.exe /c " + ShellCommand
ReturnCode = WshShell.Run(ShellCommand, 0, True)
If FileLen(ActiveWorkbook_UNC_Path + "\" + "fontlist.txt") > 0 Then
If RunMoveImagesCount > 1 Then
'not an image
ActiveCell.Value = "Warning! Detected PDF, not converted to CSV "
ActiveCell.Font.ColorIndex = 5
ActiveCell.Offset(1, 0).Select
End If
Else
'possibly not an image
ShellCommand = "cpdf.exe -missing-fonts " + Chr(34) + t + Chr(34) + " > fontlist.txt"
ShellCommand = "cmd.exe /c " + ShellCommand
ReturnCode = WshShell.Run(ShellCommand, 0, True)
If FileLen(ActiveWorkbook_UNC_Path + "\" + "fontlist.txt") > 0 Then
If RunMoveImagesCount > 1 Then
'not an image
ActiveCell.Value = "Warning! Detected PDF(s), not converted to CSV "
ActiveCell.Font.ColorIndex = 5
ActiveCell.Offset(1, 0).Select
End If
Else
'an image.... move it....
MoveFrom = ActiveWorkbook_UNC_Path + "\" + t
MoveTo = ActiveWorkbook_UNC_Path + "\Exceptions\Images\" + t
MoveFrom = ReplaceUNC(MoveFrom)
MoveTo = ReplaceUNC(MoveTo)
If FileThere(MoveTo) Then
'Kill MoveFrom
'shouldn't happen, but if it does, lets leave it there and investigate....
Else
'--------------------------------------------------------------------
' ------------PROBLEM HERE
'--------------------------------------------------------------------
Name MoveFrom As MoveTo
ImageCount = ImageCount + 1
End If
MoveFrom = ReplaceLastOccurance(MoveFrom, ".pdf", ".csv")
If FileThere(MoveFrom) Then
MoveTo = ReplaceLastOccurance(MoveTo, ".pdf", ".csv")
If FileThere(MoveTo) Then
'Kill MoveFrom
'shouldn't happen, but if it does, lets leave it there and investigate....
Else
Name MoveFrom As MoveTo
End If
End If
End If
End If
Next
Else
'no files; you're done.
End If
End Sub
Sub imacros()
Dim iim1, iret
Set iim1 = CreateObject("imacros")
iret = iim1.iimInit("", True)
Dim macro
macro = "CODE:"
macro = macro + "'Uses a Windows script to submit several datasets to a website, e. g. for filling an online database" + vbNewLine
macro = macro + "' Specify input file (if !COL variables are used, IIM automatically assume a CSV format of the input file" + vbNewLine
macro = macro + "'CSV = Comma Separated Values in each line of the filE" + vbNewLine
macro = macro + "TAB T=1" + vbNewLine
macro = macro + "SET !DATASOURCE C:\Users\Desktop\test\test.csv" + vbNewLine
macro = macro + "'Start at line 2 to skip the header in the file" + vbNewLine
macro = macro + "'Increase the current position in the file with each loop " + vbNewLine
macro = macro + "' Fill web form " + vbNewLine
macro = macro + "TAB T=1" + vbNewLine
macro = macro + "TAB CLOSEALLOTHERS" + vbNewLine
macro = macro + "SET !PLAYBACKDELAY 0.2" + vbNewLine
macro = macro + "URL GOTO=secured URL here" + vbNewLine
macro = macro + "TAG POS=1 TYPE=INPUT:TEXT ATTR=NAME:name CONTENT={{!COL1}}" + vbNewLine
macro = macro + "TAG POS=1 TYPE=INPUT:SUBMIT ATTR=TYPE:submit" + vbNewLine
macro = macro + "TAG POS=1 TYPE=TABLE ATTR=CLASS:standardTable EXTRACT=TXT" + vbNewLine
macro = macro + "SAVEAS TYPE=EXTRACT FOLDER=""C:\Users\Desktop\test"" FILE=""test_image.csv""" + vbNewLine
macro = macro + "" + vbNewLine
iret = iim1.immPlay(macro)
End Sub
Above is the code that im using.
Could someone please let me know if there is something wrong with that and the reason for error?
* Converted the code from imacros using iMacros Scripting Code Creator to VBS string
This line might have wrong quotation marks:
macro = macro + "URL GOTO="secured URL here" + vbNewLine
You can see it here, as the next line is marked as a string:
macro = macro + "URL GOTO="secured URL here" + vbNewLine
macro = macro + "TAG POS=1 TYPE=INPUT:TEXT ATTR=NAME:name CONTENT={{!COL1}}" + vbNewLine
Remove the quotation mark after the equal sign and try again.
Hi the code below merges pdfs using adobe acrobat. It works but I am looking to add page numbers to the document so that if I merge 2 documents that are 4 pages each the page numbers go from 1 to 8. How can that be done?
Here is the code:
'http://www.vbaexpress.com/forum/showthread.php?47310-Need-code-to-merge-PDF-files-in-a-folder-using-adobe-acrobat-X
Sub MergePDFs()
' ZVI:2013-08-27 http://www.vbaexpress.com/forum/showthread.php?47310-Need-code-to-merge-PDF-files-in-a-folder-using-adobe-acrobat-X
' Reference required: "VBE - Tools - References - Acrobat"
' --> Settings, change to suit
Const MyPath = "C:\mypath" '"C:\Temp" ' Path where PDF files are stored
Const MyFiles = "file1.pdf,file2.pdf" ' List of PDFs to ne merged
Const DestFile = "MergedFile.pdf" ' The name of the merged file
' <-- End of settings
Dim a As Variant, i As Long, n As Long, ni As Long, p As String
Dim AcroApp As New Acrobat.AcroApp, PartDocs() As Acrobat.CAcroPDDoc
If Right(MyPath, 1) = "\" Then p = MyPath Else p = MyPath & "\"
a = Split(MyFiles, ",")
ReDim PartDocs(0 To UBound(a))
On Error GoTo exit_
If Len(Dir(p & DestFile)) Then Kill p & DestFile
For i = 0 To UBound(a)
' Check PDF file presence
If Dir(p & Trim(a(i))) = "" Then
MsgBox "File not found" & vbLf & p & a(i), vbExclamation, "Canceled"
Exit For
End If
' Open PDF document
Set PartDocs(i) = CreateObject("AcroExch.PDDoc")
PartDocs(i).Open p & Trim(a(i))
If i Then
' Merge PDF to PartDocs(0) document
ni = PartDocs(i).GetNumPages()
If Not PartDocs(0).InsertPages(n - 1, PartDocs(i), 0, ni, True) Then
MsgBox "Cannot insert pages of" & vbLf & p & a(i), vbExclamation, "Canceled"
End If
' Calc the number of pages in the merged document
n = n + ni
' Release the memory
PartDocs(i).Close
Set PartDocs(i) = Nothing
Else
' Calc the number of pages in PartDocs(0) document
n = PartDocs(0).GetNumPages()
End If
Next
If i > UBound(a) Then
' Save the merged document to DestFile
If Not PartDocs(0).Save(PDSaveFull, p & DestFile) Then
MsgBox "Cannot save the resulting document" & vbLf & p & DestFile, vbExclamation, "Canceled"
End If
End If
exit_:
' Inform about error/success
If Err Then
MsgBox Err.Description, vbCritical, "Error #" & Err.Number
ElseIf i > UBound(a) Then
MsgBox "The resulting file is created:" & vbLf & p & DestFile, vbInformation, "Done"
End If
' Release the memory
If Not PartDocs(0) Is Nothing Then PartDocs(0).Close
Set PartDocs(0) = Nothing
' Quit Acrobat application
AcroApp.Exit
Set AcroApp = Nothing
End Sub
attached a stand-alone VBS/VBA script, which add the page number as footer to your pdf. You may took out the parts you need and write into your script just before you save the pdf or execute it afterwards.
Full Script:
File = "D:\Test.pdf"
Set App = CreateObject("Acroexch.app") '//start acrobat
app.show '//show Acrobat or comment out for hidden mode
Set AVDoc = CreateObject("AcroExch.AVDoc")
Set AForm = CreateObject("AFormAut.App") '//get AFormAPI to execute js later
If AVDoc.Open(File,"") Then
'//write JS-Code on a variable
Ex = " // set Date, filename and PageNo as footer "&vbLF _
& " var Box2Width = 50 "&vbLF _
& " for (var p = 0; p < this.numPages; p++) "&vbLF _
& " { "&vbLF _
& " var aRect = this.getPageBox(""Crop"",p); "&vbLF _
& " var TotWidth = aRect[2] - aRect[0] "&vbLF _
& " { var bStart=(TotWidth/2)-(Box2Width/2) "&vbLF _
& " var bEnd=((TotWidth/2)+(Box2Width/2)) "&vbLF _
& " var fp = this.addField(String(""xftPage""+p+1), ""text"", p, [bStart,30,bEnd,15]); "&vbLF _
& " fp.value = ""Page: "" + String(p+1)+ ""/"" + this.numPages; "&vbLF _
& " fp.textSize=6; fp.readonly = true; "&vbLF _
& " fp.alignment=""center""; "&vbLF _
& " } "&vbLF _
& " } "
'//Execute JS-Code
AForm.Fields.ExecuteThisJavaScript Ex
msgBox("Done")
end if
Set AVDoc = Nothing
Set APP = Nothing
The parts you really need if you only want to take over in your script:
Set AForm = CreateObject("AFormAut.App")
Ex = " // set Date, filename and PageNo as footer "&vbLF _
& " .....
& " .....
& " } "
'//Execute JS-Code
AForm.Fields.ExecuteThisJavaScript Ex
This also demonstrates how you can use/execute AcroJs via VBS/VBA without translating to JSO (Java Script Object).
Good luck, Reinhard
I repurposed the code on MicrosoftPowerpointConverter - MoinMoin to work without the Microsoft Scripting Runtime.
I was able to generate a new file and export text to it, (I know that's the easy part), where I am getting stuck is in two places:
Formatting bullets:
Original code
' Check for bullets
If aShape.TextFrame.TextRange.ParagraphFormat.Bullet = msoTrue Then
outText = Replace(outText, Chr(10), " * ")
End If
My code
' Check for bullets
If oShape.TextFrame.TextRange.ParagraphFormat.Bullet.Type <> ppBulletNone Then
outText = Replace(outText, Chr(10), " * ")
End If
This doesn't work at all, and it totally ignores bullet formatting, but still outputs the content without the *
Exporting images:
Original Code
' Is it a picture or embedded object
If aShape.Type = msoPicture Or aShape.Type = msoEmbeddedOLEObject Or aShape.Type = msoLinkedPicture Or aShape.Type = msoGroup Then
aShape.Export outPath + "\image" + Trim(Str(i)) + Trim(Str(j)) + ".png", ppShapeFormatPNG
oFileStream.WriteLine (Chr(13) + "attachment:image" + Trim(Str(i)) + Trim(Str(j)) + ".png" + Chr(13))
End If
My code
' Is it a picture or embedded object
If oShape.Type = msoPicture Or oShape.Type = msoEmbeddedOLEObject Or oShape.Type = msoLinkedPicture Or oShape.Type = msoGroup Then
Dim imagepath
imagepath = oPres.Path & "/images/slide" + Trim(Str(i)) + Trim(Str(j)) + ".png"
oShape.Export imagepath, ppShapeFormatPNG
Print #iFile, (Chr(13) + "<img src=" + Chr(34) + "/images/slide" + Trim(Str(i)) + Trim(Str(j)) + ".png" + Chr(34) + ">" + Chr(13))
End If
This code throws up the following error in windows, and is totally ignored in Mac
Adding my complete code below:
Sub ExportToWiki()
' Iterators
Dim i As Integer
Dim j As Integer
' Pres, Slide, Shape
Dim oPres As Presentation
Dim oSlides As Slides
Dim oSlide As Slide 'Slide Object
Dim oShp As Shape 'Shape Object
Dim iFile As Integer 'File handle for output
iFile = FreeFile 'Get a free file number
Dim PathSep As String
Dim FileNum As Integer
Set oPres = ActivePresentation
Set oSlides = oPres.Slides
FileNum = FreeFile
'Open output file
' NOTE: errors here if file hasn't been saved
Open oPres.Path & "/text.xml" For Output As FileNum
' File Handling
Dim outText As String
' Table exports
Dim row As Integer
Dim col As Integer
Dim cellText As String
' Select my ppt
' Write TOC
Print #iFile, ("[[TableOfContents]]")
' Loop through slides
For i = 1 To oPres.Slides.Count
Set oSlide = oPres.Slides(i)
' Loop through shapes
For j = 1 To oSlide.Shapes.Count
Set oShape = oSlide.Shapes(j)
' Is it a text frame?
If oShape.HasTextFrame Then
If oShape.TextFrame.HasText Then
outText = oShape.TextFrame.TextRange.Text
' Check for bullets
If oShape.TextFrame.TextRange.ParagraphFormat.Bullet.Type <> ppBulletNone Then
outText = Replace(outText, Chr(10), " * ")
End If
If j = 1 Then ' Assume first text is always the header
outText = "= " + outText + " ="
End If
Print #iFile, (outText + Chr(13) + "[[BR]]" + Chr(13))
End If
End If
' Is it a table?
If oShape.Type = msoTable Then
cellText = ""
For row = 1 To oShape.Table.Rows.Count
For col = 1 To oShape.Table.Columns.Count
If row = 1 Then
cellText = cellText + "||<class=" + Chr(34) + "tableheader" + Chr(34) + ">" + oShape.Table.Columns.Item(col).Cells(row).Shape.TextFrame.TextRange.Text
Else
cellText = cellText + "||" + oShape.Table.Columns.Item(col).Cells(row).Shape.TextFrame.TextRange.Text
End If
If col = oShape.Table.Columns.Count Then
cellText = cellText + "||" + Chr(13)
End If
Next col
Next row
Print #iFile, (Chr(13) + cellText + Chr(13))
End If
' Is it a picture or embedded object
If oShape.Type = msoPicture Or oShape.Type = msoEmbeddedOLEObject Or oShape.Type = msoLinkedPicture Or oShape.Type = msoGroup Then
Dim imagepath
imagepath = oPres.Path & "/images/slide" + Trim(Str(i)) + Trim(Str(j)) + ".png"
oShape.Export imagepath, ppShapeFormatPNG
Print #iFile, (Chr(13) + "<img src=" + Chr(34) + "/images/slide" + Trim(Str(i)) + Trim(Str(j)) + ".png" + Chr(34) + ">" + Chr(13))
End If
Next j
Next i
Close #iFile
End Sub
For the first part, I think you probably need to recursively check each paragraph within the TextRange as bullets can be set for the whole text range or specific paragraphs within it and if there is a mix, you'll get unexpected results. I also don't see why the replacement is being made for Char 10. I think you should be returning the text for the paragraphs where a bullet is found and prefixing it with your Wiki string. For example:
' Check for bullets
Dim p As Long
Dim para As String
With oShape.TextFrame.TextRange
For p = 1 To .Paragraphs.Count
If .Paragraphs(p).ParagraphFormat.Bullet.Type <> ppBulletNone Then
para = " * " & .Paragraphs(p).Text
Else
para = .Paragraphs(p).Text
End If
outText = outText & para
Next
End With
For the second point, I got the same error because the images sub folder didn't exist. Once I created it manually, the code ran on PC. For Mac, you'll need to use POSIX or AppleScript path syntax if I recall correctly, for example:
#If Mac Then
Public Const PathSeparator = ":"
#Else
Public Const PathSeparator = "\"
#End If
However, if you're using PowerPoint:mac 2016 then things are more complicated due to its sandboxed environment. Check this article for more info:
http://www.rondebruin.nl/mac/mac034.htm