Corel FORUM
Forum użytkowników programów firmy Corel. Grafika wektorowa, rastrowa i obróbka zdjęć cyfrowych

Makra - Wyszukaj obiekty z określonym kolorem konturu i usuń je

Franiu - 13 Sierpień 2015, 11:48
Temat postu: Wyszukaj obiekty z określonym kolorem konturu i usuń je
Witam;

Mam taki trywialny problem (tak mi się przynajmniej wydaje), ale niestety przeszukując fora niestety nie znalazłem odpowiedzi, a sam z VBA jestem za duża noga, aby sobie z tym poradzić.

Potrzebuje makra pod X5, które będzie wyszukiwało wszystkie obiekty mające określony kolor konturu w cmyk, rozgrupowywało je (większość z nich znajduje się bowiem w jakiś grupach), a następnie je kasowało.

PS
Przez lata używaliśmy w firmie CDR 9 i polecenia ZNAJDŹ I ZAMIEŃ z zapisanymi ustawieniami, które dawało się ustawić w menu programu jako osobne ikony i działało to pięknie. Niestety potem przerzuciliśmy się na X4, a teraz na X5 i tam niestety nie da się zapisanych poleceń ZNAJDŹ I ZAMIEŃ wyciągnąć na pasek menu. Trzeba od cholery się naklikać, aby takie polecenie uruchomić stąd też pomysł na makro które bez problemu da się wyciągnąć na pasek menu.

Z góry dzięki za pomoc.

Franiu

Shame - 13 Sierpień 2015, 20:03

Franiu napisał/a:
Trzeba od cholery się naklikać, aby takie polecenie uruchomić


Z tego co wiem, można parametry szukania zapisać do późniejszego wgrania ich w wyszukiwarkę. Raz ustawisz, zapiszesz i wtedy odpalenie takiego szukania o określonych parametrach to 3 kliknięcia.

Niestety, nie da się wyciągnąć tej opcji zparametryzowanej (żeby ładowała określone, zapisane parametry wyszukiwania) :-/

Franiu - 13 Sierpień 2015, 21:54

Shame napisał/a:
to 3 kliknięcia


No właśnie nie do końca 3. CTRL+F -> Załaduj ustawienia wyszukiwania z dysku -> Wskazanie pliku (parę ich mamy więc trzeba chwilkę poszukać) -> Zakończ -> Znajdź wszyskie -> Czy chesz rozdzilić grupy? (Tak) -> Zamknięcie okna - > Delete

Niby nie dużo, ale jak się to robi kilkadziesiąt razy dziennie to można lekko się zirytować. Dlatego pomysł, aby załatwić to jednym kliknięciem makra...

chezare - 14 Sierpień 2015, 22:05

Żeby skasować obiekt w grupie wcale nie trzeba tej grupy rozdzielać, to raz.
Dwa, gdzieś na forum jest makro które chyba włączało nadrukowanie dla czarnego, tam jest fragment który szuka koloru, można go zmodyfikować.
Przy okazji, może ktoś nie wie :-) żeby zaznaczyć obiekt zgrupowany z innymi wystarczy wcisnąć ctrl.

tomek123 - 2 Październik 2015, 19:21

Kod:

Public Sub Del_CMYK_outline()
Dim s_all As ShapeRange, s_target As ShapeRange, quest As String, i As Integer
v_col = Array("Cyan", "Magenta", "Yellow", "Kadm")
v_param = Array(0, 0, 0, 0)
For i = LBound(v_col) To UBound(v_col)
Do
v_param(i) = InputBox("Podaj wartość koloru " & v_col(i) & " [0-100]:", v_col(i), v_param(i))
Loop While v_param(i) < 0 And v_param(i) > 100
Next i
Set s_all = ActiveDocument.ActivePage.ActiveLayer.Shapes.all
quest = "@outline.color = cmyk(" & v_param(0) & "," & v_param(1) & "," & v_param(2) & "," & v_param(3) & ")"
Set s_target = s_all.Shapes.FindShapes(query:=quest)
s_target.Delete
End Sub


:roll:

Franiu - 2 Październik 2015, 23:51

Dzięki serdecznie, ale niestety po uruchomieniu (wklejeniu kodu do Global Macros-Modules-CorelMacros) makro się wykrzacza na 3 linii i dostaje komunikat: compile error: VAriable not definied :cry:
tomek123 - 4 Październik 2015, 12:19

Masz włączoną opcję Option Explicit -> wpis na samej górze modułu, to dobre ale czasami denerwujące. Albo ją wyłącz w opcjach albo zadeklaruj zmienne jak poniżej:
Kod:

