January 14, 2012

Inserting picture in worksheet using macro

Summary:
Inserting picture in worksheet using macro.

Details

 Sub Insert_ImagePic()  
 Dim wks As Worksheet  
   Dim Copies As Variant  
   Dim strPath As String  
   Dim strFileNm As String  
   Dim Pic  
   '--  
 ' Reference active sheet  
   On Error Resume Next  
   Set wks = ActiveSheet  
   ' Better solution is to reference specified worksheet, e.g.:  
   ' In this example worksheet name = 'ImagePic', customize name  
   Set wks = ThisWorkbook.Worksheets("ImagePic")  
   ' Check if sheet exists  
   If wks Is Nothing Then  
     MsgBox "Active sheet is not Worksheet...'" & vbLf & _  
         "Please select Worksheet.... and recall procedure.", _  
         vbExclamation, "Insert ImagePic"  
     Exit Sub  
   End If  
   On Error GoTo 0  
   ' Initialize File name and Path (you use ComboBox)  
   ' Customize File name and Path  
   strPath = "C:\Users\Andro\Desktop\Articles\avXl"  
   strFileNm = "av_Articles.jpg"  
   '--  
 ' Add Path separator if is missing  
   If Right(strPath, 1) <> Application.PathSeparator Then  
     strPath = strPath & Application.PathSeparator  
   End If  
   'If Me.cboEmployee.Value <> "" Then  
   If strFileNm <> "" Then  
     ' Insert ImagePic at active sheet  
     'Me.imgEmpPic.ImagePic = LoadImagePic(strPath & strFileNm)  
     Set Pic = ActiveSheet.ImagePics.Insert(strPath & strFileNm)  
     ' Optional: Specify ImagePic Left, Top, Width and Height, e.g.:  
     With Pic  
       .Left = 20 ' or:  
       .Left = wks.Range("B2").Left  
       .Top = 25  ' or:  
       .Top = wks.Range("B2").Top  
       ' Don't specify Width and Height  
       ' if you prefere original dimensions.  
       '.Width = 100  
       '.Height = 100  
     End With  
     ' Get qty of copies  
     Copies = InputBox("Qty to print:", "Print")  
     ' Check if numeric  
     If IsNumeric(Copies) Then  
       Copies = CInt(Copies)  
       ' Print out specified copies  
       ActiveSheet.PrintOut Copies:=Copies, Collate:=False  
     End If  
   End If  
   Set wks = Nothing  
 End Sub