|
 
- 帖子
- 766
- 积分
- 1451
- 技术
- 117
- 捐助
- 0
- 注册时间
- 2010-5-12
|
4楼
发表于 2012-7-6 20:01
| 只看该作者
CrLf 发表于 2012-7-5 22:46 
XP系统中默认是没有WIA组件的。
w = 1024
h = 768
Set fso = CreateObject("Scripting.FileSystemObject")
Set dir = fso.GetFolder(".")
For Each file In dir.Files
exName = LCase(fso.GetExtensionName(file))
If exName = "jpg" Or exName = "gif" Or exName = "bmp" Or exName = "png" Then
Set Img = (New Image)(file.Path)
If Img.Width = w And Img.Height = h Then
fso.DeleteFile(file)
End If
End If
Next
Class Image
'Author: Demon
'Website: http://demon.tw
'Date: 2012/7/6
Private stream
Private M_SOF0
Private M_SOF1
Private M_SOF2
Private M_SOF3
Private M_SOF5
Private M_SOF6
Private M_SOF7
Private M_SOF9
Private M_SOF10
Private M_SOF11
Private M_SOF13
Private M_SOF14
Private M_SOF15
Private M_SOI
Private M_EOI
Private M_SOS
Private M_APP0
Private M_APP1
Private M_APP2
Private M_APP3
Private M_APP4
Private M_APP5
Private M_APP6
Private M_APP7
Private M_APP8
Private M_APP9
Private M_APP10
Private M_APP11
Private M_APP12
Private M_APP13
Private M_APP14
Private M_APP15
Private M_COM
Private M_PSEUDO
Private intWidth
Private intHeight
Private intBits
Private intChannels
Private Sub Class_Initialize()
Set stream = CreateObject("ADODB.Stream")
stream.Type = 1
stream.Mode = 3
stream.Open
M_SOF0 = &HC0
M_SOF1 = &HC1
M_SOF2 = &HC2
M_SOF3 = &HC3
M_SOF5 = &HC5
M_SOF6 = &HC6
M_SOF7 = &HC7
M_SOF9 = &HC9
M_SOF10 = &HCA
M_SOF11 = &HCB
M_SOF13 = &HCD
M_SOF14 = &HCE
M_SOF15 = &HCF
M_SOI = &HD8
M_EOI = &HD9
M_SOS = &HDA
M_APP0 = &HE0
M_APP1 = &HE1
M_APP2 = &HE2
M_APP3 = &HE3
M_APP4 = &HE4
M_APP5 = &HE5
M_APP6 = &HE6
M_APP7 = &HE7
M_APP8 = &HE8
M_APP9 = &HE9
M_APP10 = &HEA
M_APP11 = &HEB
M_APP12 = &HEC
M_APP13 = &HED
M_APP14 = &HEE
M_APP15 = &HEF
M_COM = &HFE
M_PSEUDO = &HFFD8
End Sub
Private Sub Class_Terminate()
stream.Close
End Sub
Public Default Function Init(path)
Dim fso, ext
Set fso = CreateObject("Scripting.Filesystemobject")
stream.LoadFromFile path
ext = LCase(fso.GetExtensionName(path))
Select Case ext
Case "gif" HandleGif()
Case "png" HandlePng()
Case "bmp" HandleBmp()
Case "jpg" HandleJpeg()
Case "jpeg" HandleJpeg()
Case Else Err.Raise 7575, "Image", "format not supported"
End Select
Set Init = Me
End Function
Public Property Get Width()
Width = intWidth
End Property
Public Property Get Height()
Height = intHeight
End Property
Public Property Get Bits()
Bits = intBits
End Property
Private Sub HandleGif()
Dim c0, c1, c2, c3, c4
stream.Position = 6
c0 = AscB(stream.Read(1))
c1 = AscB(stream.Read(1))
c2 = AscB(stream.Read(1))
c3 = AscB(stream.Read(1))
c4 = AscB(stream.Read(1))
intWidth = c0 Or (c1 * 2 ^ 8)
intHeight = c2 Or (c3 * 2 ^ 8)
If (c4 And &H80) Then
intBits = (c4 And &H07) + 1
Else
intBits = 0
End If
intChannels = 3
End Sub
Private Sub HandlePng()
Dim c0, c1, c2, c3, c4, c5, c6, c7, c8
stream.Position = 16
c0 = AscB(stream.Read(1))
c1 = AscB(stream.Read(1))
c2 = AscB(stream.Read(1))
c3 = AscB(stream.Read(1))
c4 = AscB(stream.Read(1))
c5 = AscB(stream.Read(1))
c6 = AscB(stream.Read(1))
c7 = AscB(stream.Read(1))
c8 = AscB(stream.Read(1))
intWidth = (c0 * 2 ^ 24) + (c1 * 2 ^ 16) + (c2 * 2 ^ 8) + c3
intHeight = (c4 * 2 ^ 24) + (c5 * 2 ^ 16) + (c6 * 2 ^ 8) + c7
intBits = c8
End Sub
Private Sub HandleBmp()
Dim c0, c1, c2, c3, c4, c5, c6, c7, c8, c9, c10, c11
Dim size, c12, c13, c14, c15
stream.Position = 14
c0 = AscB(stream.Read(1))
c1 = AscB(stream.Read(1))
c2 = AscB(stream.Read(1))
c3 = AscB(stream.Read(1))
c4 = AscB(stream.Read(1))
c5 = AscB(stream.Read(1))
c6 = AscB(stream.Read(1))
c7 = AscB(stream.Read(1))
c8 = AscB(stream.Read(1))
c9 = AscB(stream.Read(1))
c10 = AscB(stream.Read(1))
c11 = AscB(stream.Read(1))
c12 = AscB(stream.Read(1))
c13 = AscB(stream.Read(1))
c14 = AscB(stream.Read(1))
c15 = AscB(stream.Read(1))
size = (c3 * 2 ^ 24) + (c2 * 2 ^ 16) + (c1 * 2 ^ 8) + c0
If size = 12 Then
intWidth = (c5 * 2 ^ 8) + c4
intHeight = (c7 * 2 ^ 8) + c6
intBits = c11
ElseIf size > 12 And (size <= 64 Or size = 108) Then
intWidth = (c7 * 2 ^ 24) + (c6 * 2 ^ 16) + (c5 * 2 ^ 8) + c4
intHeight = (c11 * 2 ^ 24) + (c10 * 2 ^ 16) + (c9 * 2 ^ 8) + c8
intBits = (c15 * 2 ^ 8) + c14
End If
End Sub
Private Sub HandleJpeg()
Dim marker, ff_read, result, length
stream.Position = 3
ff_read = 1
marker = M_PSEUDO
Do
marker = NextMarker(stream, marker, 1, ff_read)
ff_read = 0
Select Case marker
Case M_SOF0, _
M_SOF1, _
M_SOF2, _
M_SOF3, _
M_SOF5, _
M_SOF6, _
M_SOF7, _
M_SOF9, _
M_SOF10, _
M_SOF11, _
M_SOF13, _
M_SOF14, _
M_SOF15
length = (AscB(stream.Read(1)) * 2 ^ 8) + AscB(stream.Read(1))
intBits = AscB(stream.Read(1))
intHeight = (AscB(stream.Read(1)) * 2 ^ 8) + AscB(stream.Read(1))
intWidth = (AscB(stream.Read(1)) * 2 ^ 8) + AscB(stream.Read(1))
intChannels = AscB(stream.Read(1))
Exit Sub
Case M_APP0, _
M_APP1, _
M_APP2, _
M_APP3, _
M_APP4, _
M_APP5, _
M_APP6, _
M_APP7, _
M_APP8, _
M_APP9, _
M_APP10, _
M_APP11, _
M_APP12, _
M_APP13, _
M_APP14, _
M_APP15
If SkipVariable(stream) = 0 Then Exit Sub
Case M_SOS, M_EOI
Exit Sub
Case Else
If SkipVariable(stream) = 0 Then
Exit Sub
End If
End Select
Loop
End Sub
Private Function SkipVariable(stream)
Dim length
length = (AscB(stream.Read(1)) * 2 ^ 8) + AscB(stream.Read(1))
If length < 2 Then
SkipVariable = 0
Exit Function
End If
length = length - 2
stream.Position = stream.Position + length
SkipVariable = 1
End Function
Private Function NextMarker(stream, last_marker, comment_correction, ff_read)
Dim a, marker
a = 1
If last_marker = M_COM And comment_correction Then
comment_correction = 2
Else
last_marker = 0
comment_correction = 0
End If
If ff_read Then a = 1
Do
If stream.EOS Then
NextMarker = M_EOI
Exit Function
End If
marker = AscB(stream.Read(1))
If last_marker = M_COM And comment_correction > 0 Then
If marker <> &HFF Then
marker = &HFF
comment_correction = comment_correction - 1
Else
last_marker = M_PSEUDO
End If
End If
a = a + 1
Loop While marker = &HFF
If a < 2 Then
NextMarker = M_EOI
Exit Function
End If
If last_marker = M_COM And comment_correction Then
NextMarker = M_EOI
Exit Function
End If
NextMarker = marker
End Function
End Class
|
-
1
评分人数
-
|
发表于 2012-7-5 22:46
| 
