急救：请问各位朋友如何将已扫描到ImgEdit控件的图片保存到一个文件中

Question

急急

Answer 1

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
     Select Case Button.key
         Case "scan"   '扫描
             ImgScan1.DestImageControl = "ImgEdit1"
             On Error GoTo NoDevice
             With ImgScan1
                  .OpenScanner
                  .ShowSetupBeforeScan = True   '扫描之前 先进行设置
                  .StartScan
             End With
NoDevice:
             If Err.Number = 1117 Then
                 MsgBox "扫描设备没有找到，请重新安装！", vbOKOnly + vbCritical, "没有寻找到扫描设备"
                 Exit Sub
                 Else
                 MsgBox "系统未知错误，不能继续！", vbOKOnly + vbCritical, "未知错误"
                 Exit Sub
              End If
 
         Case "ok"    '确定
                     '先把当前的图片保存到硬盘上作为一个临时文件 然后将其保存到数据库里面 最后把临时文件删除
'
'          
            
            strFileName = Str(录入.lvwPic.ListItems.Count)
 
            Call SavePicToHdd     '将当前的图片保存到硬盘上作为一个临时文件
         Case "exit" '取消
                  Unload Me
      End Select
     
End Sub
Private Sub SavePicToHdd()
  On Error GoTo CancelF
 ImgAdmin1.DialogTitle = "保存图像文件"
 ImgAdmin1.CancelError = True
 ImgAdmin1.InitDir = App.Path ImgAdmin1.Image = ""
 ImgAdmin1.Filter = "压缩图片(*.bmp)|*.bmp|"
' ImgAdmin1.ShowFileDialog SaveDlg
 If InStr(1, UCase(ImgAdmin1.Image), UCase(".bmp"), vbTextCompare) Then
        ImgEdit1.SaveAs ImgAdmin1.Image, 3, 7, 1, 0, False
        scanfilename = ImgAdmin1.Image
  Else
        If ImgEdit1.Image = "" Then Exit Sub
        ImgEdit1.SaveAs App.Path & "\" & strFileName & ".bmp", 3, 7, 1, 0, False
        scanfilename = App.Path & "\" & strFileName & ".bmp"
'        scanfilename = strFileName & ".bmp"
 End If
 '添加到listview控件
'
    Call AddNewPic
 
 Exit Sub
CancelF:
 If Err.Number <> 32755 Then
    MsgBox "非法操作，不能继续！    ", vbOKOnly + vbQuestion, "未知错误"
    Else
    ImgAdmin1.Image = ""
 End IfEnd Sub
Sub AddNewPic()
    Dim Stemp1 As String
'    On Error GoTo ErrorNum
    Dim itemX As ListItem
    Set itemX = frminput.lvwPic.ListItems.Add(, scanfilename, strFileName & ".bmp", 1, 1)
'    Image1.Picture = LoadPicture(lvwPic.SelectedItem.key)
'    Stemp1 = InputBox("请输入该图片的说明:")
     Stemp1 = Str(frminput.lvwPic.ListItems.Count + 1)
    strPicDiscribe(frminput.lvwPic.ListItems.Count + 1) = "第" & Stemp1 & "张 图片"
    itemX.SubItems(1) = Stemp1
ErrorNum:
    Select Case Err.Number
        Case "35620"
            MsgBox "这个文件已经被添加了,不能重复添加."
            Exit Sub
    End Select
End Sub

Answer 2

