frmscan.frm

金算盘软件代码

            GoTo EndProc
        End If
'    Else
'        FileCopy StrFileName, strToFileName
'    End If
    GetList False
    SaveImgToBase = True
EndProc:
    Exit Function
ErrHandle:
    EMsgBox Err.Description
End Function
Private Function GetAccountlistFilePathName() As String
    '取帐套目录文件名
    Dim strTmpPath As String
    Dim strININame As String
    Dim strDefault As String
    Dim lngTmp As Long
    Dim lngSize As Long
    Dim strByteName As String
    Dim strByteKey As String
    Dim strWinSysPath As String
    On Error GoTo ErrHandle
    GetAccountlistFilePathName = ""
    
'    #If conVersionType = 1 Then
'        strByteName = "金算盘商务管理软件标准版"
'    #Else
'        #If conVersionType = 2 Then
'            strByteName = "金算盘商务管理软件行政事业版"
'        #Else
'            #If conVersionType = 4 Then
'                strByteName = "金算盘商务管理软件实达专用版"
'            #Else
'                #If conVersionType = 8 Then
'                    strByteName = "金算盘商务管理软件标准版"
'                #End If
'            #End If
'        #End If
'    #End If
    #If conWan = 1 Then
        strByteName = "万能软件"
    #Else
        strByteName = "金算盘软件"
    #End If
    '取得路径（返回路径及长度）
    strWinSysPath = App.Path
    
    If Dir(strWinSysPath & "\Account.ini") <> "" Then
        strDefault = ""
        strTmpPath = Space(255)
        lngSize = Len(strTmpPath)
        strByteKey = "ACCOUNTLIST"
        strININame = strWinSysPath & "\Account.ini"
        '取得INI文件中的字符串（节名，关键字，默认值，返回字符串，返回字符串长度，文件名）
        '取得INI文件中样板数据库路径
        lngTmp = GetPrivateProfileString(strByteName, strByteKey, strDefault, strTmpPath, lngSize, strININame)
        strTmpPath = Left(strTmpPath, lngTmp)
        If lngTmp > 0 Then
            If Dir(strTmpPath) <> "" Then
                GetAccountlistFilePathName = strTmpPath
            End If
        End If
    Else
        GetAccountlistFilePathName = "\\CHSORASVR\backup\GACCOUNT.ini"
    End If
    GetAccountlistFilePathName = Left(GetAccountlistFilePathName, Len(GetAccountlistFilePathName) - 12)
    Exit Function
ErrHandle:
    On Error Resume Next
    GetAccountlistFilePathName = "\\CHSORASVR\backup\"
End Function

Private Function ShowAoldImg(ByVal lngImageID As Long, Optional ByVal blnAlert As Boolean = True) As Boolean
    Dim strSql As String
    Dim recTmp As rdoResultset
    
    Me.MousePointer = vbHourglass
    
    On Error GoTo ErrHandle
    strSql = "SELECT OrderImage.lngImageID, OrderImage.lngOrderID," & _
        " OrderImage.strImageCode, ProjectOrder.lngCustomerID " & _
        " FROM OrderImage,ProjectOrder WHERE OrderImage.lngOrderID = ProjectOrder.lngOrderID " & _
        " AND OrderImage.lngImageID=" & lngImageID
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
    If (recTmp.BOF And recTmp.EOF) Then
        If blnAlert Then
            EMsgBox "数据库中没有本条记录！", "显示图像"
        End If
        GoTo EndProc
    End If
    m_blnNoChoose = True
    lstHead.SeekId lngImageID
    m_blnNoChoose = False
    m_lngImgID = lngImageID
    strSql = m_ImgPath & lngImageID & ".GAF"
    If Dir(strSql, 15) = "" Then
        If blnAlert Then
            EMsgBox "图像“" & strSql & "”已被删除，请重新扫描！", "显示图像"
        End If
        GoTo EndProc
    End If
    ShowAoldImg = OpenFile(strSql)
    m_blnChanged = False
EndProc:
    If Not recTmp Is Nothing Then
        recTmp.Close
        Set recTmp = Nothing
    End If
    m_lngImgID = lngImageID
    Me.MousePointer = vbDefault
    Exit Function
ErrHandle:
    Me.MousePointer = vbDefault
    EMsgBox Err.Description
End Function

Public Sub ShowNewImg()
    m_lngCustomerID = 0
    m_strCode = 0
    m_blnChanged = False
    m_lngImgID = 0
    Me.Show vbModal
