ZDIRY-TUFWT-EBONM-EYJ00-IDBLANTER.COM
ZDIRY-TUFWT-EBONM-EYJ00
BLANTERWISDOM105

Membuat Color Swatch Pantone (kumpulan kotak warna pantone otomatis) di Coreldraw 2017 64 Bit

7/15/2018
Sebuah Sistem Pencocokan Warna atau Color Matching System (CMS) adalah metode yang digunakan untuk memastikan konsistensi warna dalam proses design hingga produksi terlepas dari perangkat / media yang digunakan untuk menampilkan warna. Menjaga keakuratan dan konsistensi warna dari berbagai di media sangat sulit, bukan hanya karena warna sangat subjektif hingga batas tertentu, tetapi juga karena perangkat yang digunakan untuk menampilkan warna sangat banyak dan luas, serta teknologi yang digunakan berbeda-beda.

Ada berbagai Color Matching System (CMS) yang tersedia hingga hari ini, tapi sejauh ini yang populer  dalam industry percetakan adalah Pantone Matching System, atau PMS. PMS adalah sebuah sistem pencocokan “warna-solid”. Dimana warna solid ini digunakan untuk patokan warna apa yang akan dipilih untuk mencocokan warna gambar yang akan dicetak.

Biasanya warna yang tampil di Komputer dan hasil cetakan akan berbeda karena perbedaan pengaturan di windows dengan printer, media kertas atau kain yang digunakan memiliki kekhususan/kelebihan warna CMYK (Cyan, Magenta, Yellow, Black) sehingga warna yang dicetak bercampur dengan warna media tersebut. Untuk mengatasi hal itu kita harus mencetak terlebih dahulu warna-warna pantone kedalam media yang dibutuhkan agar proses pencocokan warna cukup dengan media tersebut tidak perlu melihat warna yang tampil di Komputer.


Membuat kotak-kotak warna seperti diatas tidaklah memakan cukup waktu banyak, caranya cukup mudah,


Pertama, Buka Coreldraw terlebih dahulu. Jika belum download Coreldraw Terbaru disini.

Kedua, Aktifkan Profiles Color Pantone Solid Coated dengan cara buka menu 

Windows>Color Palettes dan pilih salah jenis color profile Pantone ® Solid Coated.
Ketiga, Biasanya untuk Coreldraw 2017 form untuk color swatch belum tersedia namun untuk Coreldraw dibawahnya sudah ada. Oleh karena itu admin akan membagikan file Form Color Swatch untuk Coreldraw 2017. Maka dari itu bukalah menu Tool>Macros>Macro Editor.


Keempat, Sekarang insert filenya dengan cara klik pada GlobalMacros pada Toolbars Project lalu klk menu File>Import file. Dan file yang harus di import adalah frmColorSwatch.frm dan CorelMacros.bas.


Download Color Swatch CorelDraw2017 dan CorelMacros.bas

Kelima,  Sekarang kita uji apakah file-file vb macro tersebut dapat dijalankan pada Macros CorelDraw 2017. Buka menu Tool>Macros>Run Macros. Pilih GlobalMacros.GMS > CorelMacros.CreateColorSwatch pada dialog Run Macros. Lalu pilih warna yang akan ditampilkan yaitu Pantone ® Solid Coated dan atur spacing = 2 , dan gunakan outline. Klik OK


Keenam, Hasilnya akan menampilkan 16 Page Coreldraw 2017 tergantung lebar dan tingginya halaman pada tiap page.


Selesai.



Semoga Bermanfaat



Terima kasih telah berkunjung ke https://www.agungpanduan.com



Kode VB Macros Soler Swatch



Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} frmColorSwatch 

   Caption         =   "Create ColorSwatch"

   ClientHeight    =   4815

   ClientLeft      =   45

   ClientTop       =   330
   ClientWidth     =   4080
   OleObjectBlob   =   "frmColorSwatch.frx":0000
   StartUpPosition =   1  'CenterOwner
End
Attribute VB_Name = "frmColorSwatch"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

' **********************
' PARAMETERS
' **********************

Dim CSPalette As Palette
Dim PrinterName, DatePrinted As String
Dim TileSpaceW, TileSpaceH As Double
Dim CSOutline As cdrOutlineType

' **********************
' DEFAULTs and CONSTANTS
' **********************

Private Const DEF_TILESPACE = 20#
Private Const TEXTFONT = "Arial"
Private Const TEXTSPACING = 3#
Private Const LEGENDWIDTH = 20#
Private Const LEGENDHEIGHT = 10#
Private Const THUMBNAILHEIGHT = 20#
Private Const THUMBNAILWIDTH = 20#

' ********************
' OPEN DIALOG
' ********************


