Chèn hình vào cell bằng hàm tự tạo

batman1

Thành viên gạo cội
Tham gia ngày
8 Tháng chín 2014
Bài viết
3,539
Được thích
5,392
Điểm
560
Cảm ơn bác
Công việc của em là quản lý tài sản, cty có khoảng 10000 tài sản cố định, hàng tháng có khoảng trăm tài sản mua mới , mỗi tài sản có mã riêng, em định chụp ảnh về đặt tên ảnh là tên mã tài sản, sau đó dùng hàm để gọi thông tin tài sản, bao gồm cả ảnh ra trong file #197 , sau đấy in ra để lưu bản cứng mỗi tài sản 1 tờ , thế nên file của em không cần lưu ảnh vĩnh viễn, chỉ gọi ảnh của tài sản nào cần thôi bác.
Ví dụ như file em gửi thì mã tài sản ở ô B12 , còn ảnh sẽ hiện ở A23:F44
Rất tiếc là code của tôi nhập ảnh vĩnh viễn.

Bạn có các lựa chọn:
1. Chọn bằng tay các ảnh -> nhấn DELETE trên bàn phím -> lưu lại.
Bạn chỉ chèn 1 ảnh thì chọn và nhấn DELETE thôi. Có khó khăn gì đâu?

2. Thẻ Home -> nhấn nút Find & Select -> chọn Goto To Special ... -> đánh dấu chọn Objects -> OK -> nhấn DELETE

Cách này là xóa tất cả các object trên sheet. Nếu ngoài ảnh còn có các đối tượng khác thì không dùng.

3. Cho bây giờ và mãi về sau bạn nên sửa trong code của InsertPicture
Sửa
Mã:
Target.Parent.Shapes("r" & Target.Row & "c" & Target.Column).Delete
thành
Mã:
Target.Parent.Shapes(Target.Address).Delete
Sửa
Mã:
shp.Name = "r" & Target.Row & "c" & Target.Column
thành
Mã:
shp.Name = Target.Address
Bây giờ nếu muốn xóa các ảnh đã được chèn bằng InsertPicture thì chạy code
Mã:
Sub delete_pic()
Dim shname As String, sh As Worksheet, shp As Shape, rng As Range
    shname = Application.InputBox("Nhap ten sheet co anh can xoa", "Ten sheet", , , , , , 2)
    If shname = "" Then Exit Sub
    On Error Resume Next
    Set sh = ThisWorkbook.Worksheets(shname)
    If Err.Number Then Exit Sub
    
    For Each shp In sh.Shapes
        Set rng = sh.Range(shp.Name)
        If Err.Number Then
            Err.Clear
        Else
            sh.Shapes(shp.Name).Delete
        End If
    Next shp
End Sub
 

bjboyn00b

Thành viên mới
Tham gia ngày
17 Tháng mười hai 2010
Bài viết
22
Được thích
0
Điểm
363
Rất tiếc là code của tôi nhập ảnh vĩnh viễn.

Bạn có các lựa chọn:
1. Chọn bằng tay các ảnh -> nhấn DELETE trên bàn phím -> lưu lại.
Bạn chỉ chèn 1 ảnh thì chọn và nhấn DELETE thôi. Có khó khăn gì đâu?

2. Thẻ Home -> nhấn nút Find & Select -> chọn Goto To Special ... -> đánh dấu chọn Objects -> OK -> nhấn DELETE

Cách này là xóa tất cả các object trên sheet. Nếu ngoài ảnh còn có các đối tượng khác thì không dùng.

3. Cho bây giờ và mãi về sau bạn nên sửa trong code của InsertPicture
Sửa
Mã:
Target.Parent.Shapes("r" & Target.Row & "c" & Target.Column).Delete
thành
Mã:
Target.Parent.Shapes(Target.Address).Delete
Sửa
Mã:
shp.Name = "r" & Target.Row & "c" & Target.Column
thành
Mã:
shp.Name = Target.Address
Bây giờ nếu muốn xóa các ảnh đã được chèn bằng InsertPicture thì chạy code
Mã:
Sub delete_pic()
Dim shname As String, sh As Worksheet, shp As Shape, rng As Range
    shname = Application.InputBox("Nhap ten sheet co anh can xoa", "Ten sheet", , , , , , 2)
    If shname = "" Then Exit Sub
    On Error Resume Next
    Set sh = ThisWorkbook.Worksheets(shname)
    If Err.Number Then Exit Sub
   
    For Each shp In sh.Shapes
        Set rng = sh.Range(shp.Name)
        If Err.Number Then
            Err.Clear
        Else
            sh.Shapes(shp.Name).Delete
        End If
    Next shp
