Zmiana wielkości zdjęć w folderze "Automatyzując" MsPaint'a   strona główna:
A po co ten Excel ;-)
 
    Nieraz np.: u znajomych/rodziny chciałbym przeglądnąć jakieś zdjęcia… Nie zawsze mam ochotę bawić się w kopiowanie na kartę, a i tak  
nie mam dostępu do innych/wcześniejszych… wymyśliłem więc "co lepsze foty" umieścić w "Picasa Web Albums" pod moim kontem  
Gmail. Fajnie poukładane w albumach, z możliwością opisu, udostępnienia znajomym (korzystającym z Gmail) i w ogóle fajne rozwiązanie..  
Zdjęć publicznie nie umieszczam (chyba że kiedyś zrozumiem sens takiego posunięcia ;-) ale logując się na dowolnym kompie na swoją  
skrzynkę mam dostęp do wszystkich umieszczonych tam zdjęć :-)  
 
Teraz minus.. Miejsce darmowe to 5000MB a że zdjęć trochu mam to powstał pomysł zmniejszać ich rozmiar przed umieszczeniem w sieci.  
300KB na zdjęcie wg mnie w zupełności wystarczy a zdjęcia mam… no większe ;-) 1,5-5MB.   
 
Jak więc zmniejszyć zdjęcie?  
 - otworzyć duże w MsPaint  
 - Ctrl+W (okno Zmiana rozmiaru i pochylenie)  
 - w części: Zmiana rozmiaru określić procentowo zmniejszenie w Pionie i w Poziomie (w Win7 domyślnie zmiana jednego wymiaru jest  
   powtarzana w drugim)  
 - zamknąć okno  
 - zapisać zmiany  
 - zamknąć MsPaint'a  
 
Chwila zabawy :-) jak się ma 2-5 zdjęć ale jak się ma ich więcej to zabawa okrutnie monotonna i nudna.   
 
I tak powstał pomysł zautomatyzowania ww procedury. Chciałbym wskazać folder -> Klik -> a reszta dzieje się sama :-)  
 
Powstała zatem mała Forma którą wyświetlam w prawym-dolnym rogu ekranu na której  
 - można wybrać folder ze zdjęciami (+ czy przeglądać pod foldery)  
 - określić minimalną wielkość pliku (w KB) które należy zmniejszyć  
 - określić procent zmiany: wartości 10-100 (step:10)  
 - ukazuje się informacja czy są jakieś zdjęcia zakwalifikowane do zmiany  
 - ukazuje się nazwa/ścieżka zmienianego bieżąco pliku i jego numer z wszystkich   
   zakwalifikowanych do zmiany (np. 3 z 34)  
 
Wybór Folderu  
 
Na obrazie widać TextBox ale jak to nieraz robię kontrolce dodam DropButton..  
 
Private Sub UserForm_Initialize()  
    With Me  
        With .TextBox1  
            .DropButtonStyle = fmDropButtonStyleReduce  
            .ShowDropButtonWhen = fmShowDropButtonWhenAlways  
        End With  
 
który będzie działać tak:  
 
Private Sub TextBox1_DropButtonClick()  
    With Me  
        .labFolder.Caption = ""    BrowseForFolderName_Shell()
        .TextBox1.Text = BrowseForFolderName_Shell() '"D:\tkuchta1")  
    End With  
End Sub  
 
Pliki do zmiany  
 
Będę potrzebował kolekcji z nazwami plików zakwalifikowanych do zmiany:  
  Rekurencyjne odczytywanie nazw plików w folderze i jego pod folderach
Wykorzystam przeróbkę mojej procedury ->>>>>  
 
Public colFilesFullNames As VBA.Collection  
                                                     
Sub PlikiZFolderu(strFolderPath As String, strNameLike As String, minSize As Long, subFoldersFlag As Boolean)  
    Dim objFSO As Object 'Scripting.FileSystemObject  
    Dim objFolder As Object 'Scripting.Folder  
    Dim objSubFolder As Object 'Scripting.Folder  
    Dim objFile As Object 'Scripting.File  
                      
    Set objFSO = CreateObject("Scripting.FileSystemObject")  
    Set objFolder = objFSO.GetFolder(strFolderPath)  
                          
    If colFilesFullNames Is Nothing Then Set colFilesFullNames = New VBA.Collection  
                          
    For Each objFile In objFolder.Files  
        With objFile  
            If UCase(.Name) Like UCase(strNameLike) Then  
                If .Size > minSize Then  
                    colFilesFullNames.Add .Path, .Path  
                End If  
            End If  
        End With  
    Next  
    If subFoldersFlag Then  
        For Each objSubFolder In objFolder.SubFolders  
            PlikiZFolderu objSubFolder.Path, strNameLike, minSize, subFoldersFlag  
        Next  
    End If  
      
    Set objFolder = Nothing  
    Set objFSO = Nothing  
End Sub  
 
Pod przyciskiem [START]  
 
… a więc tylko to co istotne pod UserForm'em  
 
 
Private Declare Function GetForegroundWindow _  
    Lib "user32" () _  
    As Long  
 
Private Declare Function GetWindowText _  
    Lib "user32" _  
    Alias "GetWindowTextA" ( _  
        ByVal hWnd As Long, _  
        ByVal lpString As String, _  
        ByVal cch As Long) _  
    As Long  
      
Private Declare Function GetWindowTextLength _  
    Lib "user32" _  
    Alias "GetWindowTextLengthA" ( _  
        ByVal hWnd As Long) _  
    As Long  
 