'API declarations
Private Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare PtrSafe Function CommDlgExtendedError Lib "comdlg32.dll" () As Long
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr

#If Win64 Then

Private Type OPENFILENAME
        lStructSize As Long
        Padding1 As Long
        hwndOwner As LongPtr
        hInstance As LongPtr
        lpstrFilter As String
        lpstrCustomFilter As String
        nMaxCustFilter As Long
        nFilterIndex As Long
        lpstrFile As String
        nMaxFile As Long
        Padding2 As Long
        lpstrFileTitle As String
        nMaxFileTitle As Long
        Padding3 As Long
        lpstrInitialDir As String
        lpstrTitle As String
        flags As Long
        nFileOffset As Integer
        nFileExtension As Integer
        lpstrDefExt As String
        lCustData As LongPtr
        lpfnHook As LongPtr
        lpTemplateName As String
End Type

#Else

Private Type OPENFILENAME
        lStructSize As Long
        hwndOwner As LongPtr
        hInstance As LongPtr
        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 LongPtr
        lpfnHook As LongPtr
        lpTemplateName As String
End Type

#End If

'Open file dialog flag
Private Const OFN_HIDEREADONLY = &H4

'as VBA has no Hwnd(window handle) property, this function will find the Hwnd
Private Function getHwnd() As LongPtr
getHwnd = FindWindow("ThunderDFrame", "Common Open Dialog Example")
End Function


' ******************
' COLORSWATCH DIALOG
' ******************

Private Sub UserForm_Initialize()
    UpdatePaletteList
    If ComboBoxPalette.ListCount > 0 Then
         ComboBoxPalette.ListIndex = 0
    End If
    BoxSpace.Value = DEF_TILESPACE
    ButtonOK.SetFocus
End Sub

Private Sub ButtonOK_Click()
    If ValidateParams Then
        frmColorSwatch.Hide
        CreateColorSwatchFromPalette
    End If
End Sub

Private Sub ButtonCancel_Click()
    End
End Sub

Private Sub ButtonNow_Click()
    BoxDate.Value = Date
End Sub

Private Sub ButtonSelectFile_Click()
    'Ask user for the palette file
    Dim PaletteFileName As String
    Dim OpenPalette As Palette
    Dim ofn As OPENFILENAME
    Dim strFilter As String
    Dim lngApiReturn As Long
    
    'set up filter
    strFilter = "CPL - Palette Files" & Chr(0) & "*.cpl" & Chr(0) & "All Files (*.*)" & Chr(0) & "*.*"
    
    'initialize the ofn structure
    ofn.lStructSize = Len(ofn)
    ofn.flags = OFN_HIDEREADONLY
    ofn.hwndOwner = getHwnd
    ofn.lpstrFilter = strFilter
    ofn.nFilterIndex = 1
    ofn.lpstrFile = String(257, 0)
    ofn.nMaxFile = Len(ofn.lpstrFile) - 1
    ofn.lpstrFileTitle = ofn.lpstrFile
    ofn.nMaxFileTitle = ofn.nMaxFile
    ofn.lpstrTitle = "Open Palette File"
    ofn.lpstrInitialDir = CurDir
    
    'call the API function
    lngApiReturn = GetOpenFileName(ofn)

    If lngApiReturn <> 0 Then
        PaletteFileName = ofn.lpstrFile
        On Error GoTo ErrorOpenFile
        Set OpenPalette = Application.Palettes.Open(PaletteFileName)
        UpdatePaletteList
        ComboBoxPalette.Text = OpenPalette.Name
    End If
    Exit Sub
ErrorOpenFile:
    MsgBox "Unable to open " & PaletteFileName
End Sub

Private Sub CheckDate_Click()
    BoxDate.Enabled = CheckDate.Value
    ButtonNow.Enabled = CheckDate.Value
End Sub

Private Sub CheckPrinter_Click()
    BoxPrinter.Enabled = CheckPrinter.Value
End Sub

Private Sub BoxSpace_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
  If Not ((Chr(KeyAscii) >= 0 And Chr(KeyAscii) <= 9) Or (Chr(KeyAscii) = ".")) Then
    KeyAscii = 0
  End If
End Sub

Private Sub UpdatePaletteList()
    ComboBoxPalette.Clear
    Dim CSPalette As Palette
    For Each CSPalette In Application.Palettes
        ComboBoxPalette.AddItem CSPalette.Name
    Next CSPalette
End Sub


' ********************
' COLORSWATCH CREATION
' ********************

