求老师帮忙实现合并单元格图片批量插入，急

zhang6029

Option Explicit
Private Function FindPicDate(PicFile As String) As String
    Dim bytes() As Byte
    Dim sLine() As String
    Dim fSize As Long, ExifDate As Long
    Dim i As Long, d As Long
    Dim ff      As Integer
    Dim Found   As Boolean
   
    ff = FreeFile
    fSize = FileLen(PicFile)
     
    If fSize > 1024 Then fSize = 1024
    ReDim bytes(1 To fSize)
    Open PicFile For Binary As #ff
        Get #ff, 1, bytes
    Close ff
      
    sLine = Split(StrConv(bytes(), vbUnicode), Chr$(0))
   
    For i = 0 To UBound(sLine)
        ExifDate = InStr(1, sLine(i), "xif")
        If ExifDate > 0 Then
            Found = True
            Exit For
        End If
    Next i
        
    If Found = False Then Exit Function
   
    For d = i + 1 To UBound(sLine)
        ExifDate = InStr(1, sLine(d), ":")
        If ExifDate > 0 Then
            FindPicDate = sLine(d)
            Exit For
        End If
    Next d
            
End Function

小绿草

学习学习。。。。。。

lbp6688

谢谢，还是实现了好多功能，爱死你们了………………

不知道为什么

liulang0808 发表于 2018-8-16 14:33
不好意思，没有注意是拍摄时间截图的提取时间不知道对不对。一会有空再整合下代码

版主太强大了，截图效果的代码分享 让我学习下啊。谢谢

lbp6688

不知道为什么 发表于 2018-8-16 14:36
呵呵，版主您客气了。确实这个拍摄时间不太好取。如果您解决了，分享下代码哈，谢谢！

http://club.excelhome.net/thread-480091-1-1.html看看这个帖子

liulang0808

lbp6688 发表于 2018-8-16 15:04
http://club.excelhome.net/thread-480091-1-1.html看看这个帖子

楼主能提供下照片拍摄时间吗？
我的电脑系统比较老，没有其他看图软件，无法看具体拍摄时间

lbp6688

liulang0808 发表于 2018-8-16 18:34
楼主能提供下照片拍摄时间吗？
我的电脑系统比较老，没有其他看图软件，无法看具体拍摄时间

1.jpg时间2012-8-30    2.jpg时间2012-8-30  3.jpg时间2007-11-10    4.jpg时间2007-11-10

qqyyh

好好学习了！！

02761752696

路过     学习  

liulang0808

1. Sub 按钮1_Click()
   
2.     a = 1
   
3.     Set fso = CreateObject("scripting.filesystemobject")
   
4.     Set objShell = CreateObject("shell.application")
   
5.     Application.ScreenUpdating = False
   
6.     Set objFolder = objShell.Namespace(ThisWorkbook.Path)
   
7.     For Each f In fso.getfolder(ThisWorkbook.Path).Files
   
8.         If InStr(f.Name, ".xls") = 0 Then
   
9.             Cells(a, 1).Select
   
10.             Set Rng = Selection
    
11.             Set objFolderItem = objFolder.ParseName(f.Name)
    
12.             pth = f
    
13.             Set photo = ActiveSheet.Pictures.Insert(pth)
    
14.             With photo
    
15.               .Name = f.Name
    
16.               .ShapeRange.LockAspectRatio = msoFalse
    
17.               .Top = Rng.Top
    
18.               .Left = Rng.Left
    
19.               .Width = Rng.Width
    
20.               .Height = Rng.Height
    
21.             End With
    
22.             Cells(a + 3, 3) = objFolder.GetDetailsOf(objFolderItem, 25)
    
23.             Cells(a + 2, 3) = Split(f.Name, ".")(0)
    
24.             a = a + 9
    
25.         End If
    
26.     Next f
    
27.     Application.ScreenUpdating = True
    
28. End Sub
    

复制代码