Public Sub Del_CMYK_outline()
Dim s_all As ShapeRange, s_target As ShapeRange, quest As String, i As Integer, v_col As Variant, v_param As Variant
v_col = Array("Cyan", "Magenta", "Yellow", "Kadm")
v_param = Array(0, 0, 0, 0)
For i = LBound(v_col) To UBound(v_col)
Do
v_param(i) = InputBox("Podaj wartość koloru " & v_col(i) & " [0-100]:", v_col(i), v_param(i))
Loop While v_param(i) < 0 And v_param(i) > 100
Next i
Set s_all = ActiveDocument.ActivePage.ActiveLayer.Shapes.all
quest = "@outline.color = cmyk(" & v_param(0) & "," & v_param(1) & "," & v_param(2) & "," & v_param(3) & ")"
Set s_target = s_all.Shapes.FindShapes(query:=quest)
s_target.Delete
End Sub

Franiu - 5 Październik 2015, 10:46

Ooo teraz super działa. Nie potrzebuje tylko okienka z pytaniem o konkretny kolor bo wartość tą na sztywno podaje już w samym makro. Zmieniłem sobie to na poniższy sposób, pewnie mało elegancko ale działa. :)

Kod:

Public Sub Del_CMYK_outline1()
Dim s_all As ShapeRange, s_target As ShapeRange, quest As String, i As Integer, v_col As Variant, v_param As Variant
v_col = Array("Cyan", "Magenta", "Yellow", "Kadm")
v_param = Array(0, 0, 0, 0)
For i = LBound(v_col) To UBound(v_col)
Do
' v_param(i) = InputBox("Podaj wartość koloru " & v_col(i) & " [0-100]:", v_col(i), v_param(i))
Loop While v_param(i) < 0 And v_param(i) > 100
Next i
Set s_all = ActiveDocument.ActivePage.ActiveLayer.Shapes.All
quest = "@outline.color = cmyk(0,0,0,100)"
Set s_target = s_all.Shapes.FindShapes(query:=quest)
s_target.Delete
End Sub


Mam jeszcze jedną prośbę o inne makro, skoro z tym tak ładnie się udało. :) Z góry dzięki.

Myślę, że załatwi to ten sam kod tylko pojawią się ze dwie dodatkowe linijki. Chodzi o to, żeby wyszukiwało określony (na sztywno wpisany w makro) kolor konturu CMYK (czasem w grupach, czasem nie - czyli identyczne założenie jak w Del_CMYK_outline) i zamiast usuwać to zamieniać na inny kolor ten wyszukany kontur (inny konkretny CMYK, sztywno określony w makro). Na końcu powinny się wszystkie obiekty zaznaczać i odbijać lustrzanie w poziomie (robić lewoczytelny rysunek).

tomek123 - 5 Październik 2015, 16:41

Kod:

Public Sub CMYK_outline_change_flip()
Dim s As Shape, s_all As ShapeRange, s_target As ShapeRange, quest As String
Set s_all = ActiveDocument.ActivePage.ActiveLayer.Shapes.all
quest = "@outline.color = cmyk(0,50,50,0)" 'kolor konturu szukany
Set s_target = s_all.Shapes.FindShapes(query:=quest)
For Each s In s_target
s.Outline.Color.CMYKAssign 0, 0, 0, 100 'nowy kolor konturu
Next s
s_all.Flip 1 'odbicie lustrzane
End Sub

Franiu - 5 Październik 2015, 18:56

Super, działa!!! Dzięki jak nie wiem co. Jak mogę się odwdzięczyć, bo pół życia życia przy corelu właśnie mi oszczędziłeś. :-P
tomek123 - 6 Październik 2015, 02:28

Świetnie, cieszę się, jak będziesz miał jeszcze jakiś problem w Corelu z automatyzacją, to zapodaj, lubię czasami takie zadanka do rozruszania, dla przypomnienia VBA, bo ostatnio nie mam z tym do czynienia. pozdr
Franiu - 16 Październik 2015, 16:50

A mam jeszcze jedną malutką prośbę. Znowu kompilacja tego co już było, ale z inną końcówką (myślałem, że poradzę sobie sam, ale niestety poległem). ;-)

Znajdujemy obiekty z określonym kolorem konturu w cmyku (tak jak wcześniej, kolor na sztywno wpisany w makro). Grupujemy je. Zaznaczamy tą grupę (tak jak kliknięcie myszą).

tomek123 - 18 Październik 2015, 22:23

