excel：照片縮圖

建置條件：從？欄有圖片檔名資料，再選擇照片所在目錄對應出每一欄位的實際路徑，

                   並自動加入圖片在？欄，後再清除圖片檔名，但不知為何第一次加入的照片很糊，需Run二次才OK。

Private Sub CommandButton1_Click()

   Dim stMedd As String


   stMedd = "請選擇照片來源目錄：" '選擇目錄
   Set obMapp = CreateObject("Shell.Application").BrowseForFolder(0, stMedd, &H1)
   If Not obMapp Is Nothing Then
      txtPath.Text = obMapp.self.Path + "\"
   Else
      Exit Sub
   End If
End Sub


Private Sub CommandButton2_Click()
Call AddPhotoLink1(txtName.Text, txtInput.Text, txtOutput.Text, txtPath.Text)
Unload Me
End Sub






Sub AddPhotoLink1(nameColumn As String, inputpicColumn As String, outputpicColumn As String, inputPath As String)
 Dim a, b, c As Integer '宣告a,b,c為整數
    
    Dim objsheet As Worksheet
    
    WorkName = Excel.ActiveWorkbook.Name '此檔案名稱
    
  
    i = 2


    Z = 2
    
    picHeight = 3
    picWidth = 3
    'picColumn = "BA"
    picAngle = 0
    
    For j = 1 To 2
    i = 2


    Z = 2
    
    '將之前產生的圖片清除
    Sheets(ActiveSheet.Name).Activate
    Sheets(ActiveSheet.Name).Shapes.SelectAll
    Selection.Delete
    
    
    While Sheets(ActiveSheet.Name).Range(nameColumn & i) <> ""
    
      
        
        '檢查檔案是否存在
        Fullpath = inputPath + Sheets(ActiveSheet.Name).Range(inputpicColumn & i)
        If Dir(Fullpath) <> "" Then
        
            'Sheets(ActiveSheet.Name).Activate
            
            Sheets(ActiveSheet.Name).Range(outputpicColumn & Z).Select
            
            'ActiveSheet.Pictures.Insert(Fullpath).Select '在excel 2007圖片會變成連結方式
            ActiveSheet.Shapes.AddPicture Fullpath, True, True, Selection.Left, Selection.Top, Selection.Width, Selection.Height
            
            
            
            If picHeight > 0 Then
                Sheets(ActiveSheet.Name).Shapes(Sheets(ActiveSheet.Name).Shapes.Count).Height = 28.5 * picHeight


              '調整列高度
               Sheets(ActiveSheet.Name).Rows(Z).RowHeight = 28.5 * picHeight
               
            End If
            
            If picWidth > 0 Then
                Sheets(ActiveSheet.Name).Shapes(Sheets(ActiveSheet.Name).Shapes.Count).Width = 28.5 * picWidth
            End If
            
            Sheets(ActiveSheet.Name).Shapes(Sheets(ActiveSheet.Name).Shapes.Count).Rotation = picAngle
            
            Selection.Cut   '2007才需要底下這樣作
            
            Sheets(ActiveSheet.Name).Range(outputpicColumn & Z).Select
            
            ActiveSheet.Paste
            'If chkPhoto.Value Then
            If j = 2 Then
            Sheets(ActiveSheet.Name).Range(inputpicColumn & i) = ""
            Sheets(ActiveSheet.Name).Shapes(Sheets(ActiveSheet.Name).Shapes.Count).Select
            Selection.Placement = xlMoveAndSize ‘使得圖片屬性～大小位置隨著儲存格而定
            End If
        Else
            MsgBox "檔案:" & Fullpath & "不存在，請查看是否有拼錯字"
        End If
        i = i + 1 '讀取下一個名稱
        Z = Z + 1
    Wend
    Next j
    End
 
    MsgBox "執行完成", vbOKOnly, "^^ Merry Christmas and a Happy New Year ^^"
End Sub


Private Sub CommandButton3_Click()
Call AddPhotoLink1(txtName.Text, txtInput.Text, txtOutput.Text, txtPath.Text)
Unload Me
End Sub