I'm trying to insert a date into a label. I have written the following code. I can select a date by clicking on the arrow and the calendar pops up. The "CANCEL" button is working, but when I click "OK" I cannot get it to insert on the label. The label is a regular Corel document with text and images. I tried inserting a rectangle toolbox to see if I can get it to insert the date in there by using X,Y coordinates but that didn't work. I basically need to know how to insert DTPicker.Value onto the label.
DTPicker.Value
I've tried this : 1. Add a button on macro form 2. Select the rectangle 3. Click the button 4. Macro will read X, Y Pos of the rectangle, then create text and positioning it on the center of the rectangle.
Please see my post on stackOverflow for more details: http://stackoverflow.com/questions/32389241/coreldraw-x6-macro-to-insert-date-using-dtpicker-control/32502426#32502426. Thank you.
--------------------------
Private Sub OK_Click()
Dim sr As Shape Set sr = ActivePage.SelectableShapes.FindShapes.All
CorelDRAW.ActiveDocument.ReferencePoint = cdrCenter ActiveWindow.RulerOriginX = cdrCenter ActiveWindow.RulerOriginY = cdrCenter
ActiveDocument.ActiveLayer.Selected = True CorelDRAW.ActiveDocument.Unit = cdrInchSet sh = CorelDRAW.ActiveLayer.CreateArtisticText(0, 0, CStr(DTPicker1.Value)) MsgBox sh sh.PositionX = XPos sh.PositionY = YPos
'Unload MeEnd Sub
Wow, you are awesome. That does insert the date. Thank you so much. However, you made me realize that I was not using CorelDraw so now I have to try to make your other code work. Please read my other message sent before this one. Thank you so much.
Angie,
You cannot name your variable Page or Shape, so you need to name them something like p or myPage. If you want the date on each shape you will need to loop through all pages and each shape on the page like this:
Dim p As Page Dim strMyDate As String Dim x As Double, y As Double Dim s As Shape, sDate As Shape 'Get the date from the DatePicker strMyDate = CStr(DTPicker1.Value) 'Check to make sure the string is not empty, CreateArtisticText does not like an empty string If strMyDate <> "" Then 'Loop through each page in the Active Document For Each p In ActiveDocument.Pages 'Loop through each shape on each page For Each s In p.FindShapes() s.GetPositionEx cdrTopLeft, x, y 'Create the text with the date at the top left corner of the ShapeRange Set sDate = p.ActiveLayer.CreateArtisticText(x, y, strMyDate) 'Move the text the distance of the height 'You only want to use this line if you want the date to run into your shape 'sDate.Move 0, -sDate.SizeHeight Next s Next p End If 'Clean things up if you like Set sDate = Nothing Set s = Nothing Set p = Nothing
Hope that helps,
-Shelby
So, I have tried this code and I'm getting many labels inserted on the document at the same time which causes the pages to stop responding for a few seconds.When I click on the labels,every text and image is selectable.The document is not one whole image. I was wondering if maybe it's because of that?
Here's the code I'm using in case you can find something different:
Private Sub OK_Click() Dim p As Page Dim x As Double, y As Double Dim strMyDate As String Dim s As Shape, sDate As Shape 'Get the date from the DatePicker strMyDate = CStr(DTPicker1.Value) 'Check to make sure the string is not empty, CreateArtisticText does not like an empty string If strMyDate <> "" Then 'Loop through each page in the Active Document For Each p In ActiveDocument.Pages 'Loop through each shape on each page For Each s In p.FindShapes() 'Get the top left position of the ShapeRange s.GetPositionEx cdrTopLeft, x, y 'Create the text with the date at the bottom left corner of the ShapeRange Set sDate = p.ActiveLayer.CreateArtisticText(x, y, strMyDate) Next s Next p End If 'Clean things up Set sDate = Nothing Set s = Nothing Set p = Nothing End Sub
***Note that I ran the macro twice so this is why there's a lot more labels than the first time.