vuongtoituonglai
Thành viên thường trực




- Tham gia
- 7/5/14
- Bài viết
- 350
- Được thích
- 47
Chào Anh, Chị Và Các Bạn,
Mình thêm chữ nhật 今日 vào "D:\今日 Hinh\" thì không được. Kết quả "D:\?? Hinh\"
Anh chị và các bạn biết cách làm chỉ mình với.
Function InsertPic(ByVal picname As String) As String
Dim fullName As String, pic As Shape, cell_ As Range, fs As Object
Dim mPath As String
mPath = "D:\Hinh\"
Set cell_ = Application.ThisCell
On Error Resume Next
cell_.Parent.Shapes(cell_.Address).Delete
If Err.Number Then Err.Clear
On Error GoTo 0
Set fs = CreateObject("Scripting.FileSystemObject")
If fs.FileExists(mPath & picname & ".jpg") Then
fullName = picname & ".jpg"
ElseIf fs.FileExists(mPath & picname & ".bmp") Then
fullName = picname & ".bmp"
End If
If fullName <> "" Then
Set pic = cell_.Parent.Shapes.AddPicture(mPath & fullName, _
msoFalse, msoTrue, cell_.Left, cell_.Top, cell_.Width, cell_.Resize(4).Height)
pic.LockAspectRatio = msoTrue
pic.Name = cell_.Address
End If
Set cell_ = Nothing
Set fs = Nothing
End Function
Mình thêm chữ nhật 今日 vào "D:\今日 Hinh\" thì không được. Kết quả "D:\?? Hinh\"
Anh chị và các bạn biết cách làm chỉ mình với.
Function InsertPic(ByVal picname As String) As String
Dim fullName As String, pic As Shape, cell_ As Range, fs As Object
Dim mPath As String
mPath = "D:\Hinh\"
Set cell_ = Application.ThisCell
On Error Resume Next
cell_.Parent.Shapes(cell_.Address).Delete
If Err.Number Then Err.Clear
On Error GoTo 0
Set fs = CreateObject("Scripting.FileSystemObject")
If fs.FileExists(mPath & picname & ".jpg") Then
fullName = picname & ".jpg"
ElseIf fs.FileExists(mPath & picname & ".bmp") Then
fullName = picname & ".bmp"
End If
If fullName <> "" Then
Set pic = cell_.Parent.Shapes.AddPicture(mPath & fullName, _
msoFalse, msoTrue, cell_.Left, cell_.Top, cell_.Width, cell_.Resize(4).Height)
pic.LockAspectRatio = msoTrue
pic.Name = cell_.Address
End If
Set cell_ = Nothing
Set fs = Nothing
End Function