Kod:
Public Sub CMYK_outline_select()
Dim s_all As ShapeRange, s_target As ShapeRange, quest As String
Set s_all = ActiveDocument.ActivePage.ActiveLayer.Shapes.all
quest = "@outline.color = cmyk(0,50,50,0)" 'kolor konturu szukany
Set s_target = s_all.Shapes.FindShapes(query:=quest)
s_target.Group
s_target.CreateSelection
End Sub

Franiu - 21 Październik 2015, 00:02

Super! Dzięki ponownie jak nie wiem co!
Franiu - 13 Listopad 2015, 19:09

Czym bardziej wgłębiam się w temat makr tym bardziej widzę ile ich jeszcze by się przydało do optymalizacji mojej pracy. Jeszcze takie rzeczy bardzo by mi się przydały (głupio mi znowu prosić o pomoc więc może podeślij nr konta na priva to uczynię jakiś datek, bo dzięki Twojej pomocy oszczędziłem już na prawdę dużo czasu - a jak wiadomo czas to pln ) :-)

MAKRO 1: ustawia domyślne pióro konturu dla opcji rysunek (czyli tak jak klikniemy na narzędzie PIÓRO KONTURU nie mając zaznaczonego żadnego obiektu) o parametrach: szerokość 6 mm, zakończenia zaokrąglone, konkretny kolor w cmyk podany na sztywno w makro

MAKRO 2: powraca do normalnych wartości domyślnego pióra konturu (czyli to samo co wyżej tylko dla standardowych parametrów corela): szerokość 0,2 mm, kolor czarny cmyk 0,0,0,100, zakończenia bez zaokrągleń

MAKRO 3: zmiana właściwości zaznaczonego konturu na grubość w mm, którą podajesz w wyskakującym okienku Msg (domyślnie powinna być podana wartość 3 mm), zmiana koloru na cmyk na sztywno podany w makro, opcja przezroczystości tego konturu: standardowa, normalna 50%

MAKRO 4: zmiana nazwy zaznaczonych przez użytkownika obiektów na nazwę: ObiektXYZ

To ostatnie makro udało mi się nawet nagrać i działa, ale niestety jeżeli zapomnę zaznaczyć chociaż jeden obiekt to wywala mi całego corela (dosyć niebezpieczne jeżeli się wcześniej nie zapisze pliku :) )

Kod:

    Sub Zamiana_nazwy_ObiektXYZ()

    Dim OrigSelection As ShapeRange
    Set OrigSelection = ActiveSelectionRange
    ActiveSelection.ObjectData("Nazwa").Value = "ObiektXYZ"

End Sub

chezare - 14 Listopad 2015, 01:52

Niebezpieczne może być nawet jak zapiszesz plik. :-)
Można sprawdzić czy jakiś obiekt jest zaznaczony, można sprawdzić ile ich jest zaznaczonych.
Kod:
If ActiveSelectionRange.Count = 0 then goto koniec
. . . . .
koniec:
End Sub


Można też obsłużyć ewentualne błędy, jedna z takich konstrukcji, jest ich wiele, poczytaj w pomocy, wygląda praktycznie identycznie jak polecenie wyżej omijające część kodu.

Kod:
On Error goto koniec
One Error Resume Next


itd., itp.
Oczywiście coś takiego powinno być przed poleceniami, które mogą wykoleić procedurę.

Z konturem to sprawa wygląda na dosyć prostą, tylko ja bym nie podczepiał tego pod oryginalne narzędzie.
Jak się nikt nie odezwie to jutro może coś wymyślę, albo może sam pokombinuj? :-)

Kod:
ActiveSelection.Outline.SetProperties 0.236, OutlineStyles(0), CreateCMYKColor(0, 100, 100, 0)

Coś takiego np. ustawia grubość konturu, rodzaj na linię ciągłą i kolor (w tym przypadku czerwony).

chezare - 14 Listopad 2015, 17:24

Na razie nie mam pojęcia jak zmienić domyślne ustawienia dla nieistniejących jeszcze obiektów, na pewno się da to zrobić, ale wykombinowałem sposób, jak ten brak wiedzy obejść. :-)
To jest wykorzystanie mechanizmu, który w Corelu znajduje się w Opcje->Dokument.

