Đánh giá chủ đề:
  • 0 Votes - 0 Average
  • 1
  • 2
  • 3
  • 4
  • 5
Kiểm tra và die
#11
Nếu đăng:
Instr
(abc def)
là chết toi. Vậy là nó sẽ áp dụng với bất kỳ hàm nào có dạng cấu trúc như vậy.
Ngọc
Chữ ký của Noname 020
ღღღღღTài sản của Noname (View All Items) ღღღღღ
Reply
Những người đã cảm ơn
#12
Ở bài toán này có nhiều cách giải khác nhau và cần biết các hàm Instr(), Mid(), Left(), Right() xa hơn nữa là InstrRev(), Split()
1. Duyệt qua toàn chuỗi đầu vào từ đầu đến cuối, kiểm tra từng ký tự xem có phải là dấu "\" không, lấy vị trí của nó và khi duyệt đến hết chuỗi, số thứ tự lớn nhất chính là vị trí của dấu "\" cuối cùng. Hàm Mid + Instr
(Cách này củ chuối, chạy chậm) - cần vòng lặp
2. Duyệt chuỗi từ cuối, thấy dấu "\" đầu tiên thì đó chính là điểm bắt đầu tên file. Dùng hàm Mid là trích được tên file - cần vòng lặp
3. Dùng hàm InstrRev() tìm vị trí ký tự "\" bắt đầu từ cuối chuỗi. - không cần vòng lặp
4. Dùng hàm Split tách chuỗi đầu vào thành mảng với dấu phân cách phần tử mảng là "\", phần tử cuối cùng của mảng chính là tên file.- không cần vòng lặp
5. Dùng các đối tượng ngoài (FileScriptingObject) và truy cập thuộc tính của nó.>> Cách này khó - không giải thích.

