Question

用vb做图片浏览器，旋转代码？？

我用vb设计了一个图片浏览器，想设计一个按钮，控制图片旋转，顺时针或者逆时针，请各位高手帮忙写一下代码，谢谢！

另附我已设计好的代码：（无旋转功能）

Private Sub Command3_Click() '结束按钮
Dim exi As String
exi = MsgBox("您真的想退出吗？", vbYesNo + vbQuestion + vbDefaultButton1, "退出")
If exi = vbYes Then
End
End If
End Sub

Private Sub Command2_Click() '图片缩小程序
Image1.Height = Image1.Height - 50
Image1.Width = Image1.Width - 50 '按下的时候控件的高和宽各减小50
End Sub

Private Sub Command1_Click() '图片放大程序
Image1.Height = Image1.Height + 50
Image1.Width = Image1.Width + 50 '按下的时候控件的高和宽各增加50
End Sub

Private Sub Command4_Click() '图片清除程序
Image1.Picture = LoadPicture
Image1.Enabled = False
End Sub
Private Sub Command5_Click()
'上一张按钮
If File1.ListCount > 0 Then
Dim nextID As Long
'当前的id-1
nextID = File1.ListIndex - 1
'如果是第一张,就跳到最后一张
If nextID < 0 Then nextID = File1.ListCount - 1
'在列表中选中
File1.Selected(nextID) = True
'加载
Image1.Picture = LoadPicture(File1)
End If
End Sub
Private Sub Command6_Click()
'下一张按钮
If File1.ListCount > 0 Then
Dim nextID As Long
nextID = File1.ListIndex + 1
If nextID >= File1.ListCount Then nextID = 0

File1.Selected(nextID) = True
Image1.Picture = LoadPicture(File1)
End If
End Sub

Private Sub Dir1_Change() '目录改变，文件控件中显示的文件改变．
ChDir Dir1.Path
File1.Pattern = "*.jpeg;*.jpg;*.bmp;*.ico" '只能装入扩展名为.BMP、.JPG、.ICO的文件
File1.Path = Dir1.Path
End Sub

Private Sub Drive1_Change() '驱动器改变，目录控件显示改变后驱动器的文件夹
ChDrive Drive1.Drive
Dir1.Path = Drive1.Drive
End Sub

