VBA Macros in CorelDraw. Export current selection - vba

Everyone! 
I'm working on macros which should select cdrBitmapShape and save it as a separate file.
I've already found out how to search and select such an object, but I've run into a problem of saving it.
I don't get how should I save the chosen image, it is quite unclear from the docs.
As I understand from here  I should somehow assign to the Document variable the current selection Item and export it.
Here is the test file
How can I do that?
Sub Findall_bit_map()
' Recorded 03.02.2020
'frmFileConverter.Start
'Dim d As Document
Dim retval As Long
Dim opt As New StructExportOptions
opt.AntiAliasingType = cdrNormalAntiAliasing
opt.ImageType = cdrRGBColorImage
opt.ResolutionX = 600
opt.ResolutionY = 600
Dim pal As New StructPaletteOptions
pal.PaletteType = cdrPaletteOptimized
pal.NumColors = 16
pal.DitherType = cdrDitherNone
Dim Filter As ExportFilter
Set OrigSelection = ActivePage.ActiveLayer.Shapes.All
For Each shpCheck In OrigSelection
re = shpCheck.Type
If shpCheck.Type = cdrBitmapShape Then
retval = MsgBox("BITMAP", vbOKCancel, "Easy Message")
shpCheck.AddToSelection
Set Filter = Document.ExportBitmap("D:\some.jpg", cdrJPEG)
If Filter.ShowDialog() Then
Filter.Finish
Else
MsgBox "Export canceled"
End If
End If
Next shpCheck
retval = MsgBox("Click OK if you agree.", vbOKCancel, "Easy Message")
'ActivePage.Shapes.FindShapes(Query:="#type='BitmapShape'")
If retval = vbOK Then
MsgBox "You clicked OK.", vbOK, "Affirmative"
End If
End Sub

I don't know were was the bug, but here is the working version.
Sub Findall_bit_map_snip()
Dim retval As Long
Dim doc As Document
Dim pal As New StructPaletteOptions
pal.PaletteType = cdrPaletteOptimized
pal.ColorSensitive = True
pal.NumColors = 300000000
pal.DitherType = cdrDitherNone
Dim Filter As ExportFilter
Set OrigSelection = ActivePage.ActiveLayer.Shapes.All
For Each shpCheck In OrigSelection
Set doc = ActiveDocument
doc.ClearSelection
re = shpCheck.Type
If shpCheck.Type = cdrBitmapShape Then
retval = MsgBox("BITMAP", vbOKCancel, "Easy Message")
shpCheck.AddToSelection
Set Filter = doc.ExportBitmap("D:\some.jpg", cdrJPEG, cdrSelection, , , , 600, 600, cdrNoAntiAliasing, , False, , , , pal)
Filter.Finish
End If
Next shpCheck
End Sub

Related

LibreOffice Writer API - Cursors and text selection / replacement from VB6

