Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel (архив)
Страницы: 1 2 След.
RSS
Удаление пустых картинок из прайса
 
#1
03.11.2010 15:18:07
Проблема  в следующем-  выгржаем прайс из 1с  с картинками товаров.На часть товаров  нет фото в базе, и в файле 1С  получаются пустые картинки,  что сильно  увеличивает размер файла.  Ручное удаление  500  пустых картинок  занимает  много времени-  можно -ли  как-то  это сделать   быстро,Помогитек плиз.
 
 
 
#2
03.11.2010 15:47:01
тут как бэ проблема - машинный код с трудом может отличить пустую картинку от непустой, на этом основан сам принцип капчи)
 
 
 
#3
03.11.2010 15:50:18
{quote}{login=Dophin}{date=03.11.2010 03:47}{thema=}{post}тут как бэ проблема - машинный код с трудом может отличить пустую картинку от непустой, на этом основан сам принцип капчи){/post}{/quote}  
Да я то понимаю что размер картинки будет одинаковый,  так  что  считаете  что решения   проблемы нет?
 
 
 
#4
03.11.2010 15:59:51
Пустая картинка весит меньше, чем с рисунком. Может это сможет помочь макросописателям.
 
 
 
#5
03.11.2010 16:01:43
{quote}{login=}{date=03.11.2010 03:59}{thema=}{post}Пустая картинка весит меньше, чем с рисунком.{/post}{/quote} Виноват, поторопился.
 
 
 
#6
03.11.2010 16:26:47
тут можно ход конем.  
1. Сохранить в 2007.  
2. Открыть файл архиватором  
3. Отсортировать по размеру файла  
4. Имена файлов, чей размер меньше положенного выгрузить на лист.  
5. Макросом удалить картинки с этими именами.  
 
Все это ручками и долго, и стоит ли игра свечек неизвестно.  
 
Возможно можно как то получить макросом размер файла, но мне это неведомо) может кто более знающий подскажет.
 
 
 
#7
03.11.2010 16:47:24
"...получить макросом размер файла..."  
 
------------------  
...  
iFullName = "C:\Temp\Test.xls"    
iFileSize = FileLen(iFullName)    
MsgBox "Размер файла составляет : " & iFileSize & " байт", , ""    
...  
------------------
<FONT COLOR="CadetBlue">
 
 
 
#8
03.11.2010 17:18:41
Дмитрий, ума не приложу :)  
Я всего лишь помог Dophin. Или вопрос был адресован не мне? :)
<FONT COLOR="CadetBlue">
 
 
 
#9
03.11.2010 18:45:09
очевидно ко мне, это я лужу в сел, думал имена шейпов и имена картинок идентичны. А оно вон оно как.  
 
Но за функцию определения размера - спасибо, утащил в копилку)
 
 
 
#10
03.11.2010 18:50:03
там вероятно порядковый номер картинки в файле соответствует номеру шейпа,    
image1=picture 1189  
image2=picture 1190  
 
но это хз)
 
 
 
#11
03.11.2010 22:04:53
Можно без 2007, сохранить лист как web-страницу.  
С настройками web по умолчанию, в 2000 получилось следующее:  
 
post_170889_6946_image001.png 1 кб  
post_170889_6946_image002.gif 1 кб  
post_170889_6946_image003.png 14 кб  
post_170889_6946_image004.gif 5 кб  
 
Первые 2 файла относятся к первой картинке, вторые 2 ко второй.  
 
Осталось понять - если картинки раскиданы по листу, как нумеруются файлы? По номеру картинки, или по адресу topleftcell, или... ?
 
 
 
#12
04.11.2010 20:57:39
Доброго времени суток...  
Подумала тут...  
 
Если с помощью макроса на отдельном листе получить "пикселизацию" изображения, примерно вот такую (988 Кб):  
 
http://bbs.vbstreets.ru/download/file.php?id=8593&sid=d2e4896a6d518f45e8604174a34840d1  
 
и посчитать ячейки одинакового цвета (в частности, белые и учитывая, что размер картинок на листе(ах) одинаковый), то можно со 100% вероятностью гарантировать, что картинка пустая и можно ее удалить. И так по всем картинкам по циклам.  
 
Другое дело получить такое, как в ссылке...
 
 
 
#13
05.11.2010 10:48:37
если бы получить несколько больший кусок для опытов.. :)  
 
вот такой макрос выявляет некоторые совпадения(е)  
 