End Sub

Private Function ShowoldImg(ByVal lngImageID As Long) As Boolean
    m_lngImgID = lngImageID
    m_blnChanged = False
    Me.Show vbModal
End Function

Private Function FindOtherImg(Optional ByVal blnNext As Boolean = True) As Boolean
    Dim strSql As String
    Dim recTmp As rdoResultset
    
    On Error GoTo ErrHandle
    If blnNext Then
        strSql = "SELECT lngImageID,strImageCode FROM OrderImage WHERE lngOrderID=" & m_lngOrderID & " AND (strImageCode >'" & Trim(lstHead.Text) & "') ORDER BY strImageCode"  'OR Length(strImageCode)>=" & Len(Trim(LstHead.Text)) & ") ORDER BY Length(strImageCode),strImageCode"
    Else
        strSql = "SELECT lngImageID,strImageCode FROM OrderImage WHERE lngOrderID=" & m_lngOrderID & " AND (strImageCode <'" & Trim(lstHead.Text) & "') ORDER BY strImageCode Desc" 'OR Length(strImageCode)<=" & Len(Trim(LstHead.Text)) & ") ORDER BY Length(strImageCode),strImageCode Desc"
    End If
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If (recTmp.BOF And recTmp.EOF) Then
        GoTo EndProc
    End If
    With recTmp
        Do While Not .EOF
            strSql = m_ImgPath & !lngImageID & ".GAF"
            If Dir(strSql, 15) <> "" Then
                Exit Do
            End If
            .MoveNext
        Loop
        FindOtherImg = OpenFile(strSql)
        m_lngImgID = !lngImageID
        m_blnNoChoose = True
        lstHead.SeekId m_lngImgID
        m_blnNoChoose = False
    End With
EndProc:
    If Not recTmp Is Nothing Then
        recTmp.Close
        Set recTmp = Nothing
    End If
    m_blnChanged = False
    Exit Function
ErrHandle:
    EMsgBox Err.Description
End Function

Private Function DataValid() As Boolean
    Dim strSql As String
    Dim recTmp As rdoResultset
    
    m_strCodeBak = Trim(m_strCodeBak)
    If Trim(m_strCodeBak) = "" Then
        EMsgBox "编号不能为空！", "保存图像"
        lstHead.Text = m_strCodeBak
        lstHead.SetFocus
        GoTo EndProc
    End If
    If ContainErrorChar(m_strCodeBak) Then
        EMsgBox "编号中有非法字符，请重新输入！", "保存图像"
        lstHead.Text = m_strCodeBak
        lstHead.SetFocus
        GoTo EndProc
    End If
    
    If StrLen(m_strCodeBak) > 30 Then
        EMsgBox "编号不能超过30个字符，请重新输入！", "保存图像"
        lstHead.Text = m_strCodeBak
        lstHead.SetFocus
        GoTo EndProc
    End If
    DataValid = True
EndProc:
    If Not recTmp Is Nothing Then
        recTmp.Close
        Set recTmp = Nothing
    End If
End Function
Private Function RefreshImg() As Boolean
    Dim strSql As String
    Dim recTmp As rdoResultset
        
    ClearImg
    strSql = "SELECT * FROM OrderImage WHERE ROWNUM<=1 AND lngImageID=" & lstHead.ID
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
    With recTmp
        If .BOF And .EOF Then
            EMsgBox "数据库中没有本张图像，请重新扫描！", "显示图像"
            m_lngImgID = 0
            GoTo EndProc
        End If
        If ShowAoldImg(!lngImageID) Then
            m_lngImgID = !lngImageID
            m_blnChanged = False
        End If
    End With
EndProc:
    If Not recTmp Is Nothing Then
        recTmp.Close
        Set recTmp = Nothing
    End If
End Function
Private Function DeleteFile() As Boolean
    Dim strSql As String
    
    strSql = "DELETE OrderImage WHERE lngImageID=" & m_lngImgID
    If gclsBase.ExecSQL(strSql) = True Then
        If Dir(m_ImgPath & m_lngImgID & ".GAF") <> "" Then
            Kill m_ImgPath & m_lngImgID & ".GAF"
        End If
        DeleteFile = True
        ClearImg
        m_lngImgID = 0
        m_blnChanged = False
        lstHead.Text = ""
        m_strCodeBak = lstHead.Text
        GetList
    End If
End Function

