|
正巧处理图形,突然发现一个很强的库GDI+,遂恶补一番!
VERSION 5.00
Begin VB.Form frmMain
BackColor = &H8000000A&
BorderStyle = 1 'Fixed Single
Caption = "品雅图片转换工具 Ver 2.0 (Power By 赵洪涛 2008.12 Email:waenzht@sina.com)"
ClientHeight = 7590
ClientLeft = 45
ClientTop = 330
ClientWidth = 9480
KeyPreview = -1 'True
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 379.5
ScaleMode = 2 'Point
ScaleWidth = 474
StartUpPosition = 2 '屏幕中心
Begin VB.Frame Frame1
BackColor = &H8000000A&
Caption = " 选项设置 "
Height = 1455
Left = 240
TabIndex = 5
Top = 240
Width = 9015
Begin VB.ComboBox Combo1
Height = 300
ItemData = "Form1.frx":0000
Left = 6240
List = "Form1.frx":000D
Style = 2 'Dropdown List
TabIndex = 21
Top = 1027
Width = 855
End
Begin VB.CommandButton Command4
BackColor = &H00FFFFFF&
Caption = "清除"
Height = 375
Left = 4080
Style = 1 'Graphical
TabIndex = 20
ToolTipText = "从列表中移除选定的项"
Top = 990
Width = 855
End
Begin VB.CommandButton Command2
Appearance = 0 'Flat
BackColor = &H00FFFFFF&
Caption = "选择图片"
Height = 375
Left = 3120
Style = 1 'Graphical
TabIndex = 19
ToolTipText = "插入新图片"
Top = 990
Width = 855
End
Begin VB.CommandButton Command1
Caption = "开始转换 ...(&C)"
Height = 375
Left = 7275
TabIndex = 0
Top = 990
Width = 1575
End
Begin VB.TextBox Text3
Enabled = 0 'False
Height = 270
Left = 5760
MaxLength = 4
TabIndex = 2
Text = "768"
Top = 225
Width = 615
End
Begin VB.TextBox Text2
Enabled = 0 'False
Height = 270
Left = 3720
MaxLength = 4
TabIndex = 1
Text = "1024"
Top = 225
Width = 615
End
Begin VB.OptionButton Option4
BackColor = &H8000000A&
Caption = "保持原大小，不进行缩放"
Height = 255
Left = 240
TabIndex = 10
Top = 1110
Value = -1 'True
Width = 2295
End
Begin VB.OptionButton Option3
BackColor = &H8000000A&
Caption = "自定义尺寸进行等比缩放"
Height = 255
Left = 240
TabIndex = 9
Top = 820
Width = 2295
End
Begin VB.OptionButton Option2
BackColor = &H8000000A&
Caption = "以高度为准进行等比缩放"
Height = 255
Left = 240
TabIndex = 8
Top = 530
Width = 2295
End
Begin VB.OptionButton Option1
BackColor = &H8000000A&
Caption = "以宽度为准进行等比缩放"
Height = 255
Left = 240
TabIndex = 7
Top = 240
Width = 2295
End
Begin VB.TextBox Text1
Height = 270
Left = 8010
MaxLength = 3
TabIndex = 3
Text = "80"
Top = 225
Width = 615
End
Begin VB.Label Label10
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "转换成："
ForeColor = &H00FF0000&
Height = 180
Left = 5490
TabIndex = 22
Top = 1087
Width = 720
End
Begin VB.Label Label4
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "0 %"
ForeColor = &H0000FFFF&
Height = 180
Left = 5880
TabIndex = 16
Top = 645
Width = 270
End
Begin VB.Label Label3
BackColor = &H00FF0000&
Height = 315
Left = 3135
TabIndex = 17
Top = 585
Width = 15
End
Begin VB.Label Label9
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "%"
ForeColor = &H00404040&
Height = 180
Left = 8760
TabIndex = 15
Top = 270
Width = 90
End
Begin VB.Label Label8
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "像素"
ForeColor = &H00404040&
Height = 180
Left = 6420
TabIndex = 14
Top = 270
Width = 360
End
Begin VB.Label Label7
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "高度："
ForeColor = &H00FF0000&
Height = 180
Left = 5160
TabIndex = 13
Top = 270
Width = 540
End
Begin VB.Label Label6
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "像素"
ForeColor = &H00404040&
Height = 180
Left = 4380
TabIndex = 12
Top = 270
Width = 360
End
Begin VB.Label Label5
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "宽度："
ForeColor = &H00FF0000&
Height = 180
Left = 3120
TabIndex = 11
Top = 270
Width = 540
End
Begin VB.Label Label2
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "清晰度："
ForeColor = &H00FF0000&
Height = 180
Left = 7200
TabIndex = 6
Top = 270
Width = 720
End
Begin VB.Label Label1
Appearance = 0 'Flat
BackColor = &H00808080&
BorderStyle = 1 'Fixed Single
ForeColor = &H80000008&
Height = 345
Left = 3120
TabIndex = 18
Top = 570
Width = 5730
End
End
Begin VB.ListBox List1
Height = 5460
Left = 240
MultiSelect = 2 'Extended
TabIndex = 4
Top = 1920
Width = 9015
End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Private Type DlgFileInfo
iCount As Long
sPath As String
sFile() As String
picType() As Integer
End Type
Private Type GUID ' 16 bytes (128 bits)
dwData1 As Long ' 4 bytes
wData2 As Integer ' 2 bytes
wData3 As Integer ' 2 bytes
abData4(7) As Byte ' 8 bytes,zero based
End Type
Private Type EncoderParameter
GUID As GUID
NumberOfValues As Long
type As Long
Value As Long
End Type
Private Type EncoderParameters
count As Long
Parameter As EncoderParameter
End Type
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Public Enum GpUnit ' aka Unit
UnitWorld ' 0 -- World coordinate (non-physical unit)
UnitDisplay ' 1 -- Variable -- for PageTransform only
UnitPixel ' 2 -- Each unit is one device pixel.
UnitPoint ' 3 -- Each unit is a printer's point,or 1/72 inch.
UnitInch ' 4 -- Each unit is 1 inch.
UnitDocument ' 5 -- Each unit is 1/300 inch.
UnitMillimeter ' 6 -- Each unit is 1 millimeter.
End Enum
Public Enum GpStatus 'Status
ok = 0
GenericError = 1
InvalidParameter = 2
OutOfMemory = 3
ObjectBusy = 4
InsufficientBuffer = 5
NotImplemented = 6
Win32Error = 7
WrongState = 8
Aborted = 9
FileNotFound = 10
ValueOverflow = 11
AccessDenied = 12
UnknownImageFormat = 13
FontFamilyNotFound = 14
FontStyleNotFound = 15
NotTrueTypeFont = 16
UnsupportedGdiplusVersion = 17
GdiplusNotInitialized = 18
PropertyNotFound = 19
PropertyNotSupported = 20
End Enum
Public Enum GpPixelFormat
' PixelFormat1bppIndexed = &H30101
' PixelFormat4bppIndexed = &H30402
' PixelFormat8bppIndexed = &H30803
' PixelFormat16bppGreyScale = &H101004
' PixelFormat16bppRGB555 = &H21005
' PixelFormat16bppRGB565 = &H21006
' PixelFormat16bppARGB1555 = &H61007
PixelFormat24bppRGB = &H21808
' PixelFormat32bppRGB = &H22009
' PixelFormat32bppARGB = &H26200A
' PixelFormat32bppPARGB = &HE200B
' PixelFormat48bppRGB = &H10300C
' PixelFormat64bppARGB = &H34400D
' PixelFormat64bppPARGB = &H1C400E
End Enum
Dim cPicPath As String
Private Const OFN_READONLY = &H1 '“以只读方式”为选中
Private Const OFN_OVERWRITEPROMPT = &H2 '隐藏“以只读方式”
Private Const OFN_HIDEREADONLY = &H4 '出现“是否覆盖”对话框
Private Const OFN_NOCHANGEDIR = &H8 '不能改变目录
Private Const OFN_SHOWHELP = &H10 '显示“帮助”
Private Const OFN_ENABLEHOOK = &H20 '使对话框钩子函数生效
Private Const OFN_ENABLETEMPLATE = &H40 '模板生效
Private Const OFN_ENABLETEMPLATEHANDLE = &H80 '模板句柄生效？？
Private Const OFN_NOVALIDATE = &H100 '允许非法字符
Private Const OFN_ALLOWMULTISELECT = &H200 '允许选择多个文件
Private Const OFN_EXTENSIONDIFFERENT = &H400
Private Const OFN_PATHMUSTEXIST = &H800 '路径必须存在
Private Const OFN_FILEMUSTEXIST = &H1000 '文件必须存在
Private Const OFN_CREATEPROMPT = &H2000 '出现“是否建立文件”对话框
Private Const OFN_SHAREAWARE = &H4000 '忽略共享冲突
Private Const OFN_NOREADONLYRETURN = &H8000
Private Const OFN_NOTESTFILECREATE = &H10000 '不进行文件创建测试
Private Const OFN_NONETWORKBUTTON = &H20000 '没有网络按键（旧风格专用）
Private Const OFN_NOLONGNAMES = &H40000 '不使用长文件名（旧风格专用）
Private Const OFN_EXPLORER = &H80000 '资源管理器风格（新风格）
Private Const OFN_NODEREFERENCELINKS = &H100000 '使*.lnk可以选中
Private Const OFN_LONGNAMES = &H200000 '使用长文件名（旧风格专用）
Private Const OFN_ENABLEINCLUDENOTIFY = &H400000 '准许包括通知？？
Private Const OFN_ENABLESIZING = &H800000 '可改变大小
Private Const OFN_USEMONIKERS = &H1000000
Private Const OFN_DONTADDTORECENT = &H2000000
Private Const OFN_FORCESHOWHIDDEN = &H10000000
Private Declare Function GdiplusStartup Lib "gdiplus" (token As Long,inputbuf As GdiplusStartupInput,Optional ByVal outputbuf As Long = 0) As GpStatus
Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As GpStatus
Private Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hdc As Long,graphics As Long) As GpStatus
Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As Long) As GpStatus
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As GpStatus
Private Declare Function GdipCreateImageAttributes Lib "gdiplus" (imageattr As Long) As GpStatus
Private Declare Function GdipDisposeImageAttributes Lib "gdiplus" (ByVal imageattr As Long) As GpStatus
Private Declare Function GdipDrawImageRect Lib "gdiplus" (ByVal graphics As Long,ByVal image As Long,ByVal X As Single,ByVal Y As Single,ByVal Width As Single,ByVal Height As Single) As GpStatus
Private Declare Function GdipDrawImageRectRect Lib "gdiplus" (ByVal graphics As Long,ByVal dstx As Single,ByVal dsty As Single,ByVal dstwidth As Single,ByVal dstheight As Single,ByVal SrcX As Single,ByVal SrcY As Single,ByVal srcwidth As Single,ByVal srcheight As Single,ByVal srcUnit As GpUnit,Optional ByVal imageAttributes As Long = 0,Optional ByVal callback As Long = 0,Optional ByVal callbackData As Long = 0) As GpStatus
Private Declare Function GdipCreateBitmapFromScan0 Lib "gdiplus" (ByVal Width As Long,ByVal Height As Long,ByVal stride As Long,ByVal PixelFormat As Long,scan0 As Any,bitmap As Long) As GpStatus
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As Long,ByVal hPal As Long,bitmap As Long) As GpStatus
Private Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal image As Long,ByVal FileName As Long,clsidEncoder As GUID,encoderParams As Any) As GpStatus
Private Declare Function GdipGetImageGraphicsContext Lib "gdiplus" (ByVal image As Long,ByRef graphics As Long) As GpStatus
Private Declare Function GdipLoadImageFromFile Lib "gdiplus" (ByVal FileName As Long,image As Long) As GpStatus
Private Declare Function GdipGetImageDimension Lib "gdiplus" (ByVal image As Long,ByRef Width As Single,ByRef Height As Single) As GpStatus
Private Declare Function GdipGraphicsClear Lib "gdiplus" (ByVal graphics As Long,ByVal lColor As Long) As GpStatus
Private Declare Function CLSIDFromString Lib "ole32" (ByVal Str As Long,id As GUID) As Long
Private Declare Function CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any,Src As Any,ByVal cb As Long) As Long
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Function GetDlgSelectFileInfo(strFilename As String) As DlgFileInfo
'思路： 用CommonDialog控件选择文件后，其Filename属性值如下：
' 1、如果选择的是"C:/Test.txt"， Filename="C:/Test.txt"， CurDir()="C:/"
' 2、如果选择的是"C:/1/Test.txt"，Filename="C:/1/Test.txt"， CurDir()="C:/1"
' 3、如果选择的是"C:/1.txt"和"C:/2.txt"，则：
' Filename="C:/1 1.txt 2.txt"， CurDir()="C:/1"
' 因此先将路径分离开，再利用多文件之间插入的Chr$(0)字符分解各个文件名即可。
Dim sPath,tmpStr As String
Dim sFile() As String
Dim iCount As Integer
Dim i As Integer,n As Integer,nOld As Integer
tmpStr = Trim(strFilename)
If Len(tmpStr) = 1 Then Exit Function
i = 1
nOld = 0
n = 1
Do While i > 0
n = InStr(nOld + 1,tmpStr,Chr$(0),vbBinaryCompare)
If n - nOld > 1 Then
iCount = iCount + 1
ReDim Preserve sFile(iCount)
sFile(iCount) = Mid$(tmpStr,nOld + 1,n - nOld - 1)
nOld = n
Else
i = 0
End If
Loop
If iCount <> 1 Then Exit Function
If iCount = 1 Then
n = InStrRev(sFile(1),"/")
GetDlgSelectFileInfo.iCount = 1
GetDlgSelectFileInfo.sPath = Mid(sFile(1),1,n)
ReDim GetDlgSelectFileInfo.sFile(1)
GetDlgSelectFileInfo.sFile(1) = Mid(sFile(1),n + 1)
ReDim GetDlgSelectFileInfo.picType(1)
Select Case UCase(Right(GetDlgSelectFileInfo.sFile(1),4))
Case ".BMP"
GetDlgSelectFileInfo.picType(1) = 1
Case ".GIF"
GetDlgSelectFileInfo.picType(1) = 2
Case Else
GetDlgSelectFileInfo.picType(1) = 3
End Select
Else
GetDlgSelectFileInfo.iCount = iCount - 1
ReDim GetDlgSelectFileInfo.sFile(iCount - 1)
ReDim GetDlgSelectFileInfo.picType(iCount - 1)
If Right$(sFile(1),1) <> "/" Then sFile(1) = sFile(1) & "/"
GetDlgSelectFileInfo.sPath = sFile(1)
For i = 2 To iCount
GetDlgSelectFileInfo.sFile(i - 1) = sFile(i)
Select Case UCase(Right(GetDlgSelectFileInfo.sFile(i - 1),4))
Case ".BMP"
GetDlgSelectFileInfo.picType(i - 1) = 1
Case ".GIF"
GetDlgSelectFileInfo.picType(i - 1) = 2
Case Else
GetDlgSelectFileInfo.picType(i - 1) = 3
End Select
Next i
End If
End Function
'*************************************************************************
'** 作 者 ： laviewpbt
'** 函 数 名 ： SavePic
'** 输 入 ： pic(StdPicture) - 图象句柄
'** ： FileName(String) - 保存路径
'** ： Quality(Byte) - JPG图象质量
'** ： TIFF_ColorDepth(Long) - TTF格式的颜色深度
'** ： TIFF_Compression(Long) - TTF格式的压缩比
'** 输 出 ： 无
'** 功能描述 ： 把图象保存为JPG、TIFF、PNG、GIF、BMP格式
'** 日 期 ：
'** 修 改 人 ： laviewpbt
'** 日 期 ： 2005-10-23 14.43.52
'** 版 本 ： Version 1.2.1
'*************************************************************************
Private Sub SavePic(ByVal pict As String,ByVal FileName As String,picType As String,_
Optional ByVal Quality As Byte = 80,_
Optional ByVal TIFF_ColorDepth As Long = 24,_
Optional ByVal TIFF_Compression As Long = 6)
Dim tSI As GdiplusStartupInput
Dim lRes As Long
Dim lGDIP As Long
Dim lBitmap As Long
Dim aEncParams() As Byte
Screen.MousePointer = vbHourglass
' On Error GoTo ErrHandle:
tSI.GdiplusVersion = 1 ' 初始化 GDI+
lRes = GdiplusStartup(lGDIP,tSI)
If lRes = 0 Then ' 从句柄创建 GDI+ 图像
' lRes = GdipCreateBitmapFromHBITMAP(pict.Handle,lBitmap)
lRes = GdipLoadImageFromFile(StrPtr(pict),lBitmap)
If lRes = 0 Then
Dim tJpgEncoder As GUID
Dim tParams As EncoderParameters '初始化解码器的GUID标识
Select Case picType
Case "jpg"
CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"),tJpgEncoder
tParams.count = 1 ' 设置解码器参数
With tParams.Parameter ' Quality
CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"),.GUID ' 得到Quality参数的GUID标识
.NumberOfValues = 1
.type = 4
.Value = VarPtr(Quality)
End With
ReDim aEncParams(1 To Len(tParams))
Call CopyMemory(aEncParams(1),tParams,Len(tParams))
Case "png"
CLSIDFromString StrPtr("{557CF406-1A04-11D3-9A73-0000F81EF32E}"),tJpgEncoder
ReDim aEncParams(1 To Len(tParams))
Case "gif"
CLSIDFromString StrPtr("{557CF402-1A04-11D3-9A73-0000F81EF32E}"),tJpgEncoder
ReDim aEncParams(1 To Len(tParams))
End Select
If Option4.Value Then '不缩放
lRes = GdipSaveImageToFile(lBitmap,StrPtr(FileName),tJpgEncoder,aEncParams(1)) '保存图像
Else
Dim nW As Single,nH As Single,nBL As Single '原始宽、高、比例
Dim nCurrW As Integer,nCurrH As Integer '新的宽、高
Dim GDICopyBitmap As Long,GDIGraphics As Long
Dim nTmpW As Integer,nTmpH As Integer,ImgAttr As Long
If GdipGetImageDimension(lBitmap,nW,nH) = 0 Then
'''''''''''''''''''''''不执行'''''''
If Option1.Value Then
nBL = nW / CInt(Text2.Text)
nCurrW = CInt(Text2.Text)
nCurrH = CInt(nH / nBL)
Call GdipCreateBitmapFromScan0(nCurrW,nCurrH,PixelFormat24bppRGB,ByVal 0&,GDICopyBitmap)
Call GdipGetImageGraphicsContext(GDICopyBitmap,GDIGraphics)
Call GdipDrawImageRect(GDIGraphics,lBitmap,nCurrW,nCurrH)
End If
If Option2.Value Then
nBL = nH / CInt(Text3.Text)
nCurrW = CInt(nW / nBL)
nCurrH = CInt(Text3.Text)
Call GdipCreateBitmapFromScan0(nCurrW,nCurrH)
End If
''''''''''''''''''''不执行'''''''''
'自定义尺寸进行等比缩放
If Option3.Value Then
If (nW / CInt(Text2.Text)) > (nH / CInt(Text3.Text)) Then
nBL = nW / CInt(Text2.Text)
nCurrW = CInt(Text2.Text)
nCurrH = CInt(nH / nBL)
Else
nBL = nH / CInt(Text3.Text)
nCurrW = CInt(nW / nBL)
nCurrH = CInt(Text3.Text)
End If
nTmpW = CLng(Text2.Text)
nTmpH = CLng(Text3.Text)
Call GdipCreateBitmapFromScan0(nTmpW,nTmpH,GDICopyBitmap)
' Call GdipCreateImageAttributes(ImgAttr)
Call GdipGetImageGraphicsContext(GDICopyBitmap,GDIGraphics)
GdipGraphicsClear GDIGraphics,&HFFFFFFFF
GdipDrawImageRect GDIGraphics,nTmpW,nTmpH '拉伸到100*200
'Call GdipDisposeImageAttributes(ImgAttr)
End If
Call GdipSaveImageToFile(GDICopyBitmap,aEncParams(1))
Call GdipDisposeImage(GDICopyBitmap)
Call GdipDeleteGraphics(GDIGraphics)
End If
End If
GdipDisposeImage lBitmap ' 销毁GDI+图像
End If
GdiplusShutdown lGDIP '销毁 GDI+
End If
Screen.MousePointer = vbDefault
Erase aEncParams
Exit Sub
ErrHandle:
Screen.MousePointer = vbDefault
MsgBox "在保存图片的过程中发生错误:" & vbCrLf & vbCrLf & "错误号: " & Err.Number & vbCrLf & "错误描述: " & Err.Description,vbInformation Or vbOKOnly,"错误"
End Sub
Private Sub Combo1_Click()
If Combo1.ListIndex > 0 Then
Text1.Enabled = False
Else
Text1.Enabled = True
End If
End Sub
Private Sub Command1_Click()
If List1.ListCount < 1 Then
MsgBox "请选择要转换的图片文件！",0 + 48,"错误信息"
Command2.SetFocus
Exit Sub
End If
Command1.Enabled = False
Command2.Enabled = False
Command4.Enabled = False
Text1.Enabled = False
Combo1.Enabled = False
Dim i As Integer,cTmp As String,nQuality As Byte
nQuality = CInt(Text1.Text)
For i = 1 To List1.ListCount
cTmp = Left(List1.List(i - 1),Len(List1.List(i - 1)) - 4)
If Dir(cTmp & "_pview." & LCase(Combo1.Text)) <> "" Then
Kill cTmp & "_pview." & LCase(Combo1.Text)
End If
DoEvents
' Call SavePic(LoadPicture(cPicPath & List1.List(i)),cPicPath & cTmp & "_pview.jpg",".jpg",CcInt(Text1.Text))
Call SavePic(List1.List(i - 1),cTmp & "_pview." & LCase(Combo1.Text),LCase(Combo1.Text),nQuality)
Label4.Caption = CInt(i / (List1.ListCount) * 100) & " %"
Label3.Width = CInt(i / (List1.ListCount) * 5700)
DoEvents
Next i
MsgBox "共转换了 " & List1.ListCount & " 个图片 ！",0 + 64,"提示信息"
Label4.Caption = "0 %"
Label3.Width = 0
Text1.Enabled = True
Combo1.Enabled = True
Command1.Enabled = True
Command2.Enabled = True
Command4.Enabled = True
End Sub
Private Sub Command2_Click()
Dim OpenFile As OPENFILENAME
Dim lReturn As Long,n As Integer
Static strFilter As String
Dim cTmp As String
strFilter = "All Pictures" & Chr(0) & "*.bmp;*.gif;*.jpg;*.jpeg;*.tif;*.png" & Chr(0) & _
"Bitmap (*.bmp)" & Chr(0) & "*.bmp" & Chr(0) & _
"GIF (*.gif)" & Chr(0) & "*.gif" & Chr(0) & _
"JPG (*.jpg;*.jpeg)" & Chr(0) & "*.jpg;*.jpeg" & Chr(0) & _
"TIF (*.tif)" & Chr(0) & "*.tif" & Chr(0) & _
"PNG (*.png)" & Chr(0) & "*.png" & Chr(0)
OpenFile.lStructSize = Len(OpenFile)
OpenFile.hwndOwner = Me.hwnd
OpenFile.hInstance = App.hInstance
OpenFile.lpstrFilter = strFilter
OpenFile.nFilterIndex = 1
OpenFile.lpstrFile = String(8192,0)
OpenFile.nMaxFile = 8192
OpenFile.lpstrFileTitle = Space(254)
OpenFile.nMaxFileTitle = 255
OpenFile.lpstrInitialDir = cPicPath
OpenFile.lpstrTitle = "选择文本文件"
OpenFile.flags = OFN_LONGNAMES Or OFN_NODEREFERENCELINKS Or OFN_EXPLORER Or OFN_HIDEREADONLY Or _
OFN_ENABLESIZING Or OFN_ALLOWMULTISELECT Or OFN_PATHMUSTEXIST Or OFN_FILEMUSTEXIST
lReturn = GetOpenFileName(OpenFile)
n = GetDlgSelectFileInfo(OpenFile.lpstrFile).iCount
If n > 0 Then
' If cPicPath <> GetDlgSelectFileInfo(OpenFile.lpstrFile).sPath Then
' List1.Clear
' End If
cPicPath = GetDlgSelectFileInfo(OpenFile.lpstrFile).sPath
For lReturn = 1 To n
List1.AddItem cPicPath & GetDlgSelectFileInfo(OpenFile.lpstrFile).sFile(lReturn)
Next
End If
End Sub
Private Sub Command4_Click()
If List1.ListCount = 1 Then Exit Sub
Dim i As Integer
For i = List1.ListCount - 1 To 0 Step -1
If List1.Selected(i) Then
List1.RemoveItem i
End If
Next i
End Sub
Private Sub Form_Initialize()
Combo1.ListIndex = 0
End Sub
Private Sub Form_KeyDown(KeyCode As Integer,Shift As Integer)
If KeyCode = 13 Then
SendKeys "{Tab}"
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
'Unload Form1
End Sub
Private Sub List1_Click()
If List1.ListCount < 1 Then Exit Sub
Dim w As Single,h As Single
Dim nB As Single,nB1 As Single,i As Integer
Dim gdip_Graphics As Long,gdip_Image As Long
Dim tSI As GdiplusStartupInput,lRes As Long,lGDIP As Long
Dim nCurrX As Integer,nCurrY As Integer
tSI.GdiplusVersion = 1 ' 初始化 GDI+
lRes = GdiplusStartup(lGDIP,tSI)
If lRes = 0 Then ' 从句柄创建 GDI+ 图像
lRes = GdipCreateFromHDC(Me.hdc,gdip_Graphics)
If lRes = 0 Then
lRes = GdipLoadImageFromFile(StrPtr(List1.Text),gdip_Image)
If lRes = 0 Then
Call GdipGetImageDimension(gdip_Image,w,h)
If Option1.Value Then
Me.Label6.Caption = "转前：" & w & " X " & h & " 像素 转后：" & Text2.Text & " X " & Int(h / w * CInt(Text2.Text)) & " 像素"
End If
If Option2.Value Then
Me.Label6.Caption = "转前：" & w & " X " & h & " 像素 转后：" & Int(w / h * CInt(Text3.Text)) & " X " & Text3.Text & " 像素"
End If
If Option3.Value Then
Me.Label6.Caption = "转前：" & w & " X " & h & " 像素 转后：" & Text2.Text & " X " & Text3.Text & " 像素"
End If
If Option4.Value Then
Me.Label6.Caption = "转前：" & w & " X " & h & " 像素 转后：" & w & " X " & h & " 像素"
End If
Me.Label6.Left = (Me.Width / 15 - Me.Label6.Width) / 2
If w = 284 And h = 164 Then
nCurrX = List1.Left + List1.Width - w
nCurrY = List1.Top + List1.Height - h
Call GdipDrawImageRect(gdip_Graphics,gdip_Image,Int((284 - w) / 2) + 1,Int((164 - h) / 2) + 1,h)
Else
nB = 284 / w
nB1 = 164 / h
If nB > nB1 Then
Call GdipDrawImageRect(gdip_Graphics,Int((164 - h * nB) / 2) + 1,284,Int(h * nB))
Else
Call GdipDrawImageRect(gdip_Graphics,Int((284 - w * nB1) / 2) + 1,Int(w * nB1),164)
End If
End If
Call GdipDisposeImage(gdip_Image)
End If
Call GdipDeleteGraphics(gdip_Graphics)
End If
GdiplusShutdown lGDIP '销毁 GDI+
End If
Me.Refresh
End SubPrivate Sub Option1_Click() Call CheckOptionEnd SubPrivate Sub Option2_Click() Call CheckOptionEnd SubPrivate Sub Option3_Click() Call CheckOptionEnd SubPrivate Sub Option4_Click() Call CheckOptionEnd SubPrivate Sub Text1_Validate(Cancel As Boolean) Call CheckText(Text1,80,10,100)End SubPrivate Sub Text2_Validate(Cancel As Boolean) Call CheckText(Text2,1024,2560)End SubPrivate Sub Text3_Validate(Cancel As Boolean) Call CheckText(Text3,768,1600)End SubFunction CheckText(oTxt As TextBox,nDef As Integer,nMin As Integer,nMax As Integer) Dim cTmp As String cTmp = Trim(oTxt.Text) If cTmp = "" Then oTxt.Text = nDef Exit Function End If If Not IsNumeric(cTmp) Then oTxt.Text = nDef Exit Function End If If CInt(cTmp) < nMin Or CInt(cTmp) > nMax Then oTxt.Text = nDef Exit Function End IfEnd FunctionFunction CheckOption() If Option1.Value Then Text2.Enabled = True Text3.Enabled = False Exit Function End If If Option2.Value Then Text2.Enabled = False Text3.Enabled = True Exit Function End If If Option3.Value Then Text2.Enabled = True Text3.Enabled = True Exit Function End If If Option4.Value Then Text2.Enabled = False Text3.Enabled = False Exit Function End IfEnd Function （编辑：李大同）
【声明】本站内容均来自网络，其相关言论仅代表作者个人观点，不代表本站立场。若无意侵犯到您的权利，请及时与联系站长删除相关内容!
|