Jeśli otworzysz nowy dokument i np. klikniesz narzędzie Text Tool, zmienisz font, jego wielkość to otworzy Ci się okienko w którym zostaniesz zapytany czy ustawienia mają zostać zastosowane dla tekstu akapitowego czy artystycznego. Od tej pory narzędzie Text Tool będzie działało z wprowadzonymi wcześniej ustawieniami.
Podobnie jest w innych przypadkach. Jeśli bez zaznaczania jakiegokolwiek obiektu klikniesz prawym przyciskiem gryzonia w jakiś kolor, to program znowu zapyta czy taki kolor konturu ma być stosowany dla grafiki czy tekstu akapitowego lub artystycznego. Jeśli wybrałeś np. Graphic, to wszystkie obiekty tego typu które będziesz od tej pory rysował będą miały kolor konturu który wcześniej wybrałeś. W taki sposób możesz też oczywiście zmienić domyślne parametry konturu, jego grubość, kolor i zakończenia.
Jeśli po tej operacji zaznaczysz opcję, którą ja zaznaczyłem na obrazku wyżej i zapiszesz dokument to każdy nowy, nawet po zamknięciu Corela będzie korzystał z tych ustawionych wartości. To co wykombinowałem działa podobnie, ale nie zmienia ustawień na stałe.
Istnieje polecenie które nazywa się SaveStyleSheet, zapisuje ono ustawienia do pliku.
Jeśli ustawisz sobie właściwości konturu

przejdziesz do edytora VBA (alt+F11) i uruchomisz makro
Kod:
Sub zapisz_kontur()
Application.ActiveDocument.SaveStyleSheet ("c:\kontur_6mm_zielony")
End Sub

to na dysku C: zapisze Ci się plik kontur_6mm_zielony
Teraz musisz utworzyć makro, które będzie dostępne z dowolnego dokumentu i które powinno wyglądać tak
Kod:
Sub kontur_6mm_zielony()
On Error Resume Next
Application.ActiveDocument.LoadStyleSheet ("c:\kontur_6mm_zielony")
End Sub

On error jest na wypadek gdyby pliku nie było.
Uruchomienie takiego makra spowoduje przeczytanie ustawień z wcześniej zapisanego pliku, każda linia, każda figura będzie miała teraz zielony 6 mm kontur i okrągłe zakończenia linii.
Drugi plik ze standardowymi ustawieniami pozwoli Ci zmienić zmodyfikowany kontur na taki jaki jest standardowo.
Odnośnie 3, to ja nie widzę za bardzo w tym co chcesz osiągnąć sensu, bo przecież jak masz zaznaczoną figurę, to wystarczy wpisać wartość w okienku dotyczącym grubości konturu, ale to jest akurat najłatwiejsze do zrealizowania.
MsbBox służy do wyświetlania informacji, pewnie miałeś na myśli InputBox? Nie wiem też o co chodzi z przeźroczystością, w moim zabytkowym Corelu kontur takiej właściwości nie ma.
Kod:
Sub ustaw_kontur()
Dim gr As Double
If ActiveSelectionRange.Count = 0 Then GoTo koniec
Application.ActiveDocument.Unit = cdrMillimeter
gr = InputBox("Wpisz grubość konturu", "KONTUR", "3")
ActiveSelection.Outline.SetProperties gr, OutlineStyles(0), CreateCMYKColor(0, 0, 0, 100)
koniec:
End Sub


Koledzy pewnie wymyślą coś bardziej sensownego, bo moja wiedza na temat Corelowego VBA, hierarchii obiektów, metod, właściwości, itp. ogranicza się do wciśnięcia klawisza F1. :-)

Franiu - 16 Listopad 2015, 12:01

Wow! Wszystko pięknie działa.

MAKRO 1 i 2: bardzo dobry pomysł z wczytywaniem tych ustawień. Utworzyłem sobie dwa pliki, podpiąłem pod makra i śmiga.

MAKRO 3: faktycznie przejęzyczyłem się z tym okienkiem Msg (chodziło oczywiście o Inputbox :) ). Makro niby proste, ale jak się wykonuje codziennie 500x to samo to zmniejszenie 5 kliknięć do 1 oszczędza godzinę. Jeśli chodzi o przezroczystość to faktycznie we wcześniejszych wersjach nie można było jej użyć do konturu (sprawdzałem w 9). W X5 bez problemu działa i bardzo mi tu jest potrzebne. Nagrałem sobie tą operację i po doklejeniu do Twojego makro wszytko śmiga, aż miło:


Kod:
    Set OrigSelection = ActiveSelectionRange
    With ActiveSelection.Transparency
        .ApplyUniformTransparency 50
        .AppliedTo = cdrApplyToFillAndOutline
        .MergeMode = cdrMergeNormal
       
        End With


MAKRO 4: dokleiłem podany warunek i nic się już nie wywala jak nie zaznaczę obiektu przed wykonaniem makra

Słowo się rzekło więc czas na podzielenie się zyskiem z oszczędzonego czasu. Podeślij na priva konto, to cosik sypnę. :mrgreen: [/code]