我用读写两个过程保存和显示图片readdb为读
writedb为写Option Explicit
Const BlockSize = 4096Private Sub SavePic(ByRef Fld As Field, DiskFile As String)
Const BlockSize = 4096 '每次读写块的大小
Dim ADOFld As Field 'ADODB Field 对象
Dim byteData() As Byte '定义数据块数组
Dim NumBlocks As Long '定义数据块个数
Dim FileLength As Long '标识文件长度
Dim LeftOver As Long '定义剩余字节长度
Dim SourceFile As Long '定义自由文件号
Dim I As Long '定义循环变量
SourceFile = FreeFile '提供一个尚未使用的文件号
Open DiskFile For Binary Access Read As SourceFile '打开文件
FileLength = LOF(SourceFile) '得到文件长度
If FileLength = 0 Then '判断文件是否存在
Close SourceFile
MsgBox DiskFile & "  无 内 容 或 不 存 在 !"
Else
NumBlocks = FileLength \ BlockSize '得到数据块的个数
LeftOver = FileLength Mod BlockSize '得到剩余字节数
Fld.Value = Null
ReDim byteData(BlockSize) '重新定义数据块的大小
For I = 1 To NumBlocks
Get SourceFile, , byteData() ' 读到内存块中
Fld.AppendChunk byteData() '写入FLD
Next I
ReDim byteData(LeftOver) '重新定义数据块的大小
Get SourceFile, , byteData() '读到内存块中
Fld.AppendChunk byteData() '写入FLD
Close SourceFile '关闭源文件
End If
End Sub    Public Function ReadDB(Col As ADODB.Field, ImgFile As String, Optional BlockSize As Long = 8192) As Boolean
     Dim byteData() As Byte, NumBlocks As Integer
     Dim LeftOver As Long, DestFileNum As Integer, I As Integer
     Dim ColSize As Long
     
     On Error GoTo ErrRead
     ReadDB = False
     
     'If Dir(ImgFile) <> "" Then Kill ImgFile
     
     DestFileNum = FreeFile
     Open ImgFile For Binary As #DestFileNum
     
     ColSize = Col.ActualSize
     NumBlocks = ColSize \ BlockSize
     LeftOver = ColSize Mod BlockSize
     
     ReDim byteData(LeftOver)
     byteData() = Col.GetChunk(LeftOver)
     Put DestFileNum, , byteData()
     ReDim byteData(BlockSize)
     For I = 1 To NumBlocks
     byteData() = Col.GetChunk(BlockSize)
     Put #DestFileNum, , byteData()
     Next
     If LOF(DestFileNum) > 200 Then ReadDB = True
     Close #DestFileNum
     Exit Function
     
ErrRead:
     'MsgBox "READ PICTURE ERR:" & Err.Number
     ReadDB = False
     Exit Function
    End Function
    Public Sub SaveToDB(ByRef Fld As ADODB.Field, DiskFile As String, _
     Optional ByRef FldDesc As ADODB.Field)
     
     Dim strData As String '用于处理Text字段
     Dim byteData() As Byte '用于处理Image字段
     Dim NumBlocks As Long
     Dim FileLength As Long
     Dim LeftOver As Long
     Dim SourceFile As Long
     Dim I As Long
     
     SourceFile = FreeFile
     Open DiskFile For Binary Access Read As SourceFile
     FileLength = LOF(SourceFile)
     If FileLength = 0 Then
     Close SourceFile
     MsgBox DiskFile & " 无内容或不存在!"
     Else
     NumBlocks = FileLength \ BlockSize
     LeftOver = FileLength Mod BlockSize
     Fld.Value = Null
     Select Case Fld.Type
     Case adLongVarBinary 'Image 字段
     ReDim byteData(NumBlocks)
     For I = 1 To NumBlocks
     Get SourceFile, , byteData()
     Fld.AppendChunk byteData()
     Next I
     ReDim byteData(LeftOver)
     Get SourceFile, , byteData()
     Fld.AppendChunk byteData()
     Case adLongVarChar 'Text 字段
     strData = String(BlockSize, 32)
     For I = 1 To NumBlocks
     Get SourceFile, , strData
     Fld.AppendChunk strData
     Next I
     strData = String(LeftOver, 32)
     Fld.AppendChunk strData
     End Select
     Close SourceFile
     'If Not IsMissing(FldDesc) Then FldDesc.Value = Mid(DiskFile, PosA(DiskFile, "\") + 1)
     End If
    End Sub    Public Sub WriteDB(Col As ADODB.Field, ImgFile As String, Optional BlockSize As Long = 8192)
     Dim byteData() As Byte, FileLength As Long, NumBlocks As Integer
     Dim LeftOver As Long, SourceFileNum As Integer, I As Integer
     
     SourceFileNum = FreeFile
     Open ImgFile For Binary As SourceFileNum
     FileLength = LOF(SourceFileNum)
     If FileLength > 50 Then
     NumBlocks = FileLength \ BlockSize
     LeftOver = FileLength Mod BlockSize
     
     ReDim byteData(LeftOver)
     Get SourceFileNum, , byteData()
     Col.AppendChunk byteData()
     ReDim byteData(BlockSize)
     For I = 1 To NumBlocks
     Get SourceFileNum, , byteData()
     Col.AppendChunk byteData()
     Next
     End If
     Close SourceFileNum
    End Sub