Live Preview like CalendarCreator...

[ddonnahoe]

I have a macro in CD12 that I wrote about a year ago and have been constantly tweaking it to make improvements. My latest tweak is changing the standard preview area (which is just a VB picture box) to use the functionality of the dll Alex told me about that gives live preview of the document as it is being created, like in his CalendarCreator. The problem is I don't really understand much about how to program this little gem.

Currently my code just takes the input from the browse file window and if it is a file capable of being shown in the VB picture box (i.e. jpg or bmp) then it shows a preview of the imported file. Otherwise it shows and bmp file that reads "Preview Not Available". I want to get rid of the annoying piece of crap and make the preview area preview the whole document. It is only one page anytime I run the macro and I would really like to see it before it prints. Sometimes the .ai or .eps that I import is not formatted properly or I might accidentally choose the wrong file.

What I'm getting at is I want to be able to see the imported file no matter waht file file format it is, before the macro is finished.

Here is the code...

Option Explicit
Private Declare Function GetOpenFileName Lib "comdlg32.dll" _
    Alias "GetOpenFileNameA" _
    (pOpenfilename As OPENFILENAME) As Long

Private Type OPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type
Private Function GetValue(ByVal sValue As String) As Integer
    If sValue = "" Then
        GetValue = 0
    Else
        GetValue = Val(sValue)
    End If
End Function
Private Sub RunningTotal()
    Dim sa As Integer
    Dim ma As Integer
    Dim la As Integer
    Dim xla As Integer
    Dim xxla As Integer
    Dim xxxla As Integer
    Dim yxs As Integer
    Dim ys As Integer
    Dim ym As Integer
    Dim yl As Integer
    Dim tc As Integer
    
    sa = GetValue(ASmall1.Value)
    ma = GetValue(AMedium1.Value)
    la = GetValue(ALarge1.Value)
    xla = GetValue(AXLarge1.Value)
    xxla = GetValue(ADoubleX1.Value)
    xxxla = GetValue(A3X1.Value)
    yxs = GetValue(YBaby1.Value)
    ys = GetValue(YSmall1.Value)
    ym = GetValue(YMedium1.Value)
    yl = GetValue(YLarge1.Value)

    tc = sa + ma + la + xla + xxla + xxxla + yxs + ys + ym + yl
    
    If tc > 0 Then
        TCTotal.Caption = "Total Shirts: " & tc
        Else
        TCTotal.Caption = "Total Shirts: 0"
    End If
End Sub
Private Sub A3X1_Change()
    RunningTotal
End Sub
Private Sub ADoubleX1_Change()
    RunningTotal
End Sub
Private Sub ALarge1_Change()
    RunningTotal
End Sub
Private Sub AMedium1_Change()
    RunningTotal
End Sub
Private Sub ASmall1_Change()
    RunningTotal
End Sub
Private Sub AXLarge1_Change()
    RunningTotal
End Sub

Private Sub DateIn_Change()
    RushOrder
End Sub
Private Sub DateOut_Change()
    RushOrder
End Sub
Private Sub YBaby1_Change()
    RunningTotal
End Sub
Private Sub YLarge1_Change()
    RunningTotal
End Sub
Private Sub YMedium1_Change()
    RunningTotal
End Sub
Private Sub YSmall1_Change()
    RunningTotal
End Sub
Private Sub cmdBrowse_Click()
    Call ShowOpenFile
End Sub
Private Sub RushOrder()
    If DateOut.Value - DateIn.Value < 7 Then
        RushCheckBox1.Value = True
    Else
        RushCheckBox1.Value = False
    End If
