压缩上传 - 专家坐堂 - Foxtable(狐表) - 新一代数据库软件，完美融合Access、Foxpro、Excel、vb.net之优势，人人都能掌握的快速软件开发工具!

Dim ftp1 As New FtpClient

ftp1.Host="

ftp1.Account =

ftp1.Password =

Dim wjm As String=""

If Tables("拍户口_table1").Rows.Count>0

Dim r As Row = Tables("拍户口_table1").Current

If ValidPIN(r("身份证件号"))= True

wjm = r("身份证件号") & ".jpg"

ElseIf r("学籍号")>""

wjm= r("学籍号") & ".jpg"

Else

messagebox.show("该学生的身份证号和学籍号中至少有一个要正确完整")

Return

End If

If wjm>""

Dim pic As WinForm.PictureBox = e.Form.Controls("PicView2")

Dim img As Image

If pic.Image IsNot Nothing

Dim buffer() As Byte = Functions.Execute("GetImageToBytes",pic.Image)

Dim result As Integer = Functions.Execute("SaveBytesToFile",buffer,wjm)

Dim fl As String=ProjectPath & "RemoteFiles\xp\" & FileSys.GetName(wjm)

pic.image.save(fl)

Dim fileInfo As new FileInfo(fl)

Dim file As String = fl

img = getImage(file)

Dim bmp As bitmap

bmp = new bitmap(img, 100, 100 * (img.height / img.width))

