| 以文本方式查看主题 - Foxtable(狐表) (http://foxtable.com/bbs/index.asp) -- 专家坐堂 (http://foxtable.com/bbs/list.asp?boardid=2) ---- 压缩上传 (http://foxtable.com/bbs/dispbbs.asp?boardid=2&id=149090) |
| -- 作者：刘林 -- 发布时间：2020/4/23 10:02:00 -- 压缩上传 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 End If 老师：你好，之前我也做过压缩，这个地方没做压缩，发现用户上读的图片很大,现在才发现，又很急越急越晕，增加压缩这样好像没压缩起，请老师帮改下压缩文件大小，谢谢!
|
| -- 作者：有点蓝 -- 发布时间：2020/4/23 10:35:00 -- 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
|
| -- 作者：刘林 -- 发布时间：2020/4/23 12:21:00 -- 老师，这样出现上传时项目就出现停止运行然后就关闭了呢 |
| -- 作者：有点蓝 -- 发布时间：2020/4/23 13:41:00 -- 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
|
| -- 作者：刘林 -- 发布时间：2020/4/26 15:06:00 -- 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 Next 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 End If End If 老师，这个代码之可以用,但现在出现有的电脑传一张图片就显示停止运行，然后就关闭了，这是什么原因，怎么改进这个 |
| -- 作者：有点蓝 -- 发布时间：2020/4/26 15:15:00 -- 试试去掉图片框的列绑定 |
| -- 作者：刘林 -- 发布时间：2020/4/26 16:42:00 -- 不绑定又如何让PICTUREBOX.随着记录变动显示远程图片呢 |
| -- 作者：刘林 -- 发布时间：2020/4/26 17:16:00 -- 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 老师，不绑相片列，为了显示远程图片这样写了，但有个问题明显卡，如何解决更好呢
|
| -- 作者：有点蓝 -- 发布时间：2020/4/26 17:25:00 -- 先判断remotefiles目录有没有这个文件，没有再下载，如果有直接使用，不要下载了 |
| -- 作者：刘林 -- 发布时间：2020/4/26 17:28:00 -- 这样也有个问题，如果远程文件变了，但文件名没变，这样就得不到远程更新后的, [此贴子已经被作者于2020/4/26 17:28:13编辑过]
|