End Sub
Cám ơn bác rất nhiều :D
 

sevt.01

Thành viên mới
Tham gia ngày
16 Tháng sáu 2018
Bài viết
6
Được thích
0
Điểm
13
Tuổi
30
Em đính kèm lại file em cần chèn anh, Mong các anh hướng dẫn thêm. Echưa chèn được ảnh vào file trên nhiều dòng và cột.
Mới chỉ chèn được khi nó ở trong 1 cell.
cảm ơn các anh!
 

File đính kèm

batman1

Thành viên gạo cội
Tham gia ngày
8 Tháng chín 2014
Bài viết
3,539
Được thích
5,392
Điểm
560
Em đính kèm lại file em cần chèn anh, Mong các anh hướng dẫn thêm. Echưa chèn được ảnh vào file trên nhiều dòng và cột.
Mới chỉ chèn được khi nó ở trong 1 cell.
cảm ơn các anh!
Nhờ người khác thì cũng phải mô tả cho người ta hiểu.

Nhập ảnh vào đâu? Tên ảnh lấy ở đâu? Nhập khi nào?

Không có mô tả thì tôi tự cho ví dụ, rồi hãy tự thích ứng với tập tin thực. Code có sẵn, ví dụ cũng cho sẵn

https://www.giaiphapexcel.com/diend...-vào-khung-textbox-bằng-vba.84107/post-863151

thế mà không làm được thì bó tay toàn tập.

1. Vùng cần nhập ảnh không bắt buộc phải merge. Hiện tại ví dụ nhập ảnh vào C25:H32. Do cần phải biết lấy ảnh nào cho C25:H32 nên tôi nhập 11540859 vào C25. Tức code sẽ tìm ảnh 11540859.JPG để nhập.
Mã:
Sub Button2_Click()
    With Worksheets("file")
        InsertPicture ThisWorkbook.Path & "\file anh\" & .Range("C25").Value & ".jpg", .Range("C25:H32")
    End With
End Sub
Tức code sẽ tìm ảnh trong thư mục "file anh". Nếu tên thư mục thay đổi thì tự sửa trong code. Thư mục "file anh" phải nằm cùng thư mục với tập tin Excel. Nếu khác thì tự sửa trong code.

Code coi là đang nhập ảnh trong sheet "file". Nếu tên khác thì tự sửa.

2. Trong code ví dụ tôi nhập vào C25 chỉ tên mà không có định dạng JPG vì code có thể tự thêm vào. Tự sửa theo ý muốn.

3. Code InsertPicture và Sub Button2_Click ở trong Module1.
 

File đính kèm

sevt.01

Thành viên mới
Tham gia ngày
16 Tháng sáu 2018
Bài viết
6
Được thích
0
Điểm
13
Tuổi
30
Em cảm ơn anh, em đã làm được ạ.
 

cuahang0000

Thành viên mới
Tham gia ngày
2 Tháng sáu 2009
Bài viết
7
Được thích
1
Điểm
665
Hàm CommPic phiên bản mới nhất với nhiều tùy chọn:
Mã:
Function CommPic(ByVal PicPath As String, Optional ByVal PicCel As Range, _
                Optional ByVal ScaleWidth As Single = 1, _
                Optional ByVal ScaleHeight As Single = 1) As String
  Dim mRng As Range, cmt As Comment, fso As Object, bChk As Boolean
  On Error Resume Next
  Application.Volatile
  Set fso = CreateObject("Scripting.FileSystemObject")
  If PicCel Is Nothing Then Set PicCel = Application.ThisCell
  PicCel(1, 1).Comment.Delete
  If Left(PicPath, 7) = "http://" Then
    bChk = URLExists(PicPath)
  Else
    bChk = fso.FileExists(PicPath)
    If bChk = False Then
      PicPath = ThisWorkbook.Path & "\" & PicPath
      bChk = fso.FileExists(PicPath)
    End If
  End If
  If bChk Then
    If PicCel(1, 1).Comment Is Nothing Then PicCel(1, 1).AddComment
    PicCel(1, 1).Comment.Text vbLf
    Set mRng = PicCel(1, 1).MergeArea
    If mRng Is Nothing Then Set mRng = PicCel(1, 1)
    Set cmt = mRng(1, 1).Comment
    cmt.Visible = True
    With cmt.Shape
      .LockAspectRatio = msoFalse
      .Placement = xlMoveAndSize
      .Shadow.Visible = msoFalse
      .Line.ForeColor.RGB = PicCel.Interior.Color
      .AutoShapeType = msoShapeRectangle
      .Left = mRng.Left: .Top = mRng.Top
      .Width = mRng.Width: .Height = mRng.Height
      .ScaleWidth ScaleWidth, msoFalse, msoScaleFromMiddle
      .ScaleHeight ScaleHeight, msoFalse, msoScaleFromMiddle
      .Fill.UserPicture PicPath
    End With
  End If