chezare - 16 Listopad 2015, 15:59

Franiu, jak chcesz komuś pomóc, to znajdziesz sposób i kogoś komu Twoja pomoc się przyda, ja, a jestem pewien, że znakomita większość kolegów również, nie zaglądamy tu żeby zarobić parę groszy. Przyznam się. Robię to z egoistycznych pobudek, sprawia mi przyjemność kiedy uda mi się komuś pomóc. Nie wiem, może to jakieś zboczenie? :-)
Franiu - 16 Listopad 2015, 16:09

Dziękuje więc serdecznie :poklon

Mało ludzi podobnie myślących zostało jeszcze na naszym łez padole, ale nieskromnie powiem że też jestem człowiekiem starej daty i staram się jak mogę nie ulec nowym trendom rynkowym. :)

Franiu - 18 Listopad 2015, 16:08

Myślałem, że to już koniec, ale jednak nie. :) Jeszcze jedna potrzeba się zrodziła (apetyt rośnie w miarę jedzenia). :)

MAKRO 5: szuka obiektów posiadających określoną nazwę w menadżerze obiektów np: okiektXYZ i grupuje je

MAKRO 6: szuka obiektów posiadających określoną nazwę w menadżerze obiektów np: okiektXYZ i usuwa je

chezare - 18 Listopad 2015, 23:59

Może tak?

Kod:
Sub SZUKAJ_NAZWY()
Dim s As Shape
Dim odp
Dim gr As ShapeRange
Dim naz As String
On Error Resume Next
Optimization = True
naz = InputBox("Wpisz nazwę", "SZUKAJ", "ObiektXYZ")
    If naz = "" Then
    MsgBox "Musisz coś wpisać&#8230;"
    GoTo koniec
    End If
        Set gr = ActivePage.Shapes.All.UngroupAllEx
        ActiveDocument.ClearSelection
For Each s In ActivePage.Shapes
    If s.ObjectData("Nazwa").Value = naz Then
     s.AddToSelection
    End If
Next s
If ActiveSelection.Shapes.Count <> 0 Then
    ActiveSelection.Group
    odp = MsgBox("Usunąć zaznaczone?", vbYesNo, "Objects")
    If odp = vbYes Then ActiveSelection.Delete
End If
koniec:
Optimization = False
ActiveWindow.Refresh
End Sub


To działa tak, że najpierw się pyta o szukaną nazwę, domyślnie taką jak wcześniej chciałeś,
później rozdziela wszystkie grupy, jeśli jakieś oczywiście są i robi tak, żeby nic nie było zaznaczone.
To po to, żeby w kolekcji zaznaczonych obiektów nie znalazł się taki, który był zaznaczony przed
uruchomieniem procedury.
Na końcu jeśli coś zostało znalezione, to pyta się czy skasować. Odpowiedź negatywna
kończy procedurę pozostawiając zaznaczone i zgrupowane, znalezione obiekty które spełniają
warunek (konkretna nazwa we właściwościach).

Wcześniej coś Ci się wykolejało kiedy nic nie było zaznaczone, w tej procedurze jest taki fragment, który taką okoliczność bada:
If ActiveSelection.Shapes.Count <> 0 Then
Jak byś miał coś takiego:

if activeselection.shapes.count=0 then goto koniec


koniec:
end sub
to i bez obsługi błędów by Ci się nie wykolejało.

Franek, tylko zrób jakieś próby zanim stanie się nieszczęście, bo ja to piszę wciskając dwadzieścia razy na minutę klawisz F1 i żadnej gwarancji że coś nie wybuchnie nie daję. :-)

Myślę, że jak już masz parę tych wynalazków których używasz, to można by je zebrać do kupy zrobić jakiś formularz i wybierać z listy, albo klikając w jakiś konkretny przycisk?
Tak to Ci się za chwilę zrobi śmietnik.

Zrobiłem taki przykładowy plik, musisz go wypakować do katalogu gdzie jest zainstalowany Corel …\DRAW\GMS. Po uruchomieniu Corela na liście z makrami będziesz miał to które jest wyżej, ale uruchamiane z formularza.

Franiu - 20 Listopad 2015, 13:04

Bardzo fajne to co napisałeś, ale do mojego użytku ciut za bardzo skomplikowane. Wolałbym jednak każde makro osobno. :)

Makra podpinam sobie pod ikony, które sam rysuje i mam do nich wtedy szybki dostęp (nie muszę wywoływać osobnego formularza, który też chwilkę zajmuje nie mówić o miejscu na ekranie).