I have been attempting to replace Office OLE in a vb6 application with LibreOffice.
I have had some success, however, I am falling short trying to search for text, then create a cursor based on the text that was found, then insert an image at that cursors point in the document.
I have been able to piece together working code that will allow me to search for text, replace text and insert an image, however, I cannot seem to figure out how to create a cursor that will allow me to insert an image at the pace where the text is that I have found . In the provided example, the [PICTUREPLACEHOLDER] text in the document.
Has anyone ever done this before and do they have any suggestions how I can create a cursor that will allow me to specify where the image will be inserted.
I have included the code for the VB6 test app so you can see the source code to see how its currently working.
Any suggestions would be very much appreciated.
Please Note - this is experimental code - very rough and ready - not final code by a long shot - just trying to figure out how this works with LibreOffice Writer.
To run this, you will need to create an empty vb6 app with a button.
You also need LibreOffice installed.
Many thanks
Rod.
Sub firstOOoProc()
Dim oSM 'Root object for accessing OpenOffice from VB
Dim oDesk, oDoc As Object 'First objects from the API
Dim arg() 'Ignore it for the moment !
'Instanciate OOo : this line is mandatory with VB for OOo API
Set oSM = CreateObject("com.sun.star.ServiceManager")
'Create the first and most important service
Set oDesk = oSM.createInstance("com.sun.star.frame.Desktop")
Dim oProvider As Object
Set oProvider = oSM.createInstance("com.sun.star.graphic.GraphicProvider")
'Open an existing doc (pay attention to the syntax for first argument)
Set oDoc = oDesk.loadComponentFromURL("file:///c:/dev/ooo/testfile.doc", "_blank", 0, arg())
' now - replace some text in the document
Dim Txt
Txt = oDoc.GetText
Dim TextCursor
TextCursor = Txt.CreateTextCursor
' attempt to replace some text
Dim SearchDescriptor
Dim Replace
Replace = oDoc.createReplaceDescriptor
Replace.SearchString = "[TESTDATA1]"
Replace.ReplaceString = "THIS IS A TEST"
oDoc.replaceAll Replace
Dim searchCrtiteria
SearchDescriptor = oDoc.createReplaceDescriptor
' Now - attempt try to replace some text with an image
SearchDescriptor.setSearchString ("[PICTUREPLACEHOLDER]")
SearchDescriptor.SearchRegularExpression = False
Dim Found
Found = oDoc.findFirst(SearchDescriptor)
' create cursor to know where to insert the image
Dim oCurs As Object
Set thing = oDoc.GetCurrentController
Set oCurs = thing.GetViewCursor
' make hte call to insert an image from a file into the document
InsertImage oDoc, oCurs, "file:///c:/dev/ooo/imagefilename.jpg", oProvider
'Save the doc
Call oDoc.storeToURL("file:///c:/dev/ooo/test2.sxw", arg())
'Close the doc
oDoc.Close (True)
Set oDoc = Nothing
oDesk.Terminate
Set oDesk = Nothing
Set oSM = Nothing
End Sub
Function createStruct(strTypeName)
Set classSize = objCoreReflection.forName(strTypeName)
Dim aStruct
classSize.CreateObject aStruct
Set createStruct = aStruct
End Function
Sub InsertImage(ByRef oDoc As Object, ByRef oCurs As Object, sURL As String, ByRef oProvider As Object)
' Init variables and instance object
Dim oShape As Object
Dim oGraph As Object
Set oShape = oDoc.createInstance("com.sun.star.drawing.GraphicObjectShape")
Set oGraph = oDoc.createInstance("com.sun.star.text.GraphicObject")
'Set oProvider = serviceManager.CreateInstance("com.sun.star.graphic.GraphicProvider")
' Add shape to document
oDoc.getDrawPage.Add oShape
' Set property path of picture
Dim oProps(0) As Object
Set oProps(0) = MakePropertyValue("URL", sURL)
' Get size from picture to load
Dim oSize100thMM
Dim lHeight As Long
Dim lWidth As Long
Set oSize100thMM = RecommendGraphSize(oProvider.queryGraphicDescriptor(oProps))
If Not oSize100thMM Is Nothing Then
lHeight = oSize100thMM.Height
lWidth = oSize100thMM.Width
End If
' Set size and path property to shape
oShape.graphic = oProvider.queryGraphic(oProps)
' Copy shape in graphic object and set anchor type
oGraph.graphic = oShape.graphic
oGraph.AnchorType = 1 'com.sun.star.Text.TextContentAnchorType.AS_CHARACTER
' Remove shape and resize graphix
Dim oText As Object
Set oText = oCurs.GetText
oText.insertTextContent oCurs, oGraph, False
oDoc.getDrawPage.Remove oShape
If lHeight > 0 And lWidth > 0 Then
Dim oSize
oSize = oGraph.Size
oSize.Height = lHeight * 500
oSize.Width = lWidth * 500
oGraph.Size = oSize
End If
End Sub
'
'Converts a Ms Windows local pathname in URL (RFC 1738)
'Todo : UNC pathnames, more character conversions
'
Public Function ConvertToUrl(strFile) As String
strFile = Replace(strFile, "\", "/")
strFile = Replace(strFile, ":", "|")
strFile = Replace(strFile, " ", "%20")
strFile = "file:///" + strFile
ConvertToUrl = strFile
End Function
'
'Creates a sequence of com.sun.star.beans.PropertyValue s
'
Public Function MakePropertyValue(cName, uValue) As Object
Dim oStruct, oServiceManager As Object
Set oServiceManager = CreateObject("com.sun.star.ServiceManager")
Set oStruct = oServiceManager.Bridge_GetStruct("com.sun.star.beans.PropertyValue")
oStruct.Name = cName
oStruct.Value = uValue
Set MakePropertyValue = oStruct
End Function
'
'A simple shortcut to create a service
'
Public Function CreateUnoService(strServiceName) As Object
Dim oServiceManager As Object
Set oServiceManager = CreateObject("com.sun.star.ServiceManager")
Set CreateUnoService = oServiceManager.createInstance(strServiceName)
End Function
Public Function RecommendGraphSize(oGraph)
Dim oSize
Dim lMaxW As Double
Dim lMaxH As Double
lMaxW = 6.75 * 2540
lMaxH = 9.5 & 2540
If IsNull(oGraph) Or IsEmpty(oGraph) Then
Exit Function
End If
oSize = oGraph.Size100thMM
If oSize.Height = 0 Or oSize.Width = 0 Then
oSize.Height = oGraph.SizePixel.Height * 2540# * Screen.TwipsPerPixelY() '/ 1440
oSize.Width = oGraph.SizePixel.Width * 2540# * Screen.TwipsPerPixelX() '/ 1440
End If
If oSize.Height = 0 Or oSize.Width = 0 Then
Exit Function
End If
If oSize.Width > lMaxW Then
oSize.Height = oSizeHeight * lMax / oSize.Width
oSize.Width = lMaxW
End If
If oSize.Height > lMaxH Then
oSize.Width = oSize.Width * lMaxH / oSize.Height
oSize.Height = lMaxH
End If
RecommendGraphSize = oSize
End Function
Private Sub Command1_Click()
firstOOoProc
End Sub
The content of the testFile.Doc file is as shown below:
This is a test File
[TESTDATA1]
[PICTUREPLACEHOLDER]
It looks like you need to move the view cursor to the found location.
Found = oDoc.findFirst(SearchDescriptor)
oVC = oDoc.getCurrentController().getViewCursor()
oVC.gotoRange(Found, False)
oVC.setString("")

OpenOffice BASIC how to insert checkbox in sheet

I'm using OpenOffice Calc.
And I am writing macro's in OpenOffice BASIC.
I need the right code to insert a checkbox in the sheet.
I now have
Dim Doc as Object
Doc = ThisComponent
Dim cbName As Object
cbName = "checkbox_name"
Dim oCheckBoxModel as Object
// dlg is a dialog, (don't know how to create a checkbox else)
oCheckBoxModel = dlg.getmodel().createInstance( "com.sun.star.awt.UnoControlCheckBoxModel" )
oCheckBoxModel.PositionX = 100
oCheckBoxModel.PositionY = 100
oCheckBoxModel.Width = 50
oCheckBoxModel.Height = 30
oCheckBoxModel.Label = id
oCheckBoxModel.Name = cbName
oCheckBoxModel.Enabled = True
oCheckBoxModel.TabIndex = 1
Doc.Sheets().insertByName( cbName, oCheckBoxModel ) // This line is totally wrong, but I hope it's clear what I want to do
So I want to create a checkbox, and then insert it into the sheet. (In a specific cell, or just by setting a X and Y position).
I searched on the internet, but I only find information about inserting controls into a dialog, not into a sheet
To create check boxes manually, see here. To create check boxes dynamically:
Sub CreateCheckbox
oDoc = ThisComponent
oSheet = oDoc.Sheets.getByIndex(0)
oDrawPage = oSheet.DrawPage 'Was oDrawPage = oDoc.getDrawPage()
oCheckboxModel = AddNewCheckbox("Checkbox_1", "Check this box", oDoc, oDrawPage)
End Sub
Function AddNewCheckbox(sName As String, sLabel As String, _
oDoc As Object, oDrawPage As Object) As Object
oControlShape = oDoc.createInstance("com.sun.star.drawing.ControlShape")
aPoint = CreateUnoStruct("com.sun.star.awt.Point")
aSize = CreateUnoStruct("com.sun.star.awt.Size")
aPoint.X = 1000
aPoint.Y = 1000
aSize.Width = 3000
aSize.Height = 1000
oControlShape.setPosition(aPoint)
oControlShape.setSize(aSize)
oButtonModel = CreateUnoService("com.sun.star.form.component.CheckBox")
oButtonModel.Name = sName
oButtonModel.Label = sLabel
oControlShape.setControl(oButtonModel)
oDrawPage.add(oControlShape)
AddNewCheckbox = oButtonModel
End Function
This code was adapted from https://forum.openoffice.org/en/forum/viewtopic.php?f=45&t=46391.

How to skip or ignore find tables MS Word?

I've a macro code (created by Davy C) to find paragraph styles and add comment for each one if found. I need to improve this code. I want to run this macro code only paragraphs and need to skip/ignore tables when found. How do I do this?
Sub CheckKeepWithNext01()
Const message As String = "Check Keep With Next"
Const styleMask As String = "Bold + KWN"
Dim paragraphCount As Integer
Dim i As Integer
Dim currentStyle As String
Dim doc As Document
Set doc = ActiveDocument
paragraphCount = doc.Paragraphs.count
Do While i < paragraphCount
i = i + 1
If doc.Paragraphs(i).Range.Bold = True Then
If doc.Paragraphs(i).KeepWithNext = False Then
currentStyle = doc.Paragraphs(i).Range.Style
If Left(currentStyle, Len(styleMask)) <> styleMask Then
doc.Paragraphs(i).Range.Select
Selection.Comments.Add Range:=Selection.Range
Selection.TypeText Text:=message
End If
End If
End If
Loop
Set doc = Nothing
End Sub
See below screenshot for more clarity:
I've got the answer!
If doc.Paragraphs(i).Range.Tables.count = 0 Then

SAP B1 - Option Button- 'Unable to cast object System.String to type SAPbouiCOM.Item' Error

I am writing a vb.net code in Visual Studio for an add on in SAP B1. Right now, I want to choose an option button and according to what the user chose, I want to take this value and send it to another function in another class. This action I want to make it right after the user press the OK button, so I am trying to do this in an event.
The code that I wrote for creating the options buttons:
Dim optBtn As SAPbouiCOM.OptionBtn
'Dim oFrm As SAPbouiCOM.Form
Dim oUserdatasource As SAPbouiCOM.UserDataSource
oUserdatasource = oform2.DataSources.UserDataSources.Add("BD_resDS", SAPbouiCOM.BoDataType.dt_SHORT_TEXT, 1)
'Option 1
oItem = oform2.Items.Add("BD_rbRes", SAPbouiCOM.BoFormItemTypes.it_OPTION_BUTTON)
oItem.Left = 155
oItem.Top = 10
oItem.Height = 16
oItem.Width = 55
optBtn = oItem.Specific
optBtn.Caption = "Cheque"
optBtn.DataBind.SetBound(True, , "BD_resDS")
'Option 2
oItem = oform2.Items.Add("BD_rbPost", SAPbouiCOM.BoFormItemTypes.it_OPTION_BUTTON)
oItem.Left = 220
oItem.Top = 10
oItem.Height = 16
oItem.Width = 55
optBtn = oItem.Specific
optBtn.Caption = "Cash"
oItem.Visible = True
optBtn = oItem.Specific
optBtn.GroupWith("BD_rbRes")
optBtn.DataBind.SetBound(True, , "BD_resDS")
'Option 3
oItem = oform2.Items.Add("BD_rbPost2", SAPbouiCOM.BoFormItemTypes.it_OPTION_BUTTON)
oItem.Left = 280
oItem.Top = 10
oItem.Height = 16
oItem.Width = 75
optBtn = oItem.Specific
optBtn.Caption = "Credit Card"
oItem.Visible = True
optBtn = oItem.Specific
optBtn.GroupWith("BD_rbPost")
The code that I wrote in the event is this :
Public Sub SBO_Application_ItemEvent(ByVal FormUID As String, ByRef pVal As SAPbouiCOM.ItemEvent, ByRef BubbleEvent As Boolean) Handles SBO_Application.ItemEvent
Try
Dim fInv As SAPbouiCOM.Form
Dim omethod As SAPbouiCOM.Item
Dim opaymeth As SAPbouiCOM.OptionBtn
Dim paymeth As String
'If pVal.ItemUID = "1" And pVal.EventType = SAPbouiCOM.BoEventTypes.et_ITEM_PRESSED And pVal.BeforeAction = True And pVal.ActionSuccess = False And pVal.FormUID = "60006" Then
'End If
'Events of the Blanket Agreement form
If (FormUID = "Choose") Then
If (pVal.BeforeAction = False) Then
' Click on Add Row
If (pVal.ItemUID = "1") And (pVal.EventType = SAPbouiCOM.BoEventTypes.et_ITEM_PRESSED) Then
fInv = SBO_Application.Forms.Item(FormUID)
omethod = fInv.DataSources.UserDataSources.Item("BD_resDS").ValueEx
opaymeth = omethod.Specific
paymeth = opaymeth.Value.ToString()
SBO_Application.MessageBox(paymeth)
If paymeth <> "" And paymeth <> Nothing Then
Dim paym As New payment(SBO_Application, oCompany)
paym.pay(paymeth)
End If
End If
End If
End If
Catch ex As Exception
'SBO_Application.MessageBox(er.Message)
SBO_Application.MessageBox(ex.Message)
End Try
End Sub
Now, the error that I got in SAP B1 is:
Unable to cast object 'System.String' to type 'SAPbouiCOM.Item'
You have declared
Dim omethod As SAPbouiCOM.Item
and assigning it to the string value
omethod = fInv.DataSources.UserDataSources.Item("BD_resDS").ValueEx
Declare string variable and assign value to it like
Dim tmpval as string =""
tmpval = fInv.DataSources.UserDataSources.Item("BD_resDS").ValueEx
try this
omethod = fInv.DataSources.UserDataSources.Item("BD_resDS").ValueEx
.ValueEx seems to return a String, so I guess you just need to remove it
omethod = fInv.DataSources.UserDataSources.Item("BD_resDS")
Another fine example why you should always turn Option Strict ON ;)