Dim x, i&  
Set x = ActiveSheet.Shapes(1)  
Dim r(1 To 1999, 1 To 1) As Long  
Call CopyMemory(r(1, 1), x, 1999)  
ReDim x(1 To 1999, 1 To 1)  
For i = 1 To 1999  
   x(i, 1) = r(i, 1)  
Next  
[a10].Resize(1999) = x
Set x = ActiveSheet.Shapes(2)  
Call CopyMemory(r(1, 1), x, 1999)  
ReDim x(1 To 1999, 1 To 1)  
For i = 1 To 1999  
   x(i, 1) = r(i, 1)  
Next  
[b10].Resize(1999) = x
Set x = ActiveSheet.Shapes(3)  
Call CopyMemory(r(1, 1), x, 1999)  
ReDim x(1 To 1999, 1 To 1)  
For i = 1 To 1999  
   x(i, 1) = r(i, 1)  
Next  
[c10].Resize(1999) = x
 
 
третья картинка - вставленный пустой прямоугольник из панели рисования иксель..  
 
данные к нему совпадают с пустой картинкой в строке 3 и отличаются от "картинки"
Живи и дай жить..
 
 
 
#14
05.11.2010 11:39:49
да уж, замутил тему, не думал  что все так сложно будет. Буду  пробовать с макросом разобраться.
 
 
 
#15
05.11.2010 11:52:25
а отправьте мне на novikovan mail ru  
 
кусок побольше, чтобы пустых и непустых картинок было штук по пять хотя б
Живи и дай жить..
 
 
 
#16
05.11.2010 14:45:58
{quote}{login=слэн}{date=05.11.2010 11:52}{thema=}{post}а отправьте мне на novikovan mail ru  
 
кусок побольше, чтобы пустых и непустых картинок было штук по пять хотя б{/post}{/quote}  
Отправил.
 
 
 
#17
09.11.2010 13:00:00
вот наваял..  
 
правда файл это не слишком облегчает, так как пустая картинка там только одна хранится и так.  НО заинтересовало само действие..
Живи и дай жить..
 
 
 
#18
09.11.2010 13:17:53
Слэн, респект!  
Правда, на строке  
getsum_clipbrd = WorksheetFunction.Sum(MetaFileBits)  
ошибка "Type mismatch"  
 
Xl2007, WinXP SP3  
 
=99333=
 
 
 
#19
09.11.2010 13:24:05
а если объявить MetaFileBits as long?  
 
попробуйте? а то у меня 2007го нет  
 
но тогда надо корректировать порог сравнения..
Живи и дай жить..
 
 
 
#20
09.11.2010 13:28:47
Я вот еще придумал, "по рабоче-крестьянски":  
1. Создаем новую книгу, сохраняем в %temp%, определяем размер файла.  
2. Копируем картинку в новую книгу, сохраняем, определяем размер файла.  
3. Если прирост размера меньше 2 кб, удаляем картинку.  
Дальше можно либо удалить картинку и вернуться к 2., либо не удалять картинку, а запомнить новый размер файла.  
Попробую, но позже.
 
 
 
#21
09.11.2010 13:37:44
можно и так.. :)  
 
вот, заменил функцию листа на цикл  
 
Function getsum_clipbrd() As Long  
Dim hMetaFile As Long  
Dim lMFSize As Long  
Dim hMem As Long  
Dim mfp As METAFILEPICT  
Dim hEMF As Long  
Dim MetaFileBits() As Byte  
Dim nFile As Integer  
Dim sm&, t!, x  
t = Timer  
Do  
   DoEvents  
   If OpenClipboard(0) Then  
    hMetaFile = GetClipboardData(3)  
     If hMetaFile Then  
           hMem = GlobalLock(hMetaFile)  
           CopyMemory mfp, ByVal hMem, Len(mfp)  
           hMem = GlobalUnlock(hMem)  
             
           lMFSize = GetMetaFileBitsEx(mfp.hMF, 0, ByVal 0&)  
           If lMFSize Then  
              ReDim MetaFileBits(0 To lMFSize - 1)  
              lMFSize = GetMetaFileBitsEx(mfp.hMF, lMFSize, MetaFileBits(0))  
              For Each x In MetaFileBits  
               getsum_clipbrd = getsum_clipbrd + x  
              Next  
              Exit Do  
           End If  
     End If  
   End If  
Loop While Timer - t < 1  
CloseClipboard  
End Function
Живи и дай жить..
 
 
 
#22
09.11.2010 15:58:27
> вот, заменил функцию листа на цикл  
Теперь ошибки нет, но удаляется только одна пустая картинка - в К10.
 
 
 