Myślałem, że sam przerobie Twój kod niestety poległem (to o co prosiłem miało być częścią większej procedury, teraz opisuje całość od A-Z).

MAKRO 5 (cała procedura): szuka obiektów posiadających określoną nazwę ObiektXYZ (nazwa na sztywno w kodzie makro, a nie podawaną w inboxie), grupuje je (chyba to grupowanie nie jest potrzebne - wydawało mi się wcześniej, że następnego kroku nie da się wykonać bez tego, a jednak jak przed chwilą próbowałem to i bez grupowania też działa), zamienia kontury znalezionych obiektów w kontury (polecenie PRZEKSZTAŁĆ KONTUR W OBIEKT -CTRL+PRZESUNIĘCIE+Q), zmienia wypełnienia znalezionych obiektów na przezroczyste, zmienia kontury znalezionych obiektów na CMYK 1,0,0,100 , zmienia grubość znalezionych obiektów na 0,71 mm

MAKRO 6: szuka obiektów posiadających określoną na sztywno w kodzie makro nazwę ObiektXYZ i usuwa je

chezare - 20 Listopad 2015, 15:38

To teraz ja mam kilka pytań.
Przyjmijmy, że w dokumencie jest ileś obiektów, które we właściwościach mają pole Nazwa i przypisaną do niego wartość ObiektXYZ.
Co robi zamiana konturu w obiekt? Ano rysuje nową figurę, jak mamy dajmy na to odcinek, to po wykonaniu tego polecenia otrzymujemy prostokąt. To samo można uzyskać rozłączając jakiś węzeł w zamkniętej figurze i dodając do niej obrys.
Wydaje mi się, że pomyliła Ci się kolejność wykonywanych działań.
Jeśli dobrze kombinuję, to powinno być tak:
1. Szukamy obiektu który w nazwie ma ObiektXYZ
2. W znalezionej figurze ustawiamy kontur na 0,71 mm
3. Zamieniamy kontur na obiekt
4. Zmieniamy kolor wypełnienia na 1/0/0/100, po zamianie w obiekt, nowa figura nie ma konturu.
?


Jeśli chodzi o kasowanie, to procedura niżej powinna załatwić sprawę.

Kod:
Sub Kasuj_ObiektXYZ()
Dim s As Shape
Dim gr As ShapeRange
On Error Resume Next
Optimization = True
Set gr = ActivePage.Shapes.All.UngroupAllEx
ActiveDocument.ClearSelection
    For Each s In ActivePage.Shapes
        If s.ObjectData("Nazwa").Value = "ObiektXYZ" Then s.Delete
    Next s
Optimization = False
ActiveWindow.Refresh
End Sub



Jeśli chodzi o pierwsze zadanie i ma być tak jak wykombinowałem, to będzie tak jak niżej.
Procedura kasuje figury, których kontur został zamieniony w obiekt (te które mają w Nazwa, ObiektXYZ), po wykonaniu procedury na stronie nie będzie już figur które mają w nazwa ObiektXYZ. Jeśli mają zostać, to trzeba wywalić kasowanie (s.delete).

Kod:
Sub kontur_w_obiekt()
Dim s As Shape
Dim gr As ShapeRange
On Error Resume Next
Optimization = True
Set gr = ActivePage.Shapes.All.UngroupAllEx
ActiveDocument.ClearSelection
    For Each s In ActivePage.Shapes
        If s.ObjectData("Nazwa").Value = "ObiektXYZ" Then
        s.Outline.SetProperties 0.027983, OutlineStyles(0)
        s.Outline.ConvertToObject
        s.Fill.ApplyUniformFill Color:=CreateCMYKColor(1, 0, 0, 100)
        s.Delete
        End If
    Next s
Optimization = False
ActiveWindow.Refresh
End Sub



PS
Nie zapominaj, że to nie jest programowanie wysokich lotów. :-)
Zakładaj hełm i rób kopie dokumentów.

Franiu - 23 Listopad 2015, 12:46

A więc tak...

MAKRO 6 (kasujące): super ok, dziękuje :)

MAKRO 5 (szukające, przekształcające): no nie do końca jak Ty piszesz... :)

Generalnie wszystkie obiekty posiadające nazwę ObiektXYZ są specyficzne. Są to zawsze otwarte krzywe (nie żadne kwadraty, kółka lub inne figury) posiadające dużą grubość ok. 10-20 mm i określony kolor tego konturu, To co ma robić makro to znajdować je i robić je przezroczyste z czarną obwódką dookoła.

Po to nam to jest, że te przekształcone makrem obiekty idą do druku na ploter gdzie zależy nam na oszczędności atramentu (zwykłe szablony produkcyjne) wiec nie chcemy drukować grubaśnych krech, a jedynie ich czarno-białe kontury. :mrgreen:

A więc moja poniższa kolejność jest jak najbardziej oki.

Szuka obiektów posiadających określoną nazwę ObiektXYZ (nazwa na sztywno w kodzie makro, a nie podawaną w inboxie), grupuje je (chyba to grupowanie nie jest potrzebne - wydawało mi się wcześniej, że następnego kroku nie da się wykonać bez tego, a jednak jak przed chwilą próbowałem to i bez grupowania też działa), zamienia kontury znalezionych obiektów w kontury (polecenie PRZEKSZTAŁĆ KONTUR W OBIEKT -CTRL+PRZESUNIĘCIE+Q), zmienia wypełnienia znalezionych obiektów na przezroczyste, zmienia kontury znalezionych obiektów na CMYK 1,0,0,100 , zmienia grubość znalezionych obiektów na 0,71 mm

tomek123 - 24 Listopad 2015, 04:49

Kod:
Public Sub FindNamedShapesAndSCurveJJE()
Dim x1#, x2#, y1#, y2#, nazwa$, kw!, _
s As Shape, s2 As Shape, sr As ShapeRange, st As ShapeRange, colArea As New Collection
nazwa = "ObiektXYZ"
Optimization = True: With ActiveDocument: .Unit = cdrMillimeter: .ReferencePoint = cdrTopLeft: End With
Set sr = ActiveLayer.Shapes.All: sr.UngroupAll: Set st = sr.Shapes.FindShapes(name:=nazwa, recursive:=True)
For Each s In st
kw = s.Outline.width: kw = 2 * kw + 0.1
x1 = s.PositionX - kw: y1 = s.PositionY + kw: x2 = s.PositionX + s.SizeWidth + kw: y2 = s.PositionY - s.SizeHeight - kw
v_area = Array(x1, y1, x2, y2): colArea.Add v_area
Next: st.ConvertOutlineToObject
For Each p In colArea
Set s = ActivePage.SelectShapesFromRectangle(p(0), p(1), p(2), p(3), False)
For Each s2 In s.Shapes
With s2: .ConvertToCurves: .name = nazwa: .Outline.Color.CMYKAssign 1, 0, 0, 100: .Outline.width = 0.71: .Fill.ApplyNoFill: End With
Next: Next: Refresh: Optimization = False
End Sub

Jakiego plotera używasz? z pozycjonowaniem optycznym? Nie masz problemów z wycinaniem, może doradzisz jaki ploter kupić, żeby dokładnie wycinał z Corela?!?

Franiu - 24 Listopad 2015, 12:50

Działa! Dzięki jak nie wiem co! Wprawdzie raz udało mi się wywalić Corela podczas testowania, ale nie wiem w sumie dlaczego (początkowo myślałem, że problem występuje jak ObiektXYZ jest w jakieś grupie, ale nie). Pomęczę jeszcze i zobaczymy.

Jeśli chodzi o drukowanie to teraz używam popularnego modelu HP 500 (drukujemy z rolki papieru A0+ tanie szablony produkcyjne, więcej nam nie potrzeba) i sprawdza się w 100%. Tani i szybki, bez problemu drukuje jako zwykła drukarka pod Windowsem 7. Czasami są tylko problemy z chipami nieoryginalnych tuszy. Podobno do rysunków typu CAD najlepszy wybór na rynku (rok temu zapłaciłem za używkę ok. 3000 netto).

Jeśli chodzi o wycinanie to tniemy okazyjnie folię chińczykiem SERONA. Tutaj problemów co niemiara (z corela nie udało nam się ciąć bezpośrednio-używamy dołączonego ArtCut 2009, który chodzi tylko pod Windowsem XP). To tania maszyna za parę tysięcy więc sensacji się nie spodziewaliśmy.

tegraf - 24 Listopad 2015, 13:04

Franiu napisał/a:
Jeśli chodzi o wycinanie to tniemy okazyjnie folię chińczykiem SERONA


SERONA czy SERON? Jaki model?

Franiu - 24 Listopad 2015, 13:08

SERON - http://seron.pl/ . Model z przed paru ładnych lat, jużnie produkowany z tego co wiem - 1250USB . Tak jak pisałem polecam średnio (głównie z powodu problemów z sterownikami i programami do wycinania). To co najważniejsze to folię tnie więc i jeśli do okazyjnego wykorzystania to da się żyć.
tegraf - 24 Listopad 2015, 13:14