Calling ABAP function module from Excel VBA Macro

I want to call an ABAP function from an Excel VBA Macro.
Is there any method I can follow to achieve this.
Please help me regarding this.
Dim sapConn As Object 'Declare connection object
Set sapConn = CreateObject("SAP.Functions") 'Create ActiveX object
sapConn.Connection.user = "user" 'Specify user
sapConn.Connection.Password = "" 'Then password
sapConn.Connection.client = "001" 'Client
sapConn.Connection.ApplicationServer = "server" 'Target server address
sapConn.Connection.Language = "PT" 'Language code
'Finally, try to logon to the specified system and check if the connection established
If sapConn.Connection.Logon(0, True) <> True Then
MsgBox "Cannot Log on to SAP" 'Issue message if cannot logon
Else
MsgBox "Logged on to SAP!"
End If
Dim rfcAcctDocCheck As Object
Dim oAcctHeader As Object
Dim otAcctAR, otAcctGL, otAcctAP, otAcctAMT, otReturn As Object
Set rfcAcctDocCheck = sapConn.Add("BAPI_ACC_DOCUMENT_CHECK")
Set oAcctHeader = rfcAcctDocCheck.Exports("DOCUMENTHEADER")
Set otAcctGL = rfcAcctDocCheck.Tables("ACCOUNTGL")
Set otAcctAR = rfcAcctDocCheck.Tables("ACCOUNTRECEIVABLE")
Set otAcctAP = rfcAcctDocCheck.Tables("ACCOUNTPAYABLE")
Set otAcctAMT = rfcAcctDocCheck.Tables("CURRENCYAMOUNT")
Set otReturn = rfcAcctDocCheck.Tables("RETURN")
Dim qtLegs As Integer
Dim dt, comp, tpDoc, docRef, tpAcct, acct, customer, vendor, _
curr, val, spLedger, ccenter, order As String
Dim curLine As Integer
For lin = 1 To UBound(reg)
id = Format(tbPost.Cells(reg(lin).lin_ini, K_COL_ID), "0000000000")
dt = getDate(tbPost.Cells(reg(lin).lin_ini, K_COL_DT))
comp = getCompanyCode(tbPost.Cells(reg(lin).lin_ini, K_COL_EMPR))
tpDoc = getDocumentType(tbPost.Cells(reg(lin).lin_ini, K_COL_TP_DOC))
docRef = tbPost.Cells(reg(lin).lin_ini, K_COL_DOC_REF)
otAcctGL.freeTable
otAcctAR.freeTable
otAcctAP.freeTable
otAcctAMT.freeTable
oAcctHeader("USERNAME") = sapConn.Connection.user
oAcctHeader("HEADER_TXT") = "Lancado via Excel"
oAcctHeader("COMP_CODE") = comp
oAcctHeader("DOC_DATE") = dt
oAcctHeader("PSTNG_DATE") = dt
oAcctHeader("DOC_TYPE") = tpDoc
oAcctHeader("REF_DOC_NO") = docRef
otAcctAMT.Rows.Add
otAcctAMT(otAcctAMT.Rows.Count, "ITEMNO_ACC") = Format(leg, "0000000000")
otAcctAMT(otAcctAMT.Rows.Count, "CURRENCY") = curr
otAcctAMT(otAcctAMT.Rows.Count, "AMT_BASE") = val
Next
If rfcAcctDocCheck.Call = False Then
MsgBox rfcAcctDocCheck.Exception
End If