Private Sub File1_Click() '单击控件中文件名称的事件
Text1.Text = File1.Path + "\" + File1 '用来在文本框中显示被选中的图形名
Image1.Picture = LoadPicture(File1.Path + "\" + File1) '当双击文件列表中的文件时,文件在图像框中显示出来
End Sub

Private Sub Form1_Load() '程序装载，开始程序
File1.Pattern = "*.jpeg;*.jpg;*.bmp;*.ico" '在文件列表框中显示扩展名为.BMP、.JPG、.ICO的文件
End Sub

Answer 1

VB6.0实现图片旋转

使用过ACDSEE的朋友一定对它的JPG图片旋转功能记忆犹新，其实我们利用VB6的先进功能，可以对任意格式的图片文件（包括JPG、GIF、BMP、ICO等）进行45度、180度旋转，确实可以和ACDSEE一较高下。
启动vb6建立一个标准exe工程，首先添加两个图片框（picture1和picture2），添加三个命令按钮command1（caption=“正常显示”）、command2（caption=“180度倒立”）、command3（caption=“45度旋转”），双击窗体，写入以下代码：
PrivateConstSRCCOPY=&HCC0020
PrivateConstPi=3.14
PrivateDeclareFunctionSetPixelLib"gdi32"(ByValhdcAsLong, ByValxAsLong,ByValyAsLong,ByValcrColorAsLong)AsLong
PrivateDeclareFunctionGetPixelLib"gdi32"(ByValhdcAsLong, ByValxAsLong,ByValyAsLong)AsLong

PrivateDeclareFunctionStretchBltLib"gdi32"(ByValhdcAsLong, ByValxAsLong,ByValyAsLong,ByValnWidthAsLong,ByValnHeightAsLong, ByValhSrcDCAsLong,ByValxSrcAsLong,ByValySrcAsLong,ByValnSrcWidth AsLong,ByValnSrcHeightAsLong,ByValdwRopAsLong)AsLong

privateSubbmp_rotate(pic1AsPictureBox,pic2AsPictureBox,ByValtheta)‘45度旋转
Dimc1xAsInteger,c1yAsInteger
Dimc2xAsInteger,c2yAsInteger
DimaAsSingle
Dimp1xAsInteger,p1yAsInteger
Dimp2xAsInteger,p2yAsInteger
DimnAsInteger,rAsInteger

c1x=pic1.ScaleWidth\2
c1y=pic1.ScaleHeight\2
c2x=pic2.ScaleWidth\2
c2y=pic2.ScaleHeight\2
Ifc2x<c2yThenn=c2yElsen=c2x
n=n-1
pic1hDC=pic1.hdc
pic2hDC=pic2.hdc
Forp2x=0Ton
Forp2y=0Ton
Ifp2x=0Thena=Pi/2Elsea=Atn(p2y/p2x)
r=Sqr(1&*p2x*p2x+1&*p2y*p2y)
p1x=r*Cos(a+theta)
p1y=r*Sin(a+theta)
c0&=GetPixel(pic1hDC,c1x+p1x,c1y+p1y)
c1&=GetPixel(pic1hDC,c1x-p1x,c1y-p1y)
c2&=GetPixel(pic1hDC,c1x+p1y,c1y-p1x)
c3&=GetPixel(pic1hDC,c1x-p1y,c1y+p1x)
Ifc0&<>-1ThenSetPixelpic2hDC,c2x+p2x,c2y+p2y,c0
Ifc1&<>-1ThenSetPixelpic2hDC,c2x-p2x,c2y-p2y,c1
Ifc2&<>-1ThenSetPixelpic2hDC,c2x+p2y,c2y-p2x,c2
Ifc3&<>-1ThenSetPixelpic2hDC,c2x-p2y,c2y+p2x,c3
Next
Next
EndSub

PrivateSubCommand1_Click()‘正常复制
Picture2.Cls
px=Picture1.ScaleWidth
py=Picture1.ScaleHeight
StretchBltPicture2.hdc,px,0,-px,py,Picture1.hdc,0,0,px,py,SRCCOPY
EndSub

PrivateSubCommand2_Click()‘180度倒立
Picture2.Cls
px=Picture1.ScaleWidth
py=Picture1.ScaleHeight
StretchBltPicture2.hdc,0,py,px,-py,Picture1.hdc,0,0,px,py,SRCCOPY
EndSub

PrivateSubCommand3_Click()‘45旋转
Picture2.Cls
Callbmp_rotate(Picture1,Picture2,3.14/4)
EndSub

PrivateSubForm_Load()
onErrorResumeNext
Me.Caption=App.Title"添加应用程序标题
Me.Left=(Screen.Width-Me.Width)/2
Me.Top=(Screen.Height-Me.Height)/2"窗体具中
Picture1.ScaleMode=3
Picture2.ScaleMode=3
EndSub
我只会做到下面的代码了.其中:
Dir1-目录列表控件
Drive1-驱动器列表控件
File1-文件列表控件
Image1-图像控件
Text1-文本框控件
Option1-单选控件(Caption为"通过单击浏览")
Option2-单选控件(Caption为"通过双击浏览")

Private Sub Dir1_Change()
File1.Path = Dir1.Path
End Sub
Private Sub Drive1_Change()
On Error GoTo DriErr
Dir1.Path = Drive1.Drive
Exit Sub
DriErr:
If Err.Number = 68 Then
If MsgBox("请问要重试还是取消?", vbRetryCancel + vbCritical, "硬盘不存在或光驱没有插入磁盘!") = vbRetry Then
Resume 0
Else
Drive1.Drive = "C:"
Resume Next
End If
End If
End Sub
Private Sub File1_Click()
If Option2.Value = True Then Exit Sub
Dim picFile As String
If Right(Dir1.Path, 1) = "\" Then
picFile = Dir1.Path + File1.FileName
Else
picFile = Dir1.Path + "\" + File1.FileName
End If
Image1.Picture = LoadPicture(picFile)
Text1.Text = picFile
End Sub
Private Sub File1_DblClick()
If Option1.Value = True Then Exit Sub
Dim picFile As String
If Right(Dir1.Path, 1) = "\" Then
picFile = Dir1.Path + File1.FileName
Else
picFile = Dir1.Path + "\" + File1.FileName
End If
Image1.Picture = LoadPicture(picFile)
Text1.Text = picFile
End Sub

Answer 2

mark 学习