Ma on jakiś system rozpoznawania znaczników, coś na kształt OPOS Summy? Masz jakąś instrukcję w pdf?
Franiu - 24 Listopad 2015, 13:19

To ploter rozpoznający instrukcję HPGL, jeśli chodzi o OPOS Summy to nie mam pojęcia co to jest. :) Daj maila na prova to podeśle Ci instrukcję (choć wiele tam nie ma).
tomek123 - 24 Listopad 2015, 16:17

Wychodzi na to, że trzeba porządną sumkę przeznaczyć, żeby mieć dobrą maszynkę do cięcia.... choć słyszałem, że na politechnice studenci wydziałów elektronicznych są w stanie złożyć pod konkretne zamówienie niezły ploterek jaki tylko się wymarzy za max 5k, muszę poszukać kontaktu, jakby ktoś miał to z góry podziękowania. W sumie lepiej wesprzeć swoich niż chińczyków czy amerykańców kreatorów plastikowej tandety;)
Franiu - 25 Listopad 2015, 08:43

No niestety, porządne plotery do cięcia folii zaczynają się od 5k w górę (i to używki). Jeżeli ktoś tnie dużo, to pewnie dokładność takiej maszyny i łatwość obsługi mu się zwrócą. Jeżeli do cięcia od czasu do czasu to moim zdaniem chińczyki też dają radę. Oczywiście jeżeli można mieć to samo złożone w Polsce za podobne pieniądze to też jestem za.
Franiu - 30 Listopad 2015, 15:11

Kod:
Public Sub FindNamedShapesAndSCurveJJE()
Dim x1#, x2#, y1#, y2#, nazwa$, kw!, _
s As Shape, s2 As Shape, sr As ShapeRange, st As ShapeRange, colArea As New Collection
nazwa = "ObiektXYZ"
Optimization = True: With ActiveDocument: .Unit = cdrMillimeter: .ReferencePoint = cdrTopLeft: End With
Set sr = ActiveLayer.Shapes.All: sr.UngroupAll: Set st = sr.Shapes.FindShapes(name:=nazwa, recursive:=True)
For Each s In st
kw = s.Outline.width: kw = 2 * kw + 0.1
x1 = s.PositionX - kw: y1 = s.PositionY + kw: x2 = s.PositionX + s.SizeWidth + kw: y2 = s.PositionY - s.SizeHeight - kw
v_area = Array(x1, y1, x2, y2): colArea.Add v_area
Next: st.ConvertOutlineToObject
For Each p In colArea
Set s = ActivePage.SelectShapesFromRectangle(p(0), p(1), p(2), p(3), False)
For Each s2 In s.Shapes
With s2: .ConvertToCurves: .name = nazwa: .Outline.Color.CMYKAssign 1, 0, 0, 100: .Outline.width = 0.71: .Fill.ApplyNoFill: End With
Next: Next: Refresh: Optimization = False
End Sub


No jednak coś z tym makrem jest nie tak. Wcześniej jak próbowałem na próbnych plikach gdzie na szybko rysowałem kilka obiektów i paru z nich nadawałem nazwę ObiektXYZ i wszytko działało ładnie. Teraz na "prawdziwym" pliku coś się chrzani. Mimo, że tylko kilka obiektów ma nazwę ObiektXYZ to i tak zmienia wszystkie obiekty z pliku.... Da się coś z tym zrobić? Jak dasz na priva maila to może podeśle Ci ten plik to łatwiej się będzie połapać co może być problemem.

tomek123 - 1 Grudzień 2015, 11:46

http://corel.wodip.opole....wprofile&u=6844
Nie wiem, u mnie działa

tegraf - 15 Styczeń 2016, 18:14

Ola80 myśli, że jest sprytna. Jednozdaniowe, nic nie wnoszące wpisy z linkiem.
Shame - 15 Styczeń 2016, 19:35

tegraf, o tym samym pomyślałem. Stają się co raz sprytniejsi. Niedługo nie będziemy mogli rozróżnić ich od prawdziwych ludzi. CA co bedzie jeśli wygenerują osobowość? Albo... duszę? :shock:
tegraf - 15 Styczeń 2016, 20:54

Shame napisał/a:
CA co bedzie jeśli wygenerują osobowość?


A niech to... Zaatakują nas forumowe terminatory!

Na szczęście parę podręczników, jak przeżyć - już sfilmowano: "Terminator" i "Łowca androidów". Czas się zabrać za oglądanie. Zwłaszcza ten drugi.

Cysorz - 15 Styczeń 2016, 23:36

Małe "kuku" zrobione.
Jak będzie powód do większego to zaboli!


Powered by phpBB modified by Przemo © 2003 phpBB Group