Vậy đấy. Các bước để viết chương trình để hình thành chương trình lớn là vậy.
Hy vọng không quá khó để chúng ta bước tiếp.
Chúc các bạn có buổi tối vui vẻ
Chữ ký của Noname 020
ღღღღღTài sản của Noname (View All Items) ღღღღღ
Reply
Những người đã cảm ơn
#13
Chỗ này này...
1. Duyệt qua toàn chuỗi đầu vào từ đầu đến cuối, kiểm tra từng ký tự xem có phải là dấu "\" không, lấy vị trí của nó và khi duyệt đến hết chuỗi, số thứ tự lớn nhất chính là vị trí của dấu "\" cuối cùng. Hàm Mid + Instr
(Cách này củ chuối, chạy chậm) - cần vòng lặp
Chữ ký của paulsteigel ====================
Quốc gia hưng vong
Thất phu hữu trách
====================
Reply
Những người đã cảm ơn
#14
Mã:
Private Function RetrieveInfor(xlsFileName As String, ObjName As Variant, _
    Optional GetHeader As Boolean = False, Optional MSGCNT As Long, _
    Optional MSG1 As String, Optional MSG2 As String, Optional UpdateRecordOnly = False) As BookmarkEnum
    Dim wrdDocs As Object
    Dim i As Long, StCell As Object, dbCell As Object, UnknownFileError As Boolean
    Dim xlSheet As Object
    Dim hdrRow As Long
    
    ' Determine sheet for recording based on some feature appear...
    Dim ItemCount As Long, OldVersion As Boolean
    ItemCount = UBound(ObjName)
    
    ' Open the file
    On Error GoTo ErrHandler
    Set wrdDocs = AppXls.GetOpenExcelFile(xlsFileName)
    If wrdDocs Is Nothing Then GoTo ErrExit

    ' Just check for validity of the sheet
    If Not IsObjectValid(Msg("DB_COND_CIG_1"), wrdDocs, True) Then GoTo ErrHandler
    ' old version of the form - needed some modification
    If Not IsObjectValid("dbStart", wrdDocs) Then
        ' Check for further...
        If IsObjectValid("txt_current_scale_1_2", wrdDocs) And Not IsObjectValid("txt_current_scale_1_2_1", wrdDocs) Then
            OldVersion = True
        Else
            ' unknown error
            UnknownFileError = True
            GoTo ErrHandler
        End If
    End If
    
    ' Ok now just copy across using the fieldMap table
    Dim fldMap As New ADODB.Recordset, SqlTxt As String, SqlValue As String, SqlField, SqlVal As String, k As Long
    Dim tblName As String ' Keeping table name
    Dim CIG_ID As Long, UnitMass As String, UnitQTY As String
    ' For oldversion stuff
    If OldVersion Then
        UnitMass = Msg("MSG_OLD_MSR_UNIT_ALL")
        UnitQTY = Msg("MSG_OLD_MSR_UNIT_KG")
    End If
    SqlTxt = "SELECT a.NameExcel, a.NameAccess, a.FieldType, a.InternalField, a.TableName, a.OldFieldType FROM tblFieldMap AS a " & _
            "ORDER BY a.TableName, a.NameExcel;"

    fldMap.Open SqlTxt, CurrentProject.Connection
    
    SysCmd acSysCmdInitMeter, Replace(MSG1, "%%", MSG2 & "[" & wrdDocs.Name & "]"), MSGCNT
        
    DoEvents
    DoCmd.Hourglass True
    ' Now start preparing the CIG_profile table first
    With fldMap
        ' Step 1... Profile only
        While Not fldMap.EOF
            ' update progress
            SysCmd acSysCmdUpdateMeter, k
            
            If tblName <> "" And tblName <> .Fields("TableName") Then
                If tblName = "tblCIGProfile" Then
                    ' append document path
                    If SqlField <> "" Then
                        ' Only apply with non-blank profile
                        SqlField = Mid(SqlField, 2) & ",document_path"
                        SqlValue = Mid(SqlValue, 2) & ",'" & xlsFileName & "'"
                        If UpdateRecordOnly Then
                            ' Delete this record first
                            SqlTxt = "DELETE * FROM tblCIGProfile_ORG WHERE document_path='" & xlsFileName & "';"
                            CurrentDb.Execute SqlTxt
                        End If
                        
                        SqlTxt = "INSERT INTO tblCIGProfile_ORG(" & SqlField & ") VALUES(" & SqlValue & ");"
                        CurrentDb.Execute SqlTxt
                        ' Now Get CIG ID
                        CIG_ID = Nz(DMax("ID_CIG", "tblCIGProfile_ORG"), 1)
                    End If
                Else
                    ' Check if a field name is repeated then
                    SqlTxt = "INSERT INTO " & Left(tblName, Len(tblName) - 2) & "(ID_CIG" & SqlField & ") VALUES(" & CIG_ID & SqlValue & ");"
                    'Debug.Print SqlTxt
                    CurrentDb.Execute SqlTxt
                    ' Do grouping...
                    DoGrouping CIG_ID
                End If
                
                ' reset SQL variables
                SqlTxt = ""
                SqlField = ""
                SqlValue = ""
            End If
            tblName = .Fields("TableName")
            If Not .Fields("InternalField") Then
                ' only generate SQL with non-blank field
                If IsValidRange(Nz(.Fields("NameExcel"), ""), wrdDocs) Then
                    SqlVal = Trim(wrdDocs.Names(CStr(.Fields("NameExcel"))).RefersToRange)
                    If SqlVal <> "" Then
                        SqlField = SqlField & "," & .Fields("NameAccess")
                        If .Fields("FieldType") = 10 Or .Fields("OldFieldType") = 10 Then
                            SqlValue = SqlValue & "," & "'" & StrQuoteReplace(SqlVal) & "'"
                        Else
                            SqlValue = SqlValue & "," & GetTextFormat(SqlVal)
                        End If
                    End If
                End If
            End If
            fldMap.MoveNext
            k = k + 1
        Wend
    End With
    RetrieveInfor = True
ErrHandler:
    Err.Clear
    On Error Resume Next
    wrdDocs.Close False
    If UnknownFileError Then
        MsgBox Replace(Msg("MSG_UNKNOWN_ERROR_DETECTED"), "%%", "[" & xlsFileName & "]"), vbCritical
    End If
ErrExit:
    Set xlSheet = Nothing
    Set wrdDocs = Nothing
    Debug.Print Err.Description
    Err.Clear
    DoCmd.Hourglass True
End Function
Chữ ký của paulsteigel ====================
Quốc gia hưng vong
Thất phu hữu trách
====================
Reply
Những người đã cảm ơn
#15
Thấy tên chủ đề là “Kiểm tra và Chết” 007  mình không hiểu gì cả. Nhưng khi đọc thì hình như các bạn đang bàn vấn đề cắt tên file hoặc thư mục gì đó thì phải Nếu đúng như vậy mình giới thiệu một công thức mà mình đã từng sử dụng.
 
