以文本方式查看主题

-  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编辑过]