End Function
Private Function URLExists(ByVal URL As String) As Boolean
  Application.Volatile
  On Error Resume Next
  If Left(UCase(URL), 7) <> "HTTP://" Then URL = "http://" & URL
  With CreateObject("MSXML2.XMLHTTP")
    .Open "HEAD", URL, False: .send
    URLExists = .Status = 200
  End With
End Function
Khả năng của hàm:
- Như ý anh: Nếu đường dẫn không tồn tại, sẽ xóa Comment
- Cho phép chèn hình có trong ổ đĩa máy tính hoặc hình trên Web
- Tự động thay đổi size hình và dịch chuyển theo cell (khi cell thay đổi kích thước, chỉ cần bấm F9 để cập nhật)
- Cho phép thu nhỏ, phóng to hình tùy ý. Ví dụ =CommPic(A1, , 80%, 80%) có nghĩa là thu nhỏ chiều ngang và chiều dọc 80% so với cell (mặc định là 100%)
Những khả năng mở rộng chỉ là dạng Optional, nếu anh không thích dùng vẫn có thể bỏ qua không cần khai báo. Ví dụ anh chỉ muốn chèn hình vào cell B1, với đương dẫn nằm ở A1, vậy chỉ cần gõ vào B1 thế này là đủ: =CommPic(A1) mà không cần quan tâm những đối số phía sau
Gởi Thầy ndu96081631

Xin lỗi vì em hơi dốt VBA, cho em hỏi có cách nào em đã để hình ở 1 sheet riêng biệt trong file Excel (vd: mỗi hình là 1 ô ở sheet "hinhanh")
Giờ em muốn khi em gõ mã ở sheet "xu ly" thì hình hiện tương ứng !
Em đọc kỹ các bài post nhưng không thấy đề cập việc lấy hình ở trong cùng 1 work book (em đang nói phương án nhúng hình vào file luôn)
 

File đính kèm

ndu96081631

Huyền thoại GPE
Thành viên BQT
Super Moderator
Tham gia ngày
5 Tháng sáu 2008
Bài viết
30,659
Được thích
53,399
Điểm
11,910
Em đọc kỹ các bài post nhưng không thấy đề cập việc lấy hình ở trong cùng 1 work book (em đang nói phương án nhúng hình vào file luôn)
Có chứ! Bạn xem file nhé (hàm CommPic đã cải tiến)
Điều quan trọng là bạn phải đặt tên hình trùng với mã, sau đó dùng hàm này tại B2
Mã:
=CommPic("hinh!"&A2,,0.8,0.8)
Con số 0.8 là độ phóng to thu nhỏ hình so với cell. Nếu không ghi gì có nghĩa là số ấy =1, vừa khít hình với cell
 

File đính kèm

tueyennhi

Thành viên tích cực
Tham gia ngày
18 Tháng mười 2010
Bài viết
1,172
Được thích
101
Điểm
720
Tuổi
31
Có chứ! Bạn xem file nhé (hàm CommPic đã cải tiến)
Điều quan trọng là bạn phải đặt tên hình trùng với mã, sau đó dùng hàm này tại B2
Mã:
=CommPic("hinh!"&A2,,0.8,0.8)
Con số 0.8 là độ phóng to thu nhỏ hình so với cell. Nếu không ghi gì có nghĩa là số ấy =1, vừa khít hình với cell
Thầy cho em hỏi chèn hình từ trên mạng thì làm thế nào? Em copy đường link và đánh Compic("Đường link") thì không được.
 

ndu96081631