Private Function ValidateParams() As Boolean
    ValidateParams = True
    
    PrinterName = BoxPrinter.Value
    DatePrinted = BoxDate.Value
    If CheckOutline.Value = True Then
        CSOutline = cdrOutline
    Else
        CSOutline = cdrNoOutline
    End If
    
    If (IsNumeric(BoxSpace.Text) = False) Then GoTo ErrNumSpace
    TileSpaceW = Val(BoxSpace.Text)
    TileSpaceH = Val(BoxSpace.Text)
    If TileSpaceH < LEGENDHEIGHT Then TileSpaceH = LEGENDHEIGHT
    
    If ComboBoxPalette.TextLength = 0 Then GoTo ErrNoSelect
    On Error GoTo ErrPaletteName
    Set CSPalette = Application.Palettes(ComboBoxPalette.Text)
    
    Exit Function
    
ErrNoSelect:
    MsgBox "No palette selected"
    ComboBoxPalette.SetFocus
    ValidateParams = False
    Exit Function
ErrPaletteName:
    MsgBox "Invalid palette name : " & ComboBoxPalette.Text
    ComboBoxPalette.SetFocus
    ValidateParams = False
    Exit Function
ErrNumSpace:
    MsgBox "Spacing not numeric : " & BoxSpace.Text
    BoxSpace.SetFocus
    ValidateParams = False
    Exit Function

End Function

Private Sub CreateColorSwatchFromPalette()
    ' Create a new document
    Dim CSDocument As Document
    Dim CSPage As Page
    Set CSDocument = Application.CreateDocument
    Set CSPage = CSDocument.ActivePage
    CSDocument.Unit = cdrMillimeter

    ' Set working values
    
    Dim PageWidth, PageHeight As Double
    PageHeight = CSDocument.ActivePage.SizeHeight
    PageWidth = CSDocument.ActivePage.SizeWidth
    
    Dim TileH, TileW As Double
    Dim ThumbnailH, ThumbnailW As Double
    ThumbnailH = THUMBNAILHEIGHT
    ThumbnailW = THUMBNAILWIDTH
    TileH = ThumbnailH + TileSpaceH
    TileW = ThumbnailW + TileSpaceW
    If TileH > PageHeight Then TileH = PageHeight - 1
    If TileW > PageWidth Then TileW = PageWidth - 1
    If TileW < LEGENDWIDTH Then TileW = LEGENDWIDTH
    
    Dim LineLength As Long, ColumnLength As Long, PageSize As Long
    LineLength = PageWidth \ TileW
    ColumnLength = (PageHeight \ TileH) - 1 ' Save room for header
    PageSize = LineLength * ColumnLength
    
    If LineLength < 1 Or ColumnLength < 1 Then
        MsgBox "Failed to create the colorswatch. Reduce thumbnail spacing or change the page size."
        Exit Sub
    End If
    
    Dim MarginLeft, MarginBottom As Double
    MarginLeft = (PageWidth Mod TileW) / 2
    MarginBottom = (PageHeight Mod TileH) / 2
    
    CSDocument.DrawingOriginX = MarginLeft - (PageWidth / 2)
    CSDocument.DrawingOriginY = MarginBottom + (ColumnLength * TileH) - (PageHeight / 2)
    
    ' Initialize variables
    Dim CSColor As Color
    Dim CSLayer As Layer
    Dim CSShape As Shape
    'zpos penomoran halaman
    Dim XPos As Long, YPos As Long, ZPos As Long
    Dim ShapeLeft As Double, ShapeBottom As Double
    Dim RefCenter As Double
    Dim CSText As String
    XPos = -1   ' column
    YPos = -1   ' line
    ZPos = 0    ' page

    Application.Optimization = True
    ' Create tiles
    For Each CSColor In CSPalette.Colors
        ' Set the new position
        XPos = (XPos + 1) Mod LineLength
        If XPos = 0 Then
            ' Start a new line
            YPos = (YPos + 1) Mod ColumnLength
            If YPos = 0 Then
                ' Start a new page
                ZPos = ZPos + 1
                If CSDocument.Pages.Count < ZPos Then
                    Set CSPage = CSDocument.AddPages(1)
                End If
                Set CSLayer = CSPage.ActiveLayer
                
                ' Create the page header
                ShapeLeft = 0
                RefCenter = (PageWidth / 2) - MarginLeft

                ' page number
                ShapeBottom = MarginBottom + TEXTSPACING
                CSText = "page " & ZPos
                Set CSShape = CSLayer.CreateArtisticText(RefCenter, ShapeBottom, CSText, , , TEXTFONT, 10, Alignment:=cdrCenterAlignment)
                ' palette name
                ShapeBottom = ShapeBottom + CSShape.SizeHeight + TEXTSPACING
                CSText = CSPalette.Name
                If Len(CSText) > 0 Then
                    Set CSShape = CSLayer.CreateArtisticText(RefCenter, ShapeBottom, CSText, , , TEXTFONT, 20, Alignment:=cdrCenterAlignment)
                End If

                End If
            End If

        ' Create the tile
        RefCenter = (XPos + 0.5) * TileW
        
        ' Create thumbnail
        ShapeLeft = RefCenter - ThumbnailW / 2
        ShapeBottom = -(YPos * TileH) - ThumbnailH
        Set CSShape = CSLayer.CreateRectangle2(ShapeLeft, ShapeBottom, ThumbnailW, ThumbnailH)
        CSShape.Outline.Type = CSOutline
        CSShape.Fill.UniformColor = CSColor
