Chinaunix首页 | 论坛 | 博客
  • 博客访问: 1220339
  • 博文数量: 124
  • 博客积分: 5772
  • 博客等级: 大校
  • 技术积分: 1647
  • 用 户 组: 普通用户
  • 注册时间: 2010-09-27 10:39
文章分类

全部博文(124)

文章存档

2020年(1)

2019年(1)

2018年(5)

2017年(2)

2016年(17)

2015年(3)

2014年(7)

2013年(11)

2012年(13)

2011年(30)

2010年(34)

分类: WINDOWS

2012-08-08 11:11:56

该程序使用自定义GetPhotoDate()函数获取照片或者录像的“拍摄日期”,作为该照片的文件名。有的照片或者录像没有”拍摄日期“,就不能使用该程序,应该用FileDateTime( )函数获取”创建日期“。

  1. Dim Index As Integer
  2. Private Type GdiplusStartupInput
  3.     GdiplusVersion As Long
  4.     DebugEventCallback As Long
  5.     SuppressBackgroundThread As Long
  6.     Suppres***ternalCodecs As Long
  7. End Type


  8. Private Type PropertyItem
  9.    propId As Long ' ID of this property
  10.    Length As Long ' Length of the property value, in bytes
  11.    Type As Long ' Type of the value, as one of TAG_TYPE_XXX defined above
  12.    Value As Long ' property value
  13. End Type


  14. Private Declare Function GdiplusStartup Lib "gdiplus" (Token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
  15. Private Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal Token As Long)
  16. Private Declare Function GdipLoadImageFromFile Lib "gdiplus" (ByVal filename As Long, hImage As Long) As Long
  17. Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As Long) As Long

  18. Private Declare Function GdipGetPropertyCount Lib "gdiplus" (ByVal Image As Long, numOfProperty As Long) As Long
  19. Private Declare Function GdipGetPropertyIdList Lib "gdiplus" (ByVal Image As Long, ByVal numOfProperty As Long, list As Long) As Long
  20. Private Declare Function GdipGetPropertyItemSize Lib "gdiplus" (ByVal Image As Long, ByVal propId As Long, Size As Long) As Long
  21. Private Declare Function GdipGetPropertyItem Lib "gdiplus" (ByVal Image As Long, ByVal propId As Long, ByVal propSize As Long, Buffer As Long) As Long
  22. Private Declare Function GdipGetPropertySize Lib "gdiplus" (ByVal Image As Long, totalBufferSize As Long, numProperties As Long) As Long
  23. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDst As Any, lpSrc As Any, ByVal ByteLength As Long)



  24. Private Function GetPhotoDate(ImagePath As String) As String
  25.     Dim Bitmap As Long
  26.     Dim Token As Long
  27.     Dim Index As Long
  28.     Dim PropertyCount As Long
  29.     Dim ItemSize As Long
  30.     Dim Prop As PropertyItem
  31.     Dim GdipInput As GdiplusStartupInput
  32.     Const PropertyTagExifDTOrig As Long = &H9003& ' Date & time of original

  33.     GdipInput.GdiplusVersion = 1
  34.     GdiplusStartup Token, GdipInput
  35.     GdipLoadImageFromFile StrPtr(ImagePath), Bitmap
  36.     GdipGetPropertyCount Bitmap, PropertyCount
  37.     ReDim PropertyList(PropertyCount - 1) As Long
  38.     GdipGetPropertyIdList Bitmap, PropertyCount, PropertyList(0)
  39.     For Index = 0 To PropertyCount - 1
  40.         GdipGetPropertyItemSize Bitmap, PropertyList(Index), ItemSize
  41.         ReDim Buffer(ItemSize - 1) As Byte
  42.         GdipGetPropertyItem Bitmap, PropertyList(Index), ItemSize, ByVal VarPtr(Buffer(0))
  43.         CopyMemory Prop, ByVal VarPtr(Buffer(0)), Len(Prop)
  44.         ReDim Data(ItemSize - 16) As Byte
  45.         CopyMemory Data(0), ByVal Prop.Value, ItemSize - 16
  46.         Select Case PropertyList(Index)
  47.         Case PropertyTagExifDTOrig
  48.             GetPhotoDate = StrConv(Data, vbUnicode)
  49.         End Select
  50.     Next
  51.     GdipDisposeImage Bitmap
  52.     GdiplusShutdown Token
  53. End Function




  54. Private Sub Command1_Click()
  55.     Dim filename, newfilename$, newfilenameback$, newfilenamekz$, filedt$, exname$
  56.     Dim i%, indexphoto%
  57.     Dim ii%, aa$, cc$
  58.     Dim photoname$(), attachnum%()
  59.     ReDim photoname(1 To File1.ListCount)
  60.     ReDim attachnum(1 To File1.ListCount)
  61.     
  62.     For i = 1 To File1.ListCount
  63.         attachnum(i) = 1
  64.         photoname(i) = ""
  65.     Next i
  66.     indexphoto = 1
  67.     
  68.     For i = 0 To File1.ListCount - 1
  69.         aa = ""
  70.         cc = ""
  71.         File1.ListIndex = i
  72.         filename = CStr(File1.filename)
  73.         exname = Right(filename, 4)
  74.         
  75.         filedt = GetPhotoDate("e:\photo\" & filename)
  76.         filedt = Trim(filedt)
  77.         'MsgBox filedt
  78.         newfilename = getdtname(filedt)
  79.         For ii = 1 To Len(newfilename)
  80.             cc = Mid(newfilename, ii, 1)
  81.             If IsNumeric(cc) = True Then
  82.                 aa = aa & cc
  83.             End If
  84.         Next ii
  85.         newfilename = aa
  86.         newfilenamekz = newfilename & exname
  87.         newfilenameback = newfilenamekz
  88.         '如果有重名的文件,就在文件名后增加一个数字,和重名文件区别开
  89.         If ifsamename(photoname(), newfilenamekz) = True Then
  90.             newfilenamekz = (newfilename & attachnum(Index)) & exname
  91.             attachnum(Index) = attachnum(Index) + 1
  92.         Else
  93.             photoname(indexphoto) = newfilenameback
  94.             indexphoto = indexphoto + 1
  95.         End If
  96.         
  97.         Name "e:\photo\" & filename As "e:\photo\" & newfilenamekz
  98.     Next i
  99.     MsgBox "OK!"
  100. End Sub

  101. Private Sub Form_Load()
  102.     File1.Path = "e:\photo\"
  103. End Sub
  104. Private Function getdtname(dt As String) As String
  105.     '文件的创建时间格式为2010-05-13 19:30:23,即为形参dt。
  106.     '通过getdtname函数得到以文件创建时间为名字的文件名,格式为20100513193023
  107.     Dim dtarray() As String, darray() As String, tarray() As String
  108.     If Len(dt) > 0 Then
  109.         dtarray() = Split(dt)
  110.         'MsgBox dtarray(0)
  111.         'MsgBox dtarray(1)
  112.         darray() = Split(dtarray(0), ":")
  113.         'MsgBox darray(0)
  114.         'MsgBox darray(1)
  115.         'MsgBox darray(2)
  116.         tarray() = Split(dtarray(1), ":")
  117.         'MsgBox tarray(0)
  118.         'MsgBox tarray(1)
  119.         'MsgBox tarray(2)
  120.         If Len(darray(1)) = 1 Then darray(1) = 0 & darray(1)
  121.         If Len(darray(2)) = 1 Then darray(2) = 0 & darray(2)
  122.         If Len(tarray(0)) = 1 Then tarray(0) = 0 & tarray(0)
  123.         If Len(tarray(1)) = 1 Then tarray(1) = 0 & tarray(1)
  124.         If Len(tarray(2)) = 1 Then tarray(2) = 0 & tarray(2)
  125.         getdtname = darray(0) & darray(1) & darray(2) & tarray(0) & tarray(1) & tarray(2)
  126.     End If

  127. End Function
  128. Private Function ifsamename(name$(), destname As String) As Boolean
  129. '判断和destname是否有重名的文件
  130.     Dim Length As Integer, name_index%
  131.     'length = UBound(name()) - LBound(name()) + 1
  132.     For name_index = LBound(name()) To UBound(name())
  133.         If destname = name(name_index) Then
  134.             ifsamename = True
  135.             Index = name_index
  136.             Exit For
  137.         Else
  138.             ifsamename = False
  139.         End If
  140.     Next name_index
  141.         
  142. End Function
 用照片的拍照日期命名.rar   
阅读(4360) | 评论(0) | 转发(0) |
给主人留下些什么吧!~~