Huyền thoại GPE
Thành viên BQT
Super Moderator
Tham gia ngày
5 Tháng sáu 2008
Bài viết
30,659
Được thích
53,399
Điểm
11,910
Thầy cho em hỏi chèn hình từ trên mạng thì làm thế nào? Em copy đường link và đánh Compic("Đường link") thì không được.
Bất cứ "đường link" nào mà bạn có thể chèn bằng tay vào bảng tính được thì sẽ có thể dùng nó với code
Ví dụ:
Mã:
=CommPic("http://i1101.photobucket.com/albums/g424/atmt17/SinhNhatGPE239.jpg")
Còn "đường link" của bạn thuộc dạng gì?
 

tueyennhi

Thành viên tích cực
Tham gia ngày
18 Tháng mười 2010
Bài viết
1,172
Được thích
101
Điểm
720
Tuổi
31

ndu96081631

Huyền thoại GPE
Thành viên BQT
Super Moderator
Tham gia ngày
5 Tháng sáu 2008
Bài viết
30,659
Được thích
53,399
Điểm
11,910

File đính kèm

lenamproduct

Thành viên mới
Tham gia ngày
26 Tháng mười 2018
Bài viết
4
Được thích
0
Điểm
13
Tuổi
28
Bạn chỉ cần thay đổi chiều cao, chiều rộng của cell mà bạn đang gõ hàm rồi bấm F9 là tự động hình sẽ được chỉnh theo kích thước mới của cell
Thử xem
Chào a. Em có xem cách a chèn hình ảnh vào cố định vào exel cố định bằng hàm. Bài 5 năm trước. Không biết giờ a viết chỉnh hàm, cho mình gõ trực tiếp đường linh trong ô để hình ảnh từ đường dẫn nhảy vào ô luôn chưa ạ? Cách trước của a là pải ghi đường dẫn sang ô nhớ phụ. Và cho em hỏi thêm, là ví dụ mình có sheet2, nhưng mình muốn lấy hình ảnh từ ô B5 sheet1 (B5 là ô đã chèn hình ảnh từ file ổ cứng) thì mình có cách nào không ạ? Mail em Lenamproduct@gmail.com !
Thank anh!
 

lenamproduct

Thành viên mới
Tham gia ngày
26 Tháng mười 2018
Bài viết
4
Được thích
0
Điểm
13
Tuổi
28
Xưa nay người ta thường chèn hình vào bảng tính bằng 1 thủ tục nào đó (Sub...). Vậy các bạn có nghĩ rằng có thể chèn hình bằng hàm tự tạo không? Tức là ta gõ hàm vào cell, lập tức hình được chèn vào ngay cell ấy!
Ví dụ ta gõ thế này: =CommPic("D:\Pic\Hinh 1.jpg",C5) thì lập tức Hinh 1.jpg được chèn vừa vặn vào cell C5
Hấp dẫn nhỉ? Vậy mà code lại khá đơn giản:
chào anh. E làm theo a ok ạ. Nhưng khi mình xuất dữ liệu sang Pdf, hình ảnh k sang đc. Anh có cách nào chỉ giúp e với để PDF có thể hiện thị ảnh với ạ!
 

tueyennhi

Thành viên tích cực
Tham gia ngày
18 Tháng mười 2010
Bài viết
1,172
Được thích
101
Điểm
720
Tuổi
31
chào anh. E làm theo a ok ạ. Nhưng khi mình xuất dữ liệu sang Pdf, hình ảnh k sang đc. Anh có cách nào chỉ giúp e với để PDF có thể hiện thị ảnh với ạ!
Trong Page Setup của Excel phần Comments bạn chỉnh thành As dispayed on sheet nhé. Sau đó save đuôi pdf là được.
 

N Khánh

Thành viên mới
Tham gia ngày
22 Tháng mười một 2018
Bài viết
30
Được thích
0
Điểm
13
Tuổi
25
Nhưng hiện tại muốn chỉ ảnh to ra thì phải thay đổi kích thước của ô, nhưng file excel này của em muốn ảnh to chỉ có thể merge các ô lại, vì nếu kéo chỉnh ô cell sẽ bị hỏng cấu trúc. Nhưng khi merge các ô lại thì ảnh vẫn chỉ bé bằng ô ban đầu ạ. Mong mọi người giúp mình với !!!
 

batman1