End Sub
Public Function ExtractPath(ByVal strPathFile As String, Optional ByVal bolAddSlash As Boolean = False) As String
    Dim intPos As Integer
    strPathFile = Trim(strPathFile)
    intPos = InStrRev(strPathFile, "\")
    If intPos Then
        If Not bolAddSlash Then intPos = intPos - 1
        ExtractPath = Left$(strPathFile, intPos)
    Else
        ExtractPath = ""
    End If
End Function
Private Sub ShowOpenFile()
Dim OFName As OPENFILENAME
Dim sPath As String
Dim GetBackEnd As String
Dim BrowseOpenFile As String
Dim n As String

    OFName.lStructSize = Len(OFName)
    OFName.hwndOwner = 0&
    OFName.hInstance = 0&
    OFName.lpstrFilter = "Image Files" + Chr$(0) + "*.jpg;*.bmp;*.gif;*.jpeg;*.ai;*.cdr;*.eps"
    OFName.lpstrFile = Space$(254)
    OFName.nMaxFile = 255
    OFName.lpstrFileTitle = Space$(254)
    OFName.nMaxFileTitle = 255
    'sPath = GetBackEnd
    sPath = ExtractPath(sPath, True)
    If sPath = vbNullString Then
        'OFName.lpstrInitialDir = "c:\SharedImages\"
        OFName.lpstrInitialDir = ExtractPath(sPath, True)
    Else
        sPath = Left(sPath, InStrRev(sPath, "\") - 1)
        If Len(Dir(sPath, vbDirectory)) > 0 Then
            OFName.lpstrInitialDir = sPath
        Else
            OFName.lpstrInitialDir = "c:\SharedImages\"
        End If
    End If
    OFName.lpstrTitle = "Select an image File (*.jpg), (*.bmp), (*.gif), (*.ai), (*.cdr), (*.eps)"
    OFName.flags = 0

    If GetOpenFileName(OFName) Then
        BrowseOpenFile = OFName.lpstrFile
    Else
        BrowseOpenFile = vbNullString
        MsgBox "No file Selected."
    End If
    
    txbImagePath.Text = BrowseOpenFile
        n = InStr(BrowseOpenFile, vbNullChar)
        If n <> 0 Then BrowseOpenFile = Left$(BrowseOpenFile, n - 1)
            If LCase$(Right$(txbImagePath.Text, 3)) = ".ai" Then
                PictureNotAvail
            ElseIf LCase$(Right$(txbImagePath.Text, 3)) = "cdr" Then
                PictureNotAvail
            ElseIf LCase$(Right$(txbImagePath.Text, 3)) = "eps" Then
                PictureNotAvail
            Else
                PreviewAvail
            End If

End Sub
Sub PictureNotAvail()
    With OrderImage
    .Picture = LoadPicture("c:\pna.bmp")
    .PictureAlignment = fmPictureAlignmentCenter
    .PictureSizeMode = fmPictureSizeModeZoom
    End With
End Sub
Sub PreviewAvail()
    Dim pic As Picture
    Dim BrowseOpenFile As String
    On Error Resume Next
    Set pic = LoadPicture(BrowseOpenFile)
        If Err.Number <> 0 Then
        Set pic = LoadPicture("c:\pna.bmp")
        Else
        Set pic = LoadPicture(txbImagePath.Text)
        End If
    With OrderImage
    .Picture = pic
    .PictureAlignment = fmPictureAlignmentCenter
    .PictureSizeMode = fmPictureSizeModeZoom
    End With
End Sub
Sub UserForm_Initialize()
    RunningTotal
    SendToColor.Value = True
    Dim CSColor As Color
    Dim CSPalette As Palette
    For Each CSPalette In Palettes
        If CSPalette.Type = cdrFixedPalette Then
            'If CSPalette.PaletteID = cdrPANTONECorel8 Then
            If CSPalette.PaletteID = cdrPANTONECoated Then
                Exit For
            End If
        End If
    Next CSPalette
    
    If CSPalette Is Nothing Then
        'Set CSPalette = Palettes.OpenFixed(cdrPANTONECorel8)
        Set CSPalette = Palettes.OpenFixed(cdrPANTONECoated)
    End If
    
    Dim sName As String
    Dim C As Color
    Dim n As Long, i As Long

    For Each CSColor In CSPalette.Colors
    sName = CSColor.Name
        If CSColor.Name <> "unnamed color" Then
            If Left$(sName, 8) = "PANTONE " Then sName = Mid$(sName, 9)
            If Right$(sName, 2) = " C" Then sName = Left$(sName, Len(sName) - 2)
            sName = "PMS " & sName
                If sName = "PMS Orange 021" Then sName = "Orange PMS 021"
                If sName = "PMS 109" Then sName = "Yellow " & sName
                If sName = "PMS 131" Then sName = "Old Gold " & sName
                If sName = "PMS 186" Then sName = "Red " & sName
                If sName = "PMS 202" Then sName = "Burgundy " & sName
                If sName = "PMS 233" Then sName = "Fuchsia " & sName
                If sName = "PMS 279" Then sName = "Columbia Blue " & sName
                If sName = "PMS 281" Then sName = "Navy Blue " & sName
                If sName = "PMS 286" Then sName = "Royal Blue " & sName
                If sName = "PMS 321" Then sName = "Teal " & sName
                If sName = "PMS 348" Then sName = "Kelly Green " & sName
                If sName = "PMS 357" Then sName = "Forest Green " & sName
                If sName = "PMS 430" Then sName = "Grey " & sName
                If sName = "PMS 475" Then sName = "Flesh " & sName
                If sName = "PMS 498" Then sName = "Brown " & sName
                If sName = "PMS 1235" Then sName = "Spanish Gold " & sName
                If sName = "PMS Process Black" Then sName = "Black"
                'If sName = "PMS Trans. White" Then sName = "White"
                If sName = "PMS 871" Then sName = "Gold Metallic " & sName
                If sName = "PMS 877" Then sName = "Silver Metallic " & sName
            ComboBoxPalette1.AddItem sName
            ComboBoxPalette2.AddItem sName
            ComboBoxPalette3.AddItem sName
            ComboBoxPalette4.AddItem sName
            ComboBoxPalette5.AddItem sName
            ComboBoxPalette6.AddItem sName
        End If
    Next CSColor
    
    With cmbxPrinted
    .AddItem "Printing Department"
    .AddItem "Sewing Department"
    End With
    With cmbxPulled
    .AddItem "Gwynne"
    .AddItem "Julie"
    .AddItem "Leigh"
    .AddItem "Randy"
    .AddItem "Reggie"
    .AddItem "Sean"
    .AddItem "Trey"
    End With
    With cmbxTaken
    .AddItem "Gwynne"
    .AddItem "Julie"
    .AddItem "Leigh"
    .AddItem "Randy"
    .AddItem "Reggie"
    .AddItem "Trey"
    End With
End Sub

[ddonnahoe]

Private Sub cancel_Click()
    ' Cancels the Order Form Menu
    Unload Me
End Sub
Private Sub OK_Click()
    Me.Hide
    Dim p As Page
    Dim sa As Integer
    Dim ma As Integer
    Dim la As Integer
    Dim xla As Integer
    Dim xxla As Integer
    Dim xxxla As Integer
    Dim yxs As Integer
    Dim ys As Integer
    Dim ym As Integer
    Dim yl As Integer
    Dim tc As Integer
    
    sa = GetValue(ASmall1.Value)
    ma = GetValue(AMedium1.Value)
    la = GetValue(ALarge1.Value)
    xla = GetValue(AXLarge1.Value)
    xxla = GetValue(ADoubleX1.Value)
    xxxla = GetValue(A3X1.Value)
    yxs = GetValue(YBaby1.Value)
    ys = GetValue(YSmall1.Value)
    ym = GetValue(YMedium1.Value)
    yl = GetValue(YLarge1.Value)

    tc = sa + ma + la + xla + xxla + xxxla + yxs + ys + ym + yl
    
    ' Open OrderForm.cdt
    Dim doc As Document
    Set doc = CreateDocumentFromTemplate("c:\OrderForm.cdt")
    
    If txbImagePath.Text <> "" Then
        Dim s5 As Shape
        Dim x As Double, y As Double
        Dim nsy As Double
        ActiveLayer.Import txbImagePath.Text
        Set s5 = ActiveSelection
        s5.Move 0#, 0#
        ActiveDocument.ReferencePoint = cdrCenter
        s5.GetPosition x, y
        If s5.SizeWidth > (2.14 * s5.SizeHeight) Then
            nsy = (7.5 / s5.SizeWidth) * s5.SizeHeight
            s5.SetSizeEx x, y, , nsy
        ElseIf s5.SizeWidth < (2.14 * s5.SizeHeight) Then
            s5.SetSizeEx x, y, , 3.5
        End If
        s5.PositionX = 6.797
        s5.PositionY = 2.154
    End If
    
    ' Add input from form to page
    If RushCheckBox1.Value = True Then
        Dim s888 As Shape
        Set s888 = ActiveLayer.CreateRectangle(6.548315, 7.274756, 7.852031, 6.955921, 0, 0, 0, 0)
        s888.OrderToBack
        s888.Fill.UniformColor.CMYKAssign 0, 0, 100, 0
        s888.Outline.Type = cdrNoOutline
    End If
    
    If optCOD.Value = True Then
        ActiveLayer.CreateArtisticText 8.343, 6.75, "ü", cdrEnglishUS, , "Wingdings", 18, cdrTrue, cdrFalse, cdrNoFontLine, cdrLeftAlignment
    End If
    
     ' So on and so forth... Continue adding input from form.
     ' See actual macro  for complete code.
    
    ActiveDocument.ClearSelection
    
    ' Set Printer
    If SendToColor.Value = True Then
        Dim prn1 As Printer
        Dim n As Long
    
        Set prn1 = Nothing
        For n = 1 To Printers.Count
           If Printers(n).Name = "hp deskjet 5550 series" Then
                Set prn1 = Printers(n)
                Exit For
            End If
        Next n
    
        If prn1 Is Nothing Then
            MsgBox "Printer not found", vbCritical
        Else
           Set ActiveDocument.PrintSettings.Printer = prn1
           ActiveDocument.PrintSettings.Copies = 1
        End If

        ActiveDocument.PrintSettings.Copies = 1
        ActiveDocument.PrintSettings.PageRange = "1"
        ActiveDocument.PrintOut
    End If
    
    If SendToLaser.Value = True Then
        Dim prn2 As Printer
        Dim j As Long
    
        Set prn2 = Nothing
        For j = 1 To Printers.Count
           If Printers(j).Name = "GCC Elite XL 20/600 v3.31" Then
                Set prn2 = Printers(j)
                Exit For
            End If
        Next j
    
        If prn2 Is Nothing Then
            MsgBox "Printer not found", vbCritical
        Else
           Set ActiveDocument.PrintSettings.Printer = prn2
           ActiveDocument.PrintSettings.Copies = 1
        End If

        ActiveDocument.PrintSettings.Copies = 1
        ActiveDocument.PrintSettings.PageRange = "1"
        ActiveDocument.PrintOut
    End If
    
        ActiveWindow.ActiveView.ToFitPage
        
    If ActiveDocument.Pages.Count > 1 Then
        For Each p In ActiveDocument.Pages
            If p.Index > 1 Then p.Delete
        Next p
    End If
        
    Dim opt As New StructSaveAsOptions
            opt.EmbedICCProfile = False
            opt.Filter = cdrCDR
            opt.IncludeCMXData = False
            opt.Overwrite = False
            opt.Range = cdrAllPages
            opt.ThumbnailSize = cdr10KColorThumbnail
            opt.Version = cdrCurrentVersion
        ActiveDocument.SaveAs "D:\OrderForms\" & Format(Date, "mmddyy") & "-" & Name1.Text & "-" & PONum1.Text & ".cdr", opt
    
    ActiveDocument.Windows(1).Close
    Me.show vbModeless
    'Unload Me
End Sub

I am attaching all neccesary files to run on anyones work station. Some of the code may need changing (i.e. path configurations and what not).

[Alex]

I'm not sure I understand your question completely but I suspect you are asking too much for that little DLL. What it can do is allow you to draw onto a bitmap. You can draw lines, text, images, etc and then when everything is composed, show the bitmap in a VBA form. That's how Calendar Wizard works.

You can read the description of the DLL here: http://www.oberonplace.com/script/ui...ary2/index.htm

The DLL itself is installed with CorelDRAW 11 and 12 by default, so you don't have to redistribute it with your macro, however you need to provide VBA declarations for functions exported by the DLL so you can use it with your macros.

You can find all the declarations in my previous post here: http://forum.oberonplace.com/showpos...56&postcount=2

[ddonnahoe]

O.K. then. What about this. How can I take files that are not readable/viewable by the VB picture box control and make them viewable? I would assume that it involves creating a scratch document of the .ai, .eps, .cdr or other unreadable format and exporting to a bitmap that could be overwritten time and again and import that bitmap image in to the preview box. Then dismiss the scratch document.

How can I do this so that is optimal and doesn't drag the speed of the macro down?

[Alex]

Yes, that's the only thing I can think of which would do what you want. To create all the code you need, use VBA recorder. Begin with no document open in CorelDRAW, start VBA recorder, then open a file (AI, CMX, etc), export it to a bitmap at certain resolution, then close the document. The recorder will generate all the code necessary to perform this operation, you just need to copy/paste it into your project and tweak it (replace the hardcoded paths to the files, change the resulting image size, etc).

I hope this helps.

[SteveDude]

At one time I got a piece of code from somebody at Corel that showed a preview of the current page. Sadly I lost it many moons ago, but I thought I would throw this at you. It's some Vb6 code that will extract the preview from any CDR or CMX and works with Version 3 through X3 files. Can be modified to use with other formats. Might work in VBA, but never tried it. Did it along time ago, now use a version done in C++ that extracts/sets keywords and comments also...

Private Function ExtractBMP(SrcFile As String, tgtFile As String, Optional LookFor As String="BM") As Boolean

Dim fl As Long, i As Long, xin As Integer
Dim Perc As Integer, pos As Long

ExtractBMP = False

fl = FileLen(SrcFile)

Open SrcFile For Binary As #1
i = 1
Dim Chunck As String * 1000
Dim rChunck As String
Dim lChunck As String
xin = False

Open tgtFile For Binary As #2

Do While Not EOF(1)
Get #1, , Chunck
'~~~~~~~~~~~
Perc = Int((Seek(1) / fl) * 100)
'lblPercent.Caption = str(perc) + "% Completed"
'~~~~~~~~~~~
pos = InStr(Chunck, LookFor)

If pos <> 0 Then

If xin = False Then 'start of block
rChunck = right(Chunck, Len(Chunck) - pos + 1)
Put #2, , rChunck
xin = True
Else
lChunck = left(Chunck, Len(Chunck))
Put #2, , lChunck
Close #2
i = i + 1
Open tgtFile For Binary As #2
rChunck = right(Chunck, Len(Chunck) - pos + 1)
Put #2, , rChunck
End If

Else

If xin = True Then Put #2, , Chunck

End If

DoEvents

Loop

Close

If i = 1 And FileLen(tgtFile) = 0 Then
Kill tgtFile
i = 0
End If
If i > 0 Then ExtractBMP = True

End Function

Sure wish I could find that old code for the live preview.

Just for reminding. If you are using CorelVBA or CorelScript you can use build-in function GetCDRFileThumbnail. As I remember it was not working in some CorelDraw versions, so your code can be used instead.

Sub Exbmp()
CorelScript.GetCDRFileThumbnail "c:\test.cdr", "c:\test.bmp"
End Sub

[SteveDude]

Lev,

I wrote it for that reason, the VBA version was unreliable and if I remember correctly it did't go all the way back to v3. You can also make it work with EPS files, but you need to know how to convert a TIF to a BMP to get it work in a VB picture box. I actually do it a diifferent way now. My current DLL supports CDR, CMX, CPT, DRAWings, EPS, DXF, PLT and most Camera Formats including RAW, CRW, etc...Images are extracted to a byte array and then written to a Device Context. Personally I think Delphi is much easier when it comes to dealing with picture formats and you can create dependancy free dll's and EXE's. That's what I used for my CMX Viewer/Converter.

There is also a way to hook into the MS Office File Filters to import CDR's directly, but only up to v9.

I did versions in Delphi and VB. If there is an interest or a need i will post the code. Sorry, won't do it for CMX, because I spent too much time on it.

Steve

I wrote it for that reason, the VBA version was unreliable

Yes, I thought the same

and if I remember correctly it did't go all the way back to v3

It was workin in some versions

... i will post the code. Sorry, won't do it for CMX

Is there a big difference between CDR and CMX thumbnails? I thought they are nearly the same? Or you are parsing the CMX format itself? Or you meant some another format?

By the way, there are a lot of viewers in the net, some of them have partitionally opened sources. You can check their code. For example: CorelDraw plugin for Where Is It?. There are more formats you can check.

[shelbym]

Is there any viewer of plugin that acutally parses the CDR and not the bitmap? I am working with a company now that would like to send drawings to clients that don't have CorelDRAW on their computer, they need a way to easily view these files to approve them. Any thoughts?

Thanks,

Shelby