'        AlignHorizontal CSShape, RefCenter, CSDocument
        ' Create color components
        ShapeBottom = ShapeBottom - TEXTSPACING
        MakeColorComponentsString CSText, CSColor
        If Len(CSText) > 0 Then
            Set CSShape = CSLayer.CreateArtisticText(RefCenter, ShapeBottom, CSText, , , TEXTFONT, 6, Alignment:=cdrCenterAlignment)
        End If
        ' Create color name
        ShapeBottom = ShapeBottom - TEXTSPACING
        CSText = CSColor.Name(False)
        If Len(CSText) > 0 Then
            Set CSShape = CSLayer.CreateArtisticText(RefCenter, ShapeBottom, CSText, , , TEXTFONT, 6, Alignment:=cdrCenterAlignment)
        End If
    
    Next CSColor

    ' Create the ColorSwatch tag
    Set CSLayer = CSDocument.Pages(1).ActiveLayer
    ShapeLeft = MarginLeft
    ShapeBottom = MarginBottom + TEXTSPACING
    ' Printer Name
    If frmColorSwatch.CheckPrinter.Value = True Then
        Set CSShape = CSLayer.CreateArtisticText(ShapeLeft, ShapeBottom, "Printer : " & PrinterName, , , TEXTFONT, 10)
        ShapeBottom = ShapeBottom + CSShape.SizeHeight + TEXTSPACING
    End If
    ' Date Printed
    If frmColorSwatch.CheckDate.Value = True Then
        Set CSShape = CSLayer.CreateArtisticText(ShapeLeft, ShapeBottom, "Date : " & DatePrinted, , , TEXTFONT, 10)
    End If
    
    Set CSColor = Nothing
    Set CSShape = Nothing
    Set CSLayer = Nothing
    Set CSPage = Nothing
    Set CSDocument = Nothing
    
    Application.Optimization = False
    ActiveWindow.Refresh
    Application.Refresh
End Sub

Private Sub AlignHorizontal(ShapeObj As Shape, Ref As Double, Doc As Document)
    Doc.ReferencePoint = cdrBottomLeft
    Dim ShapeCenter As Double
    ShapeCenter = ShapeObj.PositionX + (ShapeObj.SizeWidth / 2)
    ShapeObj.Move (Ref - ShapeCenter), 0
End Sub

Private Sub MakeColorComponentsString(ByRef StrColor As String, ClrColor As Color)
    Dim PantoneFindPos As Long
    
    If Len(StrColor) = 0 Then
        StrColor = "-"
    ElseIf ClrColor.Type = cdrColorSpot Or ClrColor.Type = cdrColorPantone Then
        StrColor = "Tint:" & ClrColor.Tint
    Else
        StrColor = ClrColor.Name(True)
        PantoneFindPos = InStr(1, StrColor, " Density:", vbTextCompare)
        If PantoneFindPos > 0 Then
            StrColor = "Tint:" & Mid(StrColor, PantoneFindPos + 9)
        End If
    End If
End Sub
Share This :
Agung Panduan

9 Comments

  1. Fitrah Ramadhani4 November 2018 15.26

    Wihh.. Ini Nih Yang Saya Butuhin Buat Tugas Graphic Design

    Visit Balik Ya
    www.friendzone.site

    BalasHapus
  2. Kata Kopi4 November 2018 21.12

    Wih keren ni ..yg saya cari ni kulagamezo.com

    BalasHapus
  3. Rizal Abdillah4 November 2018 21.17

    Wah akhirnya nemu tutorialnya, btw kalo adobe illustrator bisa kah min?

    BalasHapus
  4. Bustomi Azzaini4 November 2018 23.21

    Mantap lanjut tutor min

    BalasHapus
  5. Neangan Bitcoin5 November 2018 01.52

    Mantap nih... Cocok buat ane yg lagi belajar desain vector...

    BalasHapus
  6. eka ulia20 November 2018 19.47

    Lengkap, mantap!! 👍

    BalasHapus
  7. wahyudimana26 Agustus 2019 02.17

    link rusak ya gan? tolong diperbaiki min

    BalasHapus
    Balasan
    1. Amran27 Agustus 2019 08.22

      link sudah saya perbaiki..silahkan dicoba lagi

      Hapus
Langganan: Posting Komentar (Atom)