Thành viên gạo cội
Tham gia ngày
8 Tháng chín 2014
Bài viết
3,539
Được thích
5,392
Điểm
560
Nhưng hiện tại muốn chỉ ảnh to ra thì phải thay đổi kích thước của ô, nhưng file excel này của em muốn ảnh to chỉ có thể merge các ô lại, vì nếu kéo chỉnh ô cell sẽ bị hỏng cấu trúc. Nhưng khi merge các ô lại thì ảnh vẫn chỉ bé bằng ô ban đầu ạ. Mong mọi người giúp mình với !!!
Tức bạn đã chọn cho mình một cách chèn ảnh, cụ thể là dưới dạng Comment. Bây giờ bạn muốn người ta uốn nó theo ý bạn là ảnh phải to ra mà vẫn giữ nguyên kích thước hàng cột?

Nếu không nhất thiết là comment thì đăng bài ở chủ đề mới, nêu rõ yêu cầu, có minh họa và xin hướng dẫn. Cách chèn thì để cho người giúp tự chọn. Đừng theo kiểu cứ bắt chọn một cô rồi bắt người khác phải làm sao cho cô đó "* vượt ngọn cây"
 

N Khánh

Thành viên mới
Tham gia ngày
22 Tháng mười một 2018
Bài viết
30
Được thích
0
Điểm
13
Tuổi
25
Tức bạn đã chọn cho mình một cách chèn ảnh, cụ thể là dưới dạng Comment. Bây giờ bạn muốn người ta uốn nó theo ý bạn là ảnh phải to ra mà vẫn giữ nguyên kích thước hàng cột?

Nếu không nhất thiết là comment thì đăng bài ở chủ đề mới, nêu rõ yêu cầu, có minh họa và xin hướng dẫn. Cách chèn thì để cho người giúp tự chọn. Đừng theo kiểu cứ bắt chọn một cô rồi bắt người khác phải làm sao cho cô đó "* vượt ngọn cây"
https://www.giaiphapexcel.com/diendan/threads/giúp-em-sửa-code-chèn-ảnh-vào-excel.139187/
bác giúp em với
 

matbao8x

Thành viên mới
Tham gia ngày
29 Tháng tám 2007
Bài viết
2
Được thích
2
Điểm
665
Mình đã đọc hết 11 trang topic này xin phép đào mồ và tổng hợp lại như sau:
Có 2 cách cách chèn hình vào excel.
1. Chèn hình vĩnh viễn vào excel bằng các lệnh chèn hình vào ô. có 2 hàm của 2 bác đã làm là: 199159
2. Chèn hình vào comment của chủ topic: bài 1
Mình dùng bài 159 phù hợp hơn, nhưng chưa biết code nào để bring to front hoặc send to back, hoặc frame hình lại vì mình bố trí hình chồng lên nhau. Nếu ae có đọc bài nhờ hỗ trợ chỉnh code với nhé:
Mã:
Option Explicit
Public Function InsertPic(ByVal PicPath As String, _
                          Optional ByVal PicCel As Range, _
                          Optional ByVal xScaleWidth As Double = 0.99, _
                          Optional ByVal xScaleHeight As Double = 0.99, _
                          Optional xStretch As Byte = 1) As String