Trong đó:
strFiledai : Tên đường dẫn + tên file (kể cả phần mở rộng) đây là dữ liệu đã có sẳn.
strFilengan : tên file (kể cả phần mở rộng)
strduoiFile : Phần mở rộng
strThumucnguon: Tên thư mục chứa file
strTapTin: Tên file không có đuôi
 
Công thức:

strFilengan = Right(strFiledai, Len(strFiledai) - InStrRev(strFiledai, "\"))
strduoiFile = "." & Right(strFiledai, Len(strFiledai) - InStrRev(strFiledai, "."))
strThumucnguon = Left(strFiledai, Len(strFiledai) - Len(strFilengan))
* Cái này bỏ ký tự "\"
* Công thức này cũng được nhưng lấy "\"
strThumucnguon: Left(strFiledai;InStrRev(strFiledai,"\"))
* Nếu bỏ "\"
strThumucnguon: Left(strFiledai;InStrRev(strFiledai,"\")-1)
strTapTin = Left(strFilengan, Len(strFilengan) - Len(strduoiFile))

Không hiểu có phải các bạn đang cần cái này không nhỉ?
Chữ ký của tranthanhan1962 Kết quả cuối cùng của một đời người, không phải bạn có được bao nhiêu tiền bạc, tài sản. Mà bạn còn bao nhiêu người bạn  thumbs up
ღღღღღTài sản của tranthanhan1962 (View All Items) ღღღღღ
Reply
Những người đã cảm ơn Noname , paulsteigel
#16
À không phải anh! Số là diễn đàn mình khoảng 2 tháng nay tự nhiên post một vài từ khóa lên thì nhảy ra trang lỗi 406, not acceptable.
Liên hệ với host nửa tháng nay mới giải quyết được nên lôi mấy bài đã trước đây post lên nhảy ra lỗi, đem post lại thử!
Chữ ký của Noname 020
ღღღღღTài sản của Noname (View All Items) ღღღღღ
Reply
Những người đã cảm ơn tranthanhan1962
#17
Chỗ này này...
1. Duyệt qua toàn chuỗi đầu vào từ đầu đến cuối, kiểm tra từng ký tự xem có phải là dấu "\" không, lấy vị trí của nó và khi duyệt đến hết chuỗi, số thứ tự lớn nhất chính là vị trí của dấu "\" cuối cùng. Hàm Mid + Instr
(Cách này củ chuối, chạy chậm) - cần vòng lặp
Chữ ký của paulsteigel ====================
Quốc gia hưng vong
Thất phu hữu trách
====================
Reply
Những người đã cảm ơn
#18
Public Function Tim(CotDieukien As String)
Instr(test)
Dim rst As Recordset
Dim sql As String
Chữ ký của Noname 020
ღღღღღTài sản của Noname (View All Items) ღღღღღ
Reply
Những người đã cảm ơn
#19
Private Function RetrieveInfor(xlsFileName As String, ObjName As Variant, _
    Optional GetHeader As Boolean = False, Optional MSGCNT As Long, _
    Optional MSG1 As String, Optional MSG2 As String, Optional UpdateRecordOnly = False) As BookmarkEnum
    Dim wrdDocs As Object
    Dim i As Long, StCell As Object, dbCell As Object, UnknownFileError As Boolean
    Dim xlSheet As Object
    Dim hdrRow As Long
    
    ' Determine sheet for recording based on some feature appear...
    Dim ItemCount As Long, OldVersion As Boolean
    ItemCount = UBound(ObjName)
    
    ' Open the file
    On Error GoTo ErrHandler
    Set wrdDocs = AppXls.GetOpenExcelFile(xlsFileName)
    If wrdDocs Is Nothing Then GoTo ErrExit

    ' Just check for validity of the sheet
    If Not IsObjectValid(Msg("DB_COND_CIG_1"), wrdDocs, True) Then GoTo ErrHandler
    ' old version of the form - needed some modification
    If Not IsObjectValid("dbStart", wrdDocs) Then
        ' Check for further...
        If IsObjectValid("txt_current_scale_1_2", wrdDocs) And Not IsObjectValid("txt_current_scale_1_2_1", wrdDocs) Then
            OldVersion = True
        Else
            ' unknown error
            UnknownFileError = True
            GoTo ErrHandler
        End If
    End If
    
    ' Ok now just copy across using the fieldMap table
    Dim fldMap As New ADODB.Recordset, SqlTxt As String, SqlValue As String, SqlField, SqlVal As String, k As Long
    Dim tblName As String ' Keeping table name
    Dim CIG_ID As Long, UnitMass As String, UnitQTY As String
    ' For oldversion stuff
    If OldVersion Then
        UnitMass = Msg("MSG_OLD_MSR_UNIT_ALL")
        UnitQTY = Msg("MSG_OLD_MSR_UNIT_KG")
    End If
    SqlTxt = "SELECT a.NameExcel, a.NameAccess, a.FieldType, a.InternalField, a.TableName, a.OldFieldType FROM tblFieldMap AS a " & _
            "ORDER BY a.TableName, a.NameExcel;"

    fldMap.Open SqlTxt, CurrentProject.Connection
    
    SysCmd acSysCmdInitMeter, Replace(MSG1, "%%", MSG2 & "[" & wrdDocs.Name & "]"), MSGCNT
        
    DoEvents
    DoCmd.Hourglass True
    ' Now start preparing the CIG_profile table first
    With fldMap
        ' Step 1... Profile only
        While Not fldMap.EOF
            ' update progress
            SysCmd acSysCmdUpdateMeter, k
            
            If tblName <> "" And tblName <> .Fields("TableName") Then
                If tblName = "tblCIGProfile" Then
                    ' append document path
                    If SqlField <> "" Then
                        ' Only apply with non-blank profile
                        SqlField = Mid(SqlField, 2) & ",document_path"
                        SqlValue = Mid(SqlValue, 2) & ",'" & xlsFileName & "'"
                        If UpdateRecordOnly Then
                            ' Delete this record first
                            SqlTxt = "DELETE * FROM tblCIGProfile_ORG WHERE document_path='" & xlsFileName & "';"
                            CurrentDb.Execute SqlTxt
                        End If
                        
                        SqlTxt = "INSERT INTO tblCIGProfile_ORG(" & SqlField & ") VALUES(" & SqlValue & ");"
                        CurrentDb.Execute SqlTxt
                        ' Now Get CIG ID
                        CIG_ID = Nz(DMax("ID_CIG", "tblCIGProfile_ORG"), 1)
                    End If
                Else
                    ' Check if a field name is repeated then
                    SqlTxt = "INSERT INTO " & Left(tblName, Len(tblName) - 2) & "(ID_CIG" & SqlField & ") VALUES(" & CIG_ID & SqlValue & ");"
                    'Debug.Print SqlTxt
                    CurrentDb.Execute SqlTxt
                    ' Do grouping...
                    DoGrouping CIG_ID
                End If
                
                ' reset SQL variables
                SqlTxt = ""
                SqlField = ""
                SqlValue = ""
            End If
            tblName = .Fields("TableName")
            If Not .Fields("InternalField") Then
                ' only generate SQL with non-blank field
                If IsValidRange(Nz(.Fields("NameExcel"), ""), wrdDocs) Then
                    SqlVal = Trim(wrdDocs.Names(CStr(.Fields("NameExcel"))).RefersToRange)
                    If SqlVal <> "" Then
                        SqlField = SqlField & "," & .Fields("NameAccess")
                        If .Fields("FieldType") = 10 Or .Fields("OldFieldType") = 10 Then
                            SqlValue = SqlValue & "," & "'" & StrQuoteReplace(SqlVal) & "'"
                        Else
                            SqlValue = SqlValue & "," & GetTextFormat(SqlVal)
                        End If
                    End If
                End If
            End If
            fldMap.MoveNext
            k = k + 1
        Wend
    End With
    RetrieveInfor = True
ErrHandler:
    Err.Clear
    On Error Resume Next
    wrdDocs.Close False
    If UnknownFileError Then
        MsgBox Replace(Msg("MSG_UNKNOWN_ERROR_DETECTED"), "%%", "[" & xlsFileName & "]"), vbCritical
    End If
ErrExit:
    Set xlSheet = Nothing
    Set wrdDocs = Nothing
    Debug.Print Err.Description
    Err.Clear
    DoCmd.Hourglass True
End Function
Chữ ký của Noname 020
ღღღღღTài sản của Noname (View All Items) ღღღღღ
Reply
Những người đã cảm ơn
#20
sql="S ELECT * F ROM Table1 W HERE NAME='"& CotDieukien &"'"
Chữ ký của Noname 020
ღღღღღTài sản của Noname (View All Items) ღღღღღ
Reply
Những người đã cảm ơn


Chuyển nhanh:


User(s) browsing this thread: 1 Guest(s)
Diễn Đàn Thơ Văn Thi Ẩm Lâu|Nhà Hàng Sông Thơ