www.pudn.com > imagescale---raw.zip > Form1.frm
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form Form1
Caption = "Form1"
ClientHeight = 6795
ClientLeft = 60
ClientTop = 345
ClientWidth = 9480
Icon = "Form1.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 453
ScaleMode = 3 'Pixel
ScaleWidth = 632
StartUpPosition = 2 '屏幕中心
Begin MSComDlg.CommonDialog CD
Left = 8520
Top = 2520
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.CommandButton Command2
Caption = "平滑缩放处理"
Height = 375
Left = 8040
TabIndex = 7
Top = 1800
Width = 1335
End
Begin VB.TextBox txtMag
Alignment = 2 'Center
Height = 270
Left = 8400
Locked = -1 'True
TabIndex = 6
Text = "1"
Top = 1320
Width = 735
End
Begin VB.HScrollBar HSBMag
Height = 255
LargeChange = 10
Left = 8040
Max = 50
Min = 1
TabIndex = 5
Top = 1080
Value = 20
Width = 1335
End
Begin VB.CommandButton Command1
Caption = "选择图片"
Height = 375
Left = 8040
TabIndex = 4
Top = 120
Width = 1335
End
Begin VB.HScrollBar HorzSB
Enabled = 0 'False
Height = 255
Left = 0
TabIndex = 3
Top = 6480
Width = 7695
End
Begin VB.VScrollBar VertSB
Enabled = 0 'False
Height = 6495
Left = 7680
TabIndex = 2
Top = 0
Width = 255
End
Begin VB.Frame Frame1
Appearance = 0 'Flat
BackColor = &H00000000&
BorderStyle = 0 'None
Caption = "Frame1"
ForeColor = &H80000008&
Height = 6495
Left = 0
TabIndex = 0
Top = 0
Width = 7695
Begin VB.PictureBox PIC
AutoRedraw = -1 'True
AutoSize = -1 'True
BackColor = &H00000000&
BorderStyle = 0 'None
Height = 5415
Left = 0
ScaleHeight = 361
ScaleMode = 3 'Pixel
ScaleWidth = 513
TabIndex = 1
Top = 0
Width = 7695
Begin VB.PictureBox P2
AutoRedraw = -1 'True
AutoSize = -1 'True
BackColor = &H00000000&
BorderStyle = 0 'None
Height = 1455
Left = 2280
ScaleHeight = 97
ScaleMode = 3 'Pixel
ScaleWidth = 129
TabIndex = 10
Top = 3000
Visible = 0 'False
Width = 1935
End
Begin VB.PictureBox P1
AutoRedraw = -1 'True
BackColor = &H00000000&
BorderStyle = 0 'None
Height = 1455
Left = 120
ScaleHeight = 97
ScaleMode = 3 'Pixel
ScaleWidth = 129
TabIndex = 9
Top = 3000
Visible = 0 'False
Width = 1935
End
End
End
Begin VB.Label Label2
Alignment = 2 'Center
Height = 375
Left = 7920
TabIndex = 11
Top = 2280
Width = 1575
End
Begin VB.Label Label1
Alignment = 2 'Center
Caption = "缩放比例选择(0.1--2.0)"
Height = 375
Left = 8040
TabIndex = 8
Top = 720
Width = 1455
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Base 1
DefLng A-W
DefSng X-Z
Private Sub GeneratePalBGRs()
GETDIBS P1.Image
' Save 2 copies of palette
PalSize = 4 * PICW * PICH ' Bytes
'CopyMemory PalBGR(1, 1, 1, 2), PalBGR(1, 1, 1, 1), PalSize
CopyMemory PalBGR(1, 1, 1, 3), PalBGR(1, 1, 1, 1), PalSize
End Sub
Private Sub GETDIBS(ByVal PICIM As Long)
' PICM is PIC.Image - handle to PIC picbox
On Error GoTo DIBError
'Get info on picture loaded into PIC
GetObjectAPI PICIM, Len(bmp), bmp
NewDC = CreateCompatibleDC(0&)
OldH = SelectObject(NewDC, PICIM)
' Set up bm struc for GetDIBits & StretchDIBits
With bm.bmiH
.biSize = 40
.biwidth = bmp.bmWidth
.biheight = bmp.bmHeight
.biPlanes = 1
.biBitCount = 32 ' Sets up BGRA pixels
.biCompression = 0
BytesPerScanLine = ((((.biwidth * .biBitCount) + 31) \ 32) * 4)
PadBytesPerScanLine = _
BytesPerScanLine - (((.biwidth * .biBitCount) + 7) \ 8)
.biSizeImage = BytesPerScanLine * Abs(.biheight)
End With
' Set PalBGR to receive color bytes
ReDim PalBGR(4, PICW, PICH, 3) As Byte
' Load color bytes to 1st third of PalBGR
ret = GetDIBits(NewDC, PICIM, 0, PICH, PalBGR(1, 1, 1, 1), bm, 1)
' Clear mem
SelectObject NewDC, OldH
DeleteDC NewDC
Exit Sub
'==========
DIBError:
MsgBox "Error"
On Error GoTo 0
End Sub
Private Sub Command1_Click()
Erase PalBGR
CD.Filter = "Pictures (*.bmp *.gif *.jpg *.wmf *.ico *.cur)|*.bmp;*.gif;*.jpg;*.wmf;*.ico;*.cur|All files|*.*"
CD.ShowOpen
INIT_PIC
PIC.Visible = True
'/////////////////////////////////////
Dim w As Long
Dim h As Long
Dim r As Long
P2.Picture = LoadPicture(CD.FileName)
w = P2.Width
h = P2.Height
If w > 800 Or h > 800 Then
r = MsgBox("图像太大读入和处理速度较慢！是否继续？", vbQuestion + vbYesNo + vbDefaultButton2, "提醒")
If r = vbNo Then
PIC.Picture = LoadPicture()
Exit Sub
End If
End If
Form1.Caption = "快速平滑缩放演示--" & CD.FileName & " ( " & w & " × " & h & " )"
P1.Width = w * 2
P1.Height = h * 2
Set P1.Picture = Nothing
P1.BackColor = 0 'P2.Point(0, 0)
BitBlt P1.HDC, w / 2, h / 2, w, h, P2.HDC, 0, 0, vbSrcCopy
' P1.PaintPicture P2.Picture, (l - P2.Width) \ 2, (l - P2.Height) \ 2, P2.Width, P2.Height, 0, 0
'PIC.Picture = P1.Image
'///////////////////////////////////////
PIC.Picture = P2.Image
PICW = PIC.ScaleWidth
PICH = PIC.ScaleHeight
SetPICScrollBars
PICW = P1.ScaleWidth
PICH = P1.ScaleHeight
iXp = PICW / 2
iYp = PICH / 2
MousePointer = vbHourglass
'Refresh
GeneratePalBGRs
'---------------------
'ShowPalBGR 2
MousePointer = vbDefault
End Sub
Private Sub Command2_Click()
Dim t
PIC.Visible = False
PIC.Picture = P1.Image
t = timeGetTime
ASM_Magnify
Label2.Caption = "耗时：" & CStr(timeGetTime - t) & " 毫数"
SetPICScrollBars
End Sub
Private Sub Form_Load()
Form1.Caption = "快速平滑缩放演示(图像大小最好在800×800之内)"
INIT_PIC
HSBMag.Min = 1
HSBMag.Max = 20
HSBMag.SmallChange = 1
HSBMag.LargeChange = 1
HSBMag.Value = 10
zMag = HSBMag.Value / 10
txtMag.Text = Str$(zMag)
ReDim PalLineCopy(1, 1)
Get_ASM_Code
End Sub
Private Sub Get_ASM_Code()
I_ASM "5589E581EC780000005756538B5D08FF338F45FCFF73048F45F8FF73088F45F4FF730C8F45F0FF73108F45ECFF" & _
"73148F45E8FF73188F45E48B450C8945D88B45108945D48B45148945BCB80A0000008945ACD9E8DB45BCDB45AC" & _
"DEF9DEF9D95DBC8B45F88B5DFCF7E38945E08B45FCC1E0048945DC8B45E825FF0000008945C08B45E82500FF00" & _
"00C1E8088945C48B45E8250000FF00C1E8108945C8DB45F8D945D4DEE9D95DD4B8020000008945B0D9E8DB45B0" & _
"DEF9D95DB08B45E43D00000000750AE81F000000E9110000003D01000000750AE826000000E9000000005B5E5F" & _
"89EC5DC210008B7DF48B45E0C1E00201C78B75F401C601C6E819000000C38B7DF48B45E0C1E00201C78B75F401" & _
"C601C6E8C2000000C38B45F889C1894DCC518B45FC89C1894DD0DB45D0D945D8DEE9D945BCDEC9D945D8DEC1DB" & _
"5DA88B45A83D010000007C053B45FC7E1D57E88B0200008B45C888078B45C48847018B45C08847025FE95F0000" & _
"00DB45CCD945D4DEE9D945BCDEC9D945D4DEC1DB5DA48B45A43D010000007C053B45F87E1D57E84A0200008B45" & _
"C888078B45C48847018B45C08847025FE91E0000005756E817020000E8270200008A0688078A46018847018A46" & _
"028847025E5F490F8556FFFFFF59490F8545FFFFFFC38B45F889C1894DCC518B45FC89C1894DD0DB45D0D945D8" & _
"DEE9D945BCDEC9D945D8DEC1D95DA0DB45CCD945D4DEE9D945BCDEC9D945D4DEC1D95D9CD945A0D945B0DEE9DB" & _
"5DA8D9459CD945B0DEE9DB5DA48B45A83D010000007C193B45FC7D148B45A43D010000007C0A3B45F87D05E91D" & _
"00000057E88B0100008B45C888078B45C48847018B45C08847025FE914010000D945A0DB45A8DEE9D95D98D945" & _
"9CDB45A4DEE9D95D9456E8430100008B5DFCC1E3020FB606894590DB45900FB64604894590DB4590D8E1D94598" & _
"DEC9DEC10FB6041E894590DB45900FB6441E04894590DB4590D8E1D94598DEC9DEC1D8E1D94594DEC9DEC1DB5D" & _
"90460FB60689458CDB458C0FB6460489458CDB458CD8E1D94598DEC9DEC10FB6041E89458CDB458C0FB6441E04" & _
"89458CDB458CD8E1D94598DEC9DEC1D8E1D94594DEC9DEC1DB5D8C460FB606894588DB45880FB64604894588DB" & _
"4588D8E1D94598DEC9DEC10FB6041E894588DB45880FB6441E04894588DB4588D8E1D94598DEC9DEC1D8E1D945" & _
"94DEC9DEC1DB5D885EE82800000057E8720000008B459088078B458C8847018B45888847025F490F8562FEFFFF" & _
"59490F8551FEFFFFC3B8FF0000003945907E0389459039458C7E0389458C3945887E03894588B8000000003945" & _
"907D0389459039458C7D0389458C3945887D03894588C38B45A4488B5DFCF7E38B5DA84B01D8C1E00201C6C38B" & _
"45CC488B5DFCF7E38B5DD04B01D8C1E00201C7C38B45A4488B5DFCF7E38B5DA84B01D8C1E00201C7C3"
End Sub
Private Sub I_ASM(s As String)
s = Replace$(s, " ", "")
Dim i As Long, aSize As Long
aSize = Len(s) \ 2
ReDim PicMagnifyMC(0 To aSize - 1)
For i = 0 To aSize - 1
PicMagnifyMC(i) = Val("&H" & Mid$(s, i * 2 + 1, 2))
Next
End Sub
Private Sub Form_Unload(Cancel As Integer)
Erase PalBGR
Erase PicMagnifyMC
End Sub
Private Sub HSBMag_Change()
zMag = HSBMag.Value / 10
txtMag.Text = Str$(zMag)
End Sub
Private Sub SetPICScrollBars()
If PICW > PicFrameW Then
HorzSB.Enabled = True
HorzSB.Min = 0
HorzSB.Max = PICW - PicFrameW
HorzSB.LargeChange = PICW / 10
HorzSB.Value = 0
Else
HorzSB.Enabled = False
End If
If PICH > PicFrameH Then
VertSB.Enabled = True
VertSB.Min = 0
VertSB.Max = PICH - PicFrameH
VertSB.LargeChange = PICH / 10
VertSB.Value = 0
Else
VertSB.Enabled = False
End If
End Sub
Private Sub INIT_PIC()
' Fix locations
PicFrameW = 513
PicFrameH = 433
With Frame1
.Top = 0
.Left = 0
.Width = PicFrameW
.Height = PicFrameH
End With
With PIC
.Cls
.Top = 0
.Left = 0
.Width = (PicFrameW) * 15
.Height = (PicFrameH) * 15
End With
End Sub
Private Sub VertSB_Change()
PIC.Top = -VertSB.Value * 15
PIC.Refresh
End Sub
Private Sub HorzSB_Change()
PIC.Left = -HorzSB.Value * 15
PIC.Refresh
End Sub