'--------------------------------------------------------------------------------
'CHU THICH LENH: CHEN ANH VAO CELL
'HUONG DAN:
'Tham so                    Chu thich                                       Vi du
'PicPath                    Duong dan file anh                              D:\Picture.png hoac http://taihinhanhdep.xyz/wp-content/uploads/2015/11/anh-dep-cho-dien-thoai-2.jpg
'PicCel                     Vung chen anh                                   C1:F10
'xScaleWidth,xScaleHeight   Thu phong Anh theo ty le: mac dinh 1               1,1
'xStretch                   0:  Keo gian hinh anh vua khit voi vung chen anh
'                           1:  Chen anh theo kich thuoc that cua anh
'--------------------------------------------------------------------------------
    On Error Resume Next
    Dim mRng As Range
    Dim shp As Shape
    Dim cmt As Comment
    Dim fso As Object, oShel As Object
    Dim xArrTam As Variant, xFormat As Variant, xPath As Variant
    Dim xNamePicture As String, txt As String
    Dim i As Byte, j As Byte
    Dim TyLe As Double
    Application.Volatile
    Set fso = CreateObject("Scripting.FileSystemObject")
    'CHON O CHEN ANH NGAY O CO CONG THUC (NEU CHUA CHON VUNG CHEN ANH)
    If PicCel Is Nothing Then Set PicCel = Application.ThisCell
    If PicCel.Cells(1, 1).MergeCells Then Set mRng = PicCel(1, 1).MergeArea Else Set mRng = PicCel
    With Application.ThisCell
        If .Comment Is Nothing Then .AddComment
        Set cmt = .Comment
        With cmt
            PicCel.Worksheet.Shapes.Range(Array(.Text)).Delete
            .Text "[" & PicCel.Address(0, 0) & "]" & fso.GetBaseName(PicPath)
            .Visible = False
            With .Shape
                .Top = Application.ThisCell.Top
                .Left = Application.ThisCell.Left + Application.ThisCell.Width
                .Height = 0
                .Width = 0
                .Line.ForeColor.RGB = Application.ThisCell.Interior.Color
            End With
        End With
    End With
    Err.Clear
    If Not fso.FileExists(PicPath) Then
        xFormat = Array("JPG", "JPEG", "JPE", "TIFF", "GIF", "PNG", "BMP")    'dinh dang anh
        xNamePicture = fso.GetBaseName(PicPath)    'ten anh
        Set oShel = CreateObject("Shell.Application").Namespace(&H27&).Self    'thu muc Picture
        xPath = Array(fso.GetParentFolderName(PicPath), ActiveWorkbook.Path, oShel.Path)    'duong dan
        'tim duong dan phu hop voi ten anh
        For i = LBound(xPath) To UBound(xPath)
            If Len(xPath(i)) > 0 Then
                For j = LBound(xFormat) To UBound(xFormat)
                    PicPath = xPath(i) & "\" & xNamePicture & "." & xFormat(j)
                    If fso.FileExists(PicPath) Then
                        PicPath = fso.GetFile(PicPath).ShortPath
                        GoTo Nex
                    End If
                Next j
            End If
        Next i
        InsertPic = ""
        GoTo Thoat
    End If
Nex:
    InsertPic = "  "    'PicPath
    ReDim xArrTam(3)
    'lay kich thuoc va vi tri dat anh
    'lay kich thuoc anh: ?1024 x 768? ~ Width x Height
    Set oShel = CreateObject("Shell.Application")
    If fso.FileExists(PicPath) Then
        With oShel.Namespace("" & fso.GetParentFolderName(PicPath) & "")
            txt = .Getdetailsof(.ParseName("" & fso.GetFile(PicPath).Name & ""), 31)
            xFormat = Split(Mid(txt, 2, Len(txt) - 2), " x ")
        End With
    End If
    If xStretch = 1 Then    'keo gian hinh anh vua o
        'tinh toan ty le cua anh so voi Cells
        TyLe = Application.WorksheetFunction.Min(mRng.Width / CDbl(xFormat(0)), mRng.Height / CDbl(xFormat(1)))
        xArrTam(0) = mRng.Left + (mRng.Width - (CDbl(xFormat(0)) * TyLe)) / 2
        xArrTam(1) = mRng.Top + (mRng.Height - (CDbl(xFormat(1)) * TyLe)) / 2
        xArrTam(2) = CDbl(xFormat(0)) * TyLe
        xArrTam(3) = CDbl(xFormat(1)) * TyLe
    Else    'chinh theo ty le hinh anh
LayTyLe:
        xArrTam(0) = mRng.Left
        xArrTam(1) = mRng.Top
        xArrTam(2) = mRng.Width
        xArrTam(3) = mRng.Height
    End If
    'dinh dang anh
    Set shp = PicCel.Worksheet.Shapes.AddPicture(PicPath, False, True, 1, 1, xFormat(0), xFormat(1))
    'ActiveSheet.Shapes.AddPicture("D:\1.jpg", False, True, left, top, width, heigh)
    With shp
        .Name = "[" & PicCel.Address(0, 0) & "]" & fso.GetBaseName(PicPath)
        .LockAspectRatio = msoFalse
        .Shadow.Visible = msoFalse
        .Line.ForeColor.RGB = PicCel.Interior.Color
        .AutoShapeType = msoShapeRectangle
        .Left = xArrTam(0)
        .Top = xArrTam(1)
        .Width = xArrTam(2)
        .Height = xArrTam(3)
        .ScaleWidth xScaleWidth, msoFalse, msoScaleFromMiddle
        .ScaleHeight xScaleHeight, msoFalse, msoScaleFromMiddle
        .visible = true
    End With
Thoat:
    Set oShel = Nothing: Set fso = Nothing
    Set shp = Nothing: Set cmt = Nothing
    Set PicCel = Nothing: Set mRng = Nothing
End Function
 
Top Bottom