bmp.save(ProjectPath & "RemoteFiles\xp\" & FileSys.GetName(wjm), ImageFormat.Jpeg)

bmp.Dispose

Dim ifo As new FileInfo(wjm)

If ftp1.Upload(wjm,"\xp\" & FileSys.GetName(wjm),True) = True Then

r("相片")="\xp\" & FileSys.GetName(wjm)

r.save

With Tables("拍户口_table1")

If .Position = .Rows.Count - 1

.Position = .Position - 1

.Position = .Position + 1

Else

.Position = .Position + 1

.Position = .Position - 1

End If

End With

Else

Messagebox.show("上传失败,请重新上传该文件!","提示",MessageBoxButtons.OK,MessageBoxIcon.Information)

End If

Else

MessageBox.Show("保存失败","失败")

End If

Else

MessageBox.Show("请先拍照!","错误")

End If

老师：你好，之前我也做过压缩，这个地方没做压缩，发现用户上读的图片很大,现在才发现，又很急越急越晕，增加压缩这样好像没压缩起，请老师帮改下压缩文件大小，谢谢!

If pic.Image IsNot Nothing

Dim bmp As bitmap

bmp = new bitmap(pic.Image, 100, 100 * (pic.Image.height / pic.Image.width))

bmp.save(ProjectPath & "RemoteFiles\xp\" & FileSys.GetName(wjm), ImageFormat.Jpeg)

bmp.Dispose

If ftp1.Upload(wjm,"\xp\" & FileSys.GetName(wjm),True) = True Then

老师，这样出现上传时项目就出现停止运行然后就关闭了呢

If pic.Image IsNot Nothing

dim filename as string = FileSys.GetName(wjm)

dim fpath as string = ProjectPath & "RemoteFiles\xp\" & filename

Dim bmp As bitmap

bmp = new bitmap(pic.Image, 100, 100 * (pic.Image.height / pic.Image.width))

bmp.save( fpath, ImageFormat.Jpeg)

bmp.Dispose

If ftp1.Upload( fpath,"\xp\" & filename ,True) = True Then

Dim ftp1 As New FtpClient

ftp1.Host=""

ftp1.Account = ""

ftp1.Password = ""

Dim tb As Table =Tables("贴图_table1")

If tb.Rows.Count>0

Dim r As Row = tb.Current

Dim t1 As String = e.Form.Controls("textbox1").text

Dim t2 As String = e.Form.Controls("textbox2").text

Dim t3 As String = e.Form.Controls("textbox3").text

Dim wjm As String=""

If ValidPIN(r("身份证件号"))= True

wjm = r("身份证件号")

ElseIf r("学籍号")>""

wjm =r("学籍号")

Else

messagebox.show("该学生的身份证号和学籍号中至少有一个要正确完整")

Return

End If

If t1>""

Dim ifo As new FileInfo(t1)

If Ifo.Length>40960 '大于40k才压缩

Dim img As image = getimage(t1)

Dim bmp As new bitmap(img.width, img.height)

Dim g = graphics.fromimage(bmp)

g.DrawImage(img, 0, 0, img.Width, img.Height)

Dim jpgEncoder As ImageCodecInfo

Dim codecs() As ImageCodecInfo = ImageCodecInfo.GetImageDecoders

For Each codec As ImageCodecInfo In codecs

If (codec.FormatID = ImageFormat.Jpeg.Guid) Then

jpgEncoder = codec

Exit For

End If

Dim myEncoder As System.Drawing.Imaging.Encoder = System.Drawing.Imaging.Encoder.Quality

Dim myEncoderParameters As EncoderParameters = New EncoderParameters(1)

Dim myEncoderParameter As EncoderParameter = New EncoderParameter(myEncoder, 100) ' 质量级别 0 对应于最大压缩,而质量级别 100 对应于最小压缩

myEncoderParameters.Param(0) = myEncoderParameter

Dim slt As String = ifo.path & wjm & ifo.Extension

bmp.Save(slt,jpgEncoder, myEncoderParameters)

bmp.dispose

g.dispose

Dim img1 As image = getImage(slt)

Dim bmp1 As bitmap

If img1.width > 400 Then

If 400 * (img1.height / img1.width) > 300 Then

bmp1 = new bitmap(img1, 400*(300/(400*(img1.height/img1.width))), 300)

Else

bmp1 = new bitmap(img1, 300, 300 * (img1.height / img1.width))

End If

bmp1.save(slt, ImageFormat.Jpeg)

bmp1.Dispose

End If

If ftp1.Upload(slt,"\xp\" & FileSys.GetName(wjm & Ifo.extension),True) = True Then

r("相片")="\xp\" & FileSys.GetName(wjm & Ifo.extension)

r.save

e.Form.Controls("PictureBox1").image=getimage(slt)

Else

Messagebox.show("上传失败,请重新上传该文件!","提示",MessageBoxButtons.OK,MessageBoxIcon.Information)

End If

Else

If ftp1.Upload(t1,"\xp\" & FileSys.GetName(wjm & Ifo.extension),True) = True Then

r("相片")="\xp\" & FileSys.GetName(wjm & Ifo.extension)

r.save

Else

Messagebox.show("上传失败,请重新上传该文件!","提示",MessageBoxButtons.OK,MessageBoxIcon.Information)

End If

老师，这个代码之可以用,但现在出现有的电脑传一张图片就显示停止运行，然后就关闭了，这是什么原因，怎么改进这个

试试去掉图片框的列绑定

不绑定又如何让PICTUREBOX.随着记录变动显示远程图片呢

Dim pc1 As WinForm.PictureBox = e.Form.Controls("picturebox1")

Dim ftp1 As New FtpClient

ftp1.Host=

ftp1.Account =

ftp1.Password =

Dim tb As Table=Tables("贴图_table1")

Dim Key As String =tb.Current("相片") '获取此员工的照片文件

If ftp1.Download(key,ProjectPath & "remotefiles" & Key) = False

pc1.Image= GetImage(ProjectPath & "images\wxp.jpg")

Else

pc1.Image= GetImage(projectPath & "remotefiles" & key)

End If

老师，不绑相片列，为了显示远程图片这样写了，但有个问题明显卡，如何解决更好呢

先判断remotefiles目录有没有这个文件，没有再下载，如果有直接使用，不要下载了

这样也有个问题，如果远程文件变了，但文件名没变，这样就得不到远程更新后的,

[此贴子已经被作者于2020/4/26 17:28:13编辑过]

主题：压缩上传