Private Sub CommandButton1_Click()  
    On Error GoTo OdczytywaniePlików_Error  
      
    Dim i As Long  
    Dim strCommand As String  
      
    With Me.TextBox1  
        If Len(.Text) = 0 Then  
            MsgBox "Nie wybrałeś folderu", vbExclamation  
            Exit Sub  
        End If  
        PlikiZFolderu .Value, "*.jpg", CLng(Me.TextBox2) * 1000, Me.CheckBox1.Value  
    End With  
    If colFilesFullNames.Count = 0 Then  
        Me.labFolder.Caption = "Brak plików spełniających war. filtrowania"  
    End If  
          
    For i = 1 To colFilesFullNames.Count  
        With Me  
            .labFolder.Caption = colFilesFullNames(i)  
            .labNr.Caption = i & " z: " & colFilesFullNames.Count  
            .Repaint  
        End With  
          
        strCommand = Chr(34) & "C:\windows\system32\mspaint.exe" & Chr(34) & " " & _  
                     Chr(34) & colFilesFullNames(i) & Chr(34)  
          
        Dim objWshShell As Object ' IWshRuntimeLibrary.WshShell  
        Set objWshShell = CreateObject("WScript.Shell") 'IWshRuntimeLibrary.WshShell  
        With objWshShell  
          
            .Run Command:=strCommand, WindowStyle:=1  
            Do  
                If GetText(GetForegroundWindow()) Like "*Paint*" Then Exit Do  
            Loop  
            .SendKeys "^w{TAB}" & Me.TextBox3 & "{ENTER}^s%{F4}"  
            Do  
                If GetText(GetForegroundWindow()) Like "*MojeOkno*" Then Exit Do  
            Loop  
              
        End With  
        Set objWshShell = Nothing  
    Next  
                                                             
OdczytywaniePlików_Exit:  
    On Error Resume Next  
    Set colFilesFullNames = Nothing  
    Exit Sub  
                          
OdczytywaniePlików_Error:  
    MsgBox "Byk nr: - " & Err.Number & vbCrLf & vbCrLf & _  
             Err.Description, vbExclamation, "VBAProject - OdczytywaniePlików"  
    Resume OdczytywaniePlików_Exit  
End Sub  
 
Private Function GetText(hWnd As Long) As String  
    Dim lenTxt As Long, retText As String  
       
    lenTxt = GetWindowTextLength(hWnd) + 1  
    retText = String(lenTxt, " ")  
    GetWindowText hWnd, retText, lenTxt  
    GetText = retText  
End Function  
 
Fragmentami:  
 
    With Me.TextBox1  
        If Len(.Text) = 0 Then  
            MsgBox "Nie wybrałeś folderu", vbExclamation  
            Exit Sub  
        End If  
        PlikiZFolderu .Value, "*.jpg", CLng(Me.TextBox2) * 1000, Me.CheckBox1.Value  
    End With  
    If colFilesFullNames.Count = 0 Then  
        Me.labFolder.Caption = "Brak plików spełniających war. filtrowania"  
    End If  
 
… jasne (?). Jak wybrano folder to tworzę kolekcję plików do zmiany. Do procedury tworzącej publiczną kolekcję tych plików podaję:  
ścieżkę do folderu głównego, wzór na nazwy plików (wykorzystam operator Like), min wielkość pliku który powinien być zmieniany,  
informację czy procedura ma też przeglądać pod foldery. Jak ilość pasujących do tych kryteriów plików = 0 to info..  
 
    For i = 1 To colFilesFullNames.Count  
 
dla każdego pliku z kolekcji…  
 
        With Me  
            .labFolder.Caption = colFilesFullNames(i)  
            .labNr.Caption = i & " z: " & colFilesFullNames.Count  
            .Repaint  
        End With  
 
wyświetlam na Labelach w UserFormie informacje o bieżąco zmienianym pliku: Nazwę, Nr.  
 
        strCommand = Chr(34) & "C:\windows\system32\mspaint.exe" & Chr(34) & " " & _  
                     Chr(34) & colFilesFullNames(i) & Chr(34)  
          
        Dim objWshShell As Object ' IWshRuntimeLibrary.WshShell  
        Set objWshShell = CreateObject("WScript.Shell") 'IWshRuntimeLibrary.WshShell  
        With objWshShell  
          
            .Run Command:=strCommand, WindowStyle:=1  
 
otwieram plik w MsPaint  
 
            Do  
                If GetText(GetForegroundWindow()) Like "*Paint*" Then Exit Do  
            Loop  
 
Czekam na otwarcie się zdjęcia w MsPaint. Gdy to nastąpi to okno na wierzchu będzie miało Text: Nazwa otwartego pliku i Nazwa programu  
w którym zdjęcie zostało otwarte. A więc będzie: Like "*Paint*"  
 
            .SendKeys "^w{TAB}" & Me.TextBox3 & "{ENTER}^s%{F4}"  
 
 - ctrl+w  (okno Zmiana rozmiaru i pochylenie)  
 - tab (przejście do części: Zmiana rozmiaru )  
 - procent zmiany (Me.TextBox3)  
 - enter (zamknięcie okna Zmiana rozmiaru i pochylenie)  
 - ctrl+s (zapisz zmiany)  
 - alt+F4 (zamknij MsPaint)  
 
            Do  
                If GetText(GetForegroundWindow()) Like "*MojeOkno*" Then Exit Do  
            Loop  
 
Czekam na realizację zadania. Zapisywanie zmian może chwilkę potrwać. I jak oknem na wierzchu będzie znów mój UserForm…  
 
    Next   Przykład do pobrania:
  przyklad.zip
powtarzam procedurę dla następnego pliku.  
 
i tyle :-) Całość zajmuje ułamek czasu i nerwów które trzeba by poświęcić robiąc to ręcznie :-) Tak… będzie mrugać! I niech mruga ;-)  
grunt że realizuje swoje zadanie.