#23
09.11.2010 16:08:40
Рабоче-крестьянская версия :)  
 
Sub EmptyPics()  
Dim sFN As String, iL0 As Long, iL1 As Long, s As Shape, x, ws As Worksheet  
For Each x In Split("temp tmp userprofile")  
   sFN = Environ(x)  
   If sFN <> "" Then Exit For  
Next  
If sFN = "" Then Stop  
Application.ScreenUpdating = False  
Set ws = ActiveSheet  
With Workbooks.Add(xlWBATWorksheet)  
   .SaveAs sFN & Format(Now, """\tmp""YYYYMMDDhhmmss")  
   sFN = .FullName  
   iL0 = FileLen(sFN)  
   For Each s In ws.Shapes  
   If s.Type = msoPicture Then  
       s.Copy  
       .Sheets(1).Paste  
       .Save  
       iL1 = FileLen(sFN)  
       If iL1 - iL0 < 2000 Then s.Delete  
       iL0 = iL1  
   End If  
   Next  
   .Close  
End With  
Kill sFN  
Application.ScreenUpdating = True  
End Sub
 
 
 
#24
10.11.2010 11:26:53
у меня удаляет все пустые  
 
ps и в к10 вроде непустая картинка..
Живи и дай жить..
 
 
 
#25
10.11.2010 12:08:22
{quote}{login=слэн}{date=10.11.2010 11:26}{thema=}{post}у меня удаляет все пустые  
 
ps и в к10 вроде непустая картинка..{/post}{/quote}  
 
Слэн   у меня   что-то макрос не работает-  никаких ощибок, запускаю но ничего не происходит, в чем может быть причина.  
может из за того ,что Vista?
 
 
 
#26
10.11.2010 12:10:55
{quote}{login=Казанский}{date=09.11.2010 04:08}{thema=}{post}Рабоче-крестьянская версия :)  
 
Sub EmptyPics()  
Dim sFN As String, iL0 As Long, iL1 As Long, s As Shape, x, ws As Worksheet  
For Each x In Split("temp tmp userprofile")  
   sFN = Environ(x)  
   If sFN <> "" Then Exit For  
Next  
If sFN = "" Then Stop  
Application.ScreenUpdating = False  
Set ws = ActiveSheet  
With Workbooks.Add(xlWBATWorksheet)  
   .SaveAs sFN & Format(Now, """\tmp""YYYYMMDDhhmmss")  
   sFN = .FullName  
   iL0 = FileLen(sFN)  
   For Each s In ws.Shapes  
   If s.Type = msoPicture Then  
       s.Copy  
       .Sheets(1).Paste  
       .Save  
       iL1 = FileLen(sFN)  
       If iL1 - iL0 < 2000 Then s.Delete  
       iL0 = iL1  
   End If  
   Next  
   .Close  
End With  
Kill sFN  
Application.ScreenUpdating = True  
End Sub{/post}{/quote}  
 
Если не сложно  -  можите  проставить коменты  в макросе, чтобы мог разобраться  .   Он  удаляет  все пустые , но  только  втой области что есть в примере, если добавить внизу пару картинок   то он удаляет и пустые и  нормальные.
 
 
 
#27
10.11.2010 13:38:47
странно. но у мнея висты нет. проверить не могу.
Живи и дай жить..
 
 
 
#28
10.11.2010 13:55:24
попробую вечером дома на XP-  возможно из за настроек  рабочего компа  -  не пускает  в папку system
 
 
 
#29
10.11.2010 14:19:58
да, Казанский там немножко заморочился..  :)  
 
писать можно куда угодно. т.е. вообще не заморачиваться с папкой, работать только с именами файлов- пусть пишет в текущую..
Живи и дай жить..
 
 
 
#30
10.11.2010 14:22:58
т.е. оставить только  
 
Application.ScreenUpdating = False  
Set ws = ActiveSheet  
With Workbooks.Add(xlWBATWorksheet)  
.SaveAs sFN & Format(Now, """\tmp""YYYYMMDDhhmmss")  
sFN = .FullName  
iL0 = FileLen(sFN)  
For Each s In ws.Shapes  
If s.Type = msoPicture Then  
s.Copy  
.Sheets(1).Paste  
.Save  
iL1 = FileLen(sFN)  
If iL1 - iL0 < 2000 Then s.Delete  
iL0 = iL1  
End If  
Next  
.Close  
End With  
Kill sFN  
Application.ScreenUpdating = True  
End Sub
Живи и дай жить..
 
 
 
Страницы: 1 2 След.
Читают тему
Наверх