Private Function GetOrderInfo() As Boolean
    Dim strSql As String
    Dim recTmp As rdoResultset

    If m_lngOrderID < 1 Then Exit Function
    
    strSql = "SELECT Customer.strCustomerCode||' '||Customer.strCustomerName AS strCustomer," & _
        " ProjectOrder.strDate,Project.strProjectCode||' '||Project.strProjectName AS strProject," & _
        " ProjectOrder.strOrderCode||' '||ProjectOrder.strOrderName AS strOrder FROM ProjectOrder,Customer,Project " & _
        " WHERE ProjectOrder.lngCustomerID = Customer.lngCustomerID " & _
        " AND ProjectOrder.lngProjectID = Project.lngProjectID " & _
        " AND ROWNUM<=1 AND ProjectOrder.lngOrderID = " & m_lngOrderID
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
    With recTmp
        If .BOF And .EOF Then
            EMsgBox "指定合同没有找到，可能已被删除，请重新录入！", "扫描合同"
            GoTo EndProc
        End If
        lblTitle(0).Caption = "单位:" & Trim(!strCustomer)
        lblTitle(1).Caption = "工程:" & Trim(!strProject)
        lblTitle(2).Caption = "日期:" & Trim(!strDate)
        lblTitle(3).Caption = "合同:" & Trim(!strOrder)
        GetList
        lblTitle(0).ToolTipText = lblTitle(0).Caption
        lblTitle(1).ToolTipText = lblTitle(1).Caption
        lblTitle(2).ToolTipText = lblTitle(2).Caption
        lblTitle(3).ToolTipText = lblTitle(3).Caption
    End With
    
    GetOrderInfo = True
    
    GetList
    If lstHead.RecordCount <> 0 Then
        m_blnNoChoose = True
        lstHead.ReferRow = 0
        m_blnNoChoose = False
        m_lngImgID = lstHead.ID
        ShowAoldImg m_lngImgID, False
    Else
        lstHead.Text = 1
        m_strCodeBak = lstHead.Text
    End If
EndProc:
    If Not recTmp Is Nothing Then
        recTmp.Close
        Set recTmp = Nothing
    End If
End Function
Private Sub GetList(Optional ByVal blnSetText As Boolean = True)
    Dim strSql As String
    Dim strBak As String
    Dim recTmp As rdoResultset

    strBak = Trim(lstHead.Text)
    strSql = "SELECT lngImageID,strImageCode FROM OrderImage WHERE lngOrderID=" & m_lngOrderID & " ORDER BY strImageCode"
    lstHead.SQL = strSql
    lstHead.SeekCol = "1,2"
    Set lstHead.Recordset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If blnSetText = False Then
        lstHead.Text = strBak
        Exit Sub
    End If
    If m_lngImgID <> 0 Then
        m_blnNoChoose = True
        lstHead.SeekId m_lngImgID
        m_blnNoChoose = False
    Else
        If strBak <> "" Then
            lstHead.Text = strBak
            m_strCodeBak = lstHead.Text
        End If
    End If
    lblTitle(5).Caption = "共 " & lstHead.RecordCount & " 张"
    lblTitle(5).ToolTipText = lblTitle(5).Caption
End Sub
Public Sub ScanOrder(ByVal lngOrderID As Long)
    m_lngOrderID = lngOrderID
    m_lngImgID = 0
    m_blnChanged = False
    On Error Resume Next
    Me.Show vbModal
End Sub

Private Sub LstHead_Choose()
    If m_blnNoChoose Then Exit Sub
    If lstHead.ID <> m_lngImgID Then
        If ChangeSaveNote = True Then
            m_lngImgID = lstHead.ID
            m_strCodeBak = lstHead.Text
            RefreshImg
        Else
            m_blnNoChoose = True
            If m_lngImgID = 0 Then
                lstHead.Text = m_strCodeBak
            Else
                lstHead.SeekId m_lngImgID
            End If
            m_blnNoChoose = False
        End If
    End If
End Sub

Private Sub lstHead_ItemNotExist()
    If cmdScan(4).Enabled = False Then
        If m_lngImgID <> 0 Then
            lstHead.SeekId m_lngImgID
            m_strCodeBak = lstHead.Text
        Else
            lstHead.Text = ""
            m_strCodeBak = lstHead.Text
        End If
        Exit Sub
    End If
    If ChangeSaveNote() = False Then
        Exit Sub
    End If
    ClearImg
    m_lngImgID = 0
    m_strCodeBak = lstHead.Text
    m_blnChanged = False
End Sub