[浏览完整版]
标题：压缩图片到新的文件夹地址下
1楼
yifan3429 发表于：2024/1/22 14:34:00希望达成
图库表
原图列 内容是原图地址 C:\Users\Administrator\Desktop\爆品资料\0daf3cad-77ef-4fc1-a24e-a5bcc50e2106.jpg
缩略图列 拟定压缩图新地址 C:\Users\Administrator\Desktop\压缩图\0daf3cad-77ef-4fc1-a24e-a5bcc50e2106.jpg
Dim ifo As new FileInfo(t11)
If Ifo.Length>40960 '大于40k才压缩
Dim img1 As image = getImage(t11)
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, img.RawFormat)
bmp1.Dispose
End If
2楼
有点蓝 发表于：2024/1/22 14:37:00有什么问题？
3楼
yifan3429 发表于：2024/1/22 16:27:00希望达成
图库表
原图列 内容是原图地址 C:\Users\Administrator\Desktop\爆品资料\0daf3cad-77ef-4fc1-a24e-a5bcc50e2106.jpg
缩略图列 拟定压缩图新地址 C:\Users\Administrator\Desktop\压缩图\0daf3cad-77ef-4fc1-a24e-a5bcc50e2106.jpg
4楼
有点蓝 发表于：2024/1/22 16:34:00我问的是代码执行有什么问题？
把保存的地址改为自己期望的地址不就行了！
5楼
yifan3429 发表于：2024/1/23 1:27:00For Each dr As DataRow In DataTables("表A").DataRows
Dim file As String = dr("原图")
Dim img As image = getImage(file)
Dim bmp As bitmap
If img.width > 600 Then
If 600 * (img.height / img.width) > 338 Then
bmp = New bitmap(img, 600 * (338 / (600 * (img.height / img.width))), 338)
Else
bmp = New bitmap(img, 600, 600 * (img.height / img.width))
End If
bmp.save("C:\Users\Administrator\Desktop\爆品资料1\" & dr("文件") , img.RawFormat)
bmp.Dispose
End If
dr("压缩") = "C:\Users\Administrator\Desktop\爆品资料1\" & dr("文件")
Next
此主题相关图片如下：企业微信截图_20240123012634.png
此主题相关图片如下：企业微信截图_20240123012634.png解决了
[此贴子已经被作者于2024/1/23 1:32:13编辑过]
6楼
yifan3429 发表于：2024/1/23 4:27:00Dim cnt As Integer = 1
SystemReady = False
Try
'追加数据代码
For Each dr As DataRow In DataTables("产品_图库资源").DataRows
Dim ifo As New FileInfo(dr("原始_文件地址"))
StatusBar.Message1 = "正在压缩中"
StatusBar.Message2 = cnt + 1
看不到状态 等显示出来已经结束了 中间就是像死机一样。怎么可以看到数字跳动
十万条数据要好久 能有状态就不焦虑了
' MessageBox.Show(fml)
' If FileSys.DirectoryExists(ifo.Path & "\压缩图片\") Then '如果目录C:\MyFolder存在
' FileSys.DeleteDirectory(ifo.Path & "\压缩图片\", 2, 3) '则删除之
' dr("网络_文件地址") = ""
' dr("网络_缩略图") = ""
' End If
Dim file As String = dr("原始_文件地址")
Dim img As image = getImage(file)
Dim bmp As bitmap
If img.width > 600 Then
If 600 * (img.height / img.width) > 338 Then
bmp = New bitmap(img, 600 * (338 / (600 * (img.height / img.width))), 338)
Else
bmp = New bitmap(img, 600, 600 * (img.height / img.width))
End If
If FileSys.DirectoryExists(ifo.Path & "\压缩图片\") Then '如果目录C:\MyFolder存在
Else
FileSys.CreateDirectory(ifo.Path & "\压缩图片\") '创建目录
End If
dr("网络_文件地址") = ifo.Path & "\压缩图片\"
dr("网络_缩略图") = dr("原始_文件名")
dr("网络_文件目录") = dr("网络_文件地址") & dr("网络_缩略图")
bmp.save(dr("网络_文件目录"), img.RawFormat)
bmp.Dispose
Dim ifo1 As New FileInfo(dr("网络_文件目录"))
dr("网络_文件大小") = Round2(ifo1.Length / 10240, 2) & " kb"
End If
Next
Catch ex As Exception
MessageBox.Show("压缩图片失败")
End Try
SystemReady = True
Tables("产品_图库资源").Save
MessageBox.Show("图片压缩转换成功!")
[此贴子已经被作者于2024/1/23 4:46:37编辑过]
7楼
有点蓝 发表于：2024/1/23 8:46:00http://www.foxtable.com/webhelp/topics/1476.htm
StatusBar.Message1 = "正在压缩中"
StatusBar.Message2 = cnt + 1
Application.DoEvents
8楼
yifan3429 发表于：2024/1/23 12:25:00TopVisibleRow = CurrentTable.Current
正在编辑的行始终显示在屏幕中间 怎么添加
9楼
有点蓝 发表于：2024/1/23 13:32:00http://www.foxtable.com/webhelp/topics/2358.htm
CurrentTable.TopVisibleRow = CurrentTable.Current.index
10楼
yifan3429 发表于：2024/1/26 22:55:00还是不会居中显示