Trang 1 / 12 12346 ... LastLast
Hiển thị kết quả từ 1 đến 10 / 111
  1. #1
    Tham gia
    08-07-2004
    Bài viết
    192
    Like
    0
    Thanked 14 Times in 14 Posts

    Office VBA, mỗi ngày một ví dụ....

    Vâng!
    Thưa các Quý vị, vào ddth tôi thấy nhiều câu hỏi về Office VBA quá, quả thật cũng có khá nhiều người như tôi vẫn đang mò mẫm về Access, Excel... để làm các ứng dụng của mình vì mục đích nào đó - cho mình hoặc cho người khác...
    Thiết nghĩ chúng ta có thể bắt đầu một chủ đề mới chuyên về Office VBA nhé, mỗi ngày một ví dụ mới về các thủ thuật.
    Nếu Quý vị đồng ý thì chúng ta cùng đóng góp để tất cả đều có thể bắt đầu học từ nhau những điều mình chưa biết để công việc sẽ ngày càng tiến triển...
    Nói thế thôi vậy không thì lại bảo là nhiều lời.
    '//////////Now...Start.......
    Hôm nay tôi bắt đầu với việc đưa thêm các mục menu mới vào Excel và tự động xoá khi thoát khỏi Excel nhé....
    ' Đoạn mã sau đây sẽ tạo ra một thực đơn mới trong thực đơn hệ thống của Excel, đồng thời tạo ra một thực đơn thấp hơn, khi nhấn vào sẽ thực thi một động tác ta quy định....
    Chép đoạn mã nguồn sau vào Code Module của Thisworkbook nhé
    '================================================
    Option Explicit

    Private Sub Workbook_Open()
    ' Để tạo được thực đơn, bạn phải tham chiếu đến thư viện đối tượng của
    ' Office - nhấn Tools chọn Reference và tìm thư viện đối tượng của Office

    Dim icmb As CommandBar
    Dim cbCtrPar As CommandBarControl, cbCtrChild As CommandBarControl
    Set icmb = Application.CommandBars("Worksheet Menu Bar")

    ' Đoạn này tớ làm để tắt thực đơn hệ thống mà thôi... nay chẳng dùng nữa
    'For Each cbCtrPar In iCmb.Controls
    ' cbCtrPar.Visible = False
    'Next

    ' Bắt đầu nhé
    Set cbCtrPar = icmb.Controls.Add(msoControlPopup, , , , True)
    ' Đặt tên và gán đuôi cho thực đơn...
    cbCtrPar.Caption = "Test"
    cbCtrPar.Tag = "Created"

    ' Tạo thực đơn con cho thực đơn trên
    Set cbCtrChild = cbCtrPar.Controls.Add(msoControlButton, 2091, , , True)

    ' Gán đuôi Tagf cho thực đơn để sử dụng sau này....
    cbCtrChild.Tag = "Created"
    ' Bây giờ gán hành động cho thực đơn đây (ta phải có một hàm trong module mới được, nếu không, thì nó chẳng chạy đâu.
    cbCtrChild.OnAction = "AssignmeNow"
    cbCtrChild.Caption = "Okay here is the test"
    Set icmb = Nothing
    Set cbCtrPar = Nothing
    End Sub

    Private Sub Workbook_BeforeClose(Cancel As Boolean)
    ' Thủ tục này sẽ được kích hoạt khi đóng tài liệu, thực ra khi Excel thoát ra
    ' thực đơn vừa tạo sẽ bị xoá do ta đặt thuộc tính Temporary là true lúc
    ' tạo thực đơn ở phần trên
    Dim cbCtrPar As CommandBarControl
    Dim icmb As CommandBar
    ' Okay - ta phải tìm cái thực đơn vừa tạo và xoá nó nhé, bí quyết là
    ' thuộc tính tag ta đã đặt từ khi tạo thực đơn
    Set icmb = Application.CommandBars("Worksheet Menu Bar")

    'On Error Resume Next
    For Each cbCtrPar In icmb.Controls
    If cbCtrPar.Tag = "Created" Then
    cbCtrPar.Delete
    Exit For
    End If
    Next
    ' đoạn này để bật thực đơn hệ thống lại - nay cũng không dùng , hihi
    'For Each cbCtrPar In iCmb.Controls
    ' cbCtrPar.Visible = true
    'Next

    Set cbCtrPar = Nothing
    End Sub

    '///////////////////Đưa đoạn code này vào một Module mới nhé/////////
    Function AssignmeNow()
    MsgBox "Hello Dear"
    End Function
    Quote Quote

  2. Thành viên Like bài viết này:


  3. #2
    Tham gia
    08-07-2004
    Bài viết
    192
    Like
    0
    Thanked 14 Times in 14 Posts
    Ngại viết lại quá... Cái này dùng để in ra danh sách các số ID của Menubar trong Excel...

    Sub GetBtnID()
    Dim cmb As Object
    Dim iStr As String
    '' search through all commanbars...
    For Each cmb In Application.CommandBars
    iStr = iStr & PrintBtnID(cmb)
    Next
    WriteLog iStr
    End Sub

    Private Function PrintBtnID(iCb As Object) As String
    Dim iCtr As Object
    Dim RetStr As String
    For Each iCtr In iCb.Controls
    If hasSubControl(iCtr) Then
    '' recursive search as button may contain sub-control as well
    PrintBtnID = PrintBtnID & PrintBtnID(iCtr)
    Else
    RetStr = RetStr & iCtr.Caption & vbTab & iCtr.ID & vbCrLf
    End If
    Next
    PrintBtnID = RetStr
    End Function

    Private Sub WriteLog(iTxt As String)
    '' write all to a file...
    Dim txtString As String, FileNames As String
    FileNames = ThisWorkbook.Path & "\IDNumber.log"
    On Error GoTo ErrorChk
    Open FileNames For Append As #1
    Print #1, iTxt
    Close #1
    Exit Sub
    ErrorChk:
    Close #1
    End Sub

    Private Function hasSubControl(iCtr As Object) As Boolean
    Dim i As Long
    On Error GoTo ErrHandler
    i = iCtr.Controls.Count
    hasSubControl = True
    ErrHandler:
    End Function
    Được sửa bởi paulsteigel lúc 18:40 ngày 11-03-2005

  4. Thành viên Like bài viết này:


  5. #3
    Tham gia
    12-03-2004
    Bài viết
    40
    Like
    0
    Thanked 0 Times in 0 Posts

    Thông tin Hỏi về cơ sở dữ liệu cho excel!

    Hi bác,

    Bài viết hay đấy, vì tớ ít nghiên cứu excel nên có nhiều điều để hỏi.

    Trong excel tạo một form+ list box.
    Tôi muốn lấy dữ liệu bên ngoài ví dụ một tập tin excel khác rồi đưa dữ liệu đó vào listbox của form. Tôi biết nó dùng ado để lấy dữ liệu. Ngặc một nổi phần help của excel không có hướng dẫn lấy dữ liệu từ bên ngoài mà chỉ trong book của excel mà thôi.

    Nếu bác biết hãy chia sẽ cùng anh em.

    Cám ơn bác nhiều.

  6. #4
    Tham gia
    08-07-2004
    Bài viết
    192
    Like
    0
    Thanked 14 Times in 14 Posts
    Ờ ờ.... cái này thì được....
    + Nếu bạn lấy dữ liệu từ file excel khác thì dễ quá..
    Đơn giản là thiết lập một kết nối với file Excel đó, xong đó là đọc các range của nó như là file excel bạn đang làm việc vậy....
    Ví dụ đây

    Option Explicit
    ' Add a listbox name listbox1 into the form, create an excel file with the sheet 1, a header row of Mynam and add some text there.

    Private Sub UserForm_Initialize()
    'AddFirstWay ' user internal excel connection
    AddSecondWay ' user DAO connection, you have to set reference to DAO 3.***
    End Sub

    Private Sub AddFirstWay()
    ' Okay connect the to other datasource here
    Dim Wrk As Workbook
    Dim wrsht As Worksheet
    ' assuming that data is in sheet1 of the workbook test
    ' in the same folder with current workbook
    Set Wrk = Workbooks.Open(ThisWorkbook.Path & "\Test.xls")
    Set wrsht = Wrk.Sheets("Sheet1")

    ' Initialize a range now
    Dim iRange As Range
    Dim curRange As Range
    Dim i As Long
    Set curRange = wrsht.Range("B2")
    While Not IsEmpty(curRange.Value)
    ListBox1.AddItem (curRange.Value)
    Set curRange = curRange.Offset(1)
    Wend
    Set curRange = Nothing
    Set wrsht = Nothing
    Wrk.Close
    End Sub

    Private Sub AddSecondWay()
    ' We use DAO Connection
    Dim dbs As Database
    Dim rcs As Recordset

    ' Initial the database object
    Set dbs = OpenDatabase(ThisWorkbook.Path & "\Test.xls", False, False, "Excel 8.0;HDR=YES;")
    'Dim iB As Object
    'For Each iB In dbs.TableDefs
    ' Debug.Print iB.Name
    'Next
    ' Now open the sheet
    Set rcs = dbs.OpenRecordset("SELECT [MyName] FROM [Sheet1$] where [MyName]<>'' Order by [MyName];")
    ' Add record to list
    While Not rcs.EOF
    ListBox1.AddItem (rcs.Fields("MyName"))
    rcs.MoveNext
    Wend
    rcs.Close
    dbs.Close
    End Sub

  7. Thành viên Like bài viết này:


  8. #5
    Tham gia
    12-03-2004
    Bài viết
    40
    Like
    0
    Thanked 0 Times in 0 Posts

    Thông tin Hi

    Bác lấy đâu cuốn sách đó vậy,

    Hay đó.

    Nhưng chỉ có thể đưa một column vào thôi.
    tôi nghĩ thế này
    ' lay du lieu dua vao cot thu hai trong listbox

    me.listbox1.list(0,1)= rcs.Fields("MyName1"))

    MyName1 la lay trong sql field thu hai, dua vao no khong loop duoc day.
    ma khong co additem thi khng run duoc.

    Co cach nao duoc n cot vao listbox khong

    thanks bác rất nhiều nhiều

  9. #6
    Tham gia
    29-06-2003
    Location
    Ở..ở..ý quên mất rùi
    Bài viết
    261
    Like
    0
    Thanked 1 Time in 1 Post
    Cái này hay đó, pác post nhiều nhiều lên 1 tí cho anh em học hỏi đi

  10. #7
    Tham gia
    08-07-2004
    Bài viết
    192
    Like
    0
    Thanked 14 Times in 14 Posts
    Thành thực xin lỗi quý vị, những cái này tôi đều lấy từ kinh nghiệm làm việc trước đây mà thôi cũng như từ một vài câu hỏi mà các bạn ở ttvnol cũng như ở đây đặt ra.
    Tuy nhiên có điều là tôi chỉ là dân Amateur nên việc trình bày các đoạn thủ tục đều không chuyên nghiệp ... hihi. Và biết đến đâu thì nói mò đến đó thôi.
    (VBA là cái mà tôi thích nhất)
    Vì thế, nếu có nhiều câu hỏi thì tôi sẽ lựa chọn và trả lời từng phần...
    Trở lại vấn đề của enemykill....

    "Nhưng chỉ có thể đưa một column vào thôi.
    tôi nghĩ thế này
    ' lay du lieu dua vao cot thu hai trong listbox

    me.listbox1.list(0,1)= rcs.Fields("MyName1"))"
    ' Với cách lấy trực tiếp từ range trong excel thì thế này
    ListBox1.ColumnCount = 4
    ListBox1.RowSource = "a1:d4"

    Còn lấy theo cách dùng DAO hoặc ADODB thì có khác tí tẹo, tôi không nói lại cách lấy dữ liệu nhé, chỉ đưa ra đây cách để làm thế nào điền dữ liệu vào listbox có nhiều cột một cách đơn giản nhất:

    Private Sub Testmulticolumn()
    'In: Just load data to a sample multi-dimension array...
    'out: set the list() property to the data charged array...

    Dim i, j, Rows As Single
    ' We have to be sure in advance how many columns should be added to the list (as we can only redeclare the second dimension of the array)
    Dim MyArray(2, 3) As String
    ' How many column, the list should have
    ListBox1.ColumnCount = 3
    ' this is to decide widths of colums in listbox
    ListBox1.ColumnWidths = "1 in;1 in;1 in"
    ' let's assuming that we have only 2 rows for fun...
    Rows = 2
    ' looping for adding data to the array
    For j = 0 To ListBox1.ColumnCount - 1
    For i = 0 To Rows - 1
    MyArray(i, j) = "Row " & i & ", Column " & j
    Next i
    Next j
    'Load MyArray into ListBox1
    ListBox1.List() = MyArray
    End Sub
    ' Cám ơn sự theo dõi của các quý vị...
    <<<<Quả thật mình không thích dịch lại cái comment vì trong IDE của VBA mình đánh tiếng việt Unicode không được nên dùng luôn tiếng ANh cho tiện, nếu các bạn không thích thì cho tôi biết một tiếng để lần sau không làm thế nữa ạ...??>>>>
    Được sửa bởi paulsteigel lúc 11:01 ngày 13-03-2005

  11. Thành viên Like bài viết này:


  12. #8
    Tham gia
    08-07-2004
    Bài viết
    192
    Like
    0
    Thanked 14 Times in 14 Posts
    Vâng bây giờ là phần chuyển đổi bảng mã...
    Tớ đã làm một công cụ chuyển đổi nhúng trong word hỗ trợ 17 bảng mã khác nhau, khá to, 250 KB, bận quá không làm tiếp được, nếu ai quan tâm muốn cùng đóng góp tiếp thì mail cho tớ.
    Bây giờ tớ chỉ đưa ra một công cụ chuyển đổi mã tcvn sang Unicode và ngược lại thôi (Cắt bớt chỉ làm việc với 75 nguyên âm mà tcvn có thôi)
    Không giải thích nhiều lắm ....
    Function ToUnicode(txtString As String, Optional isReversed As Boolean = False) As String
    ' This function will do the conversion of text string into unicode
    Dim iStr As String, repTxt As String, mText As String
    Dim i As Long, j As Long
    Dim iUnicode As Variant ' array to keep unicode char set
    Dim iTCVN As Variant ' array to keep TCVN char set
    Dim iProcList() As String ' array to keep what to convert

    'parse the parameter into this local variable
    iStr = txtString
    mText = txtString

    If fLang = "E" Then GoTo fExit
    iUnicode = Array(225, 224, 7843, 227, 7841, 259, 7855, 7857, 7859, 7861, 7863, 226, _
    7845, 7847, 7849, 7851, 7853, 233, 232, 7867, 7869, 7865, 234, 7871, 7873, 7875, _
    7877, 7879, 237, 236, 7881, 297, 7883, 243, 242, 7887, 245, 7885, 244, 7889, 7891, _
    7893, 7895, 7897, 417, 7899, 7901, 7903, 7905, 7907, 250, 249, 7911, 361, 7909, _
    432, 7913, 7915, 7917, 7919, 7921, 253, 7923, 7927, 7929, 7925, 273, 193, 192, 195, _
    258, 194, 212, 416, 431, 272)

    iTCVN = Array(184, 181, 182, 183, 185, 168, 190, 187, 188, 189, 198, 169, 202, 199, 200, _
    201, 203, 208, 204, 206, 207, 209, 170, 213, 210, 211, 212, 214, 221, 215, 216, 220, _
    222, 227, 223, 225, 226, 228, 171, 232, 229, 230, 231, 233, 172, 237, 234, 235, 236, _
    238, 243, 239, 241, 242, 244, 173, 248, 245, 246, 247, 249, 253, 250, 251, 252, 254, _
    174, 193, 192, 195, 161, 162, 164, 165, 166, 167)

    ' Re-enlarge the array
    ReDim iProcList(1, 133)
    ' process the vowel only and convert to asc code
    For i = 1 To Len(mText)
    repTxt = Mid(mText, i, 1)
    If AscW(repTxt) > 122 Then
    iStr = Replace(iStr, repTxt, "[" & AscW(repTxt) & "]")
    mText = Replace(mText, repTxt, " ")
    ' write the processed list
    iProcList(1, j) = "[" & AscW(repTxt) & "]"
    If isReversed Then
    iProcList(0, j) = GetElementNo(AscW(repTxt), iUnicode)
    Else
    iProcList(0, j) = GetElementNo(AscW(repTxt), iTCVN)
    End If
    j = j + 1
    End If
    Next
    If j = 0 Then
    ToUnicode = txtString
    Exit Function
    End If
    ReDim Preserve iProcList(1, j - 1)
    ' now convert to unicode
    For i = 0 To UBound(iProcList, 2)
    If isReversed Then
    iStr = Replace(iStr, iProcList(1, i), ChrW(iTCVN(Val(iProcList(0, i)))))
    Else
    iStr = Replace(iStr, iProcList(1, i), ChrW(iUnicode(Val(iProcList(0, i)))))
    End If
    Next
    fExit:
    ToUnicode = iStr
    End Function

    Private Function GetElementNo(iTxt As Long, iObj As Variant) As String
    Dim i As Long
    For i = 0 To UBound(iObj)
    If iTxt = iObj(i) Then
    GetElementNo = CStr(i)
    Exit For
    End If
    Next
    End Function

    ‘ đây cũng là một câu hỏi các bạn ở box khác đang hỏi, nên tiên đây tôi post luôn để đỡ phải trả lời nhiều .. hihi
    Nay kính thư
    Được sửa bởi paulsteigel lúc 09:30 ngày 15-03-2005

  13. Thành viên Like bài viết này:


  14. #9
    Tham gia
    08-07-2004
    Bài viết
    192
    Like
    0
    Thanked 14 Times in 14 Posts
    I. Trả lời câu hỏi của bạn Hùng
    Tôi gửi kèm phần trả lời bạn hungdhb để mọi người tiện tham khảo cách kết nối với word bằng Access hoặc VB.
    Quote Được gửi bởi hungdhb
    Cảm ơn bạn đã chỉ cho tôi giao tiếp VB và word.Tôi đã hiểu.Tôi đã làm theo bạn hướng dẫn.Khi chạy chương trình thì mỗi khi ghi data từ biến mystring vào word thì chương trình lại hỏi save as để mình phải nhập tên file cần lưu vào. Sau đó nó tự động đóng file đó lại và chỉ còn cửa sổ word trắng (không có file nào hiển thị cả). Tôi muốn mỗi khi chương trình ghi dữ liệu từ biến mystring vào file word, nó sẽ tự động lưu vào “C: \doc” với tên file là ngày giờ lúc đó kèm theo tên form hiện hành.Sau đó chương trình sẽ tự động mở file đó ra xem luôn. Nếu vậy thì tôi phải sửa ntn trong đoạn code đó, bạn giúp tôi với. Xin cảm ơn rất nhiều.
    À, sao khi chạy tôi không thấy word tự động prỉnpiview cho mình thấy mặc dù mình đã có viết lệnh wrdDoc.PrintPreview

    Option Explicit
    Dim wrdApp As Word.Application
    Dim wrdDoc As Word.Document
    Public Sub WordAutomate()
    'Dim wrdApp As Object
    'Dim wrdDoc As Object
    'Dim wrdSelection As word.Selection
    Dim wrdSelection As Word.Selection
    Dim myString As String
    Set wrdApp = CreateObject("Word.application")

    wrdApp.Visible = False
    myString = "A test for word Automation"
    Set wrdDoc = wrdApp.Documents.Add

    wrdDoc.Select

    Set wrdSelection = wrdApp.Selection
    wrdSelection.TypeText myString
    wrdDoc.PrintPreview
    wrdDoc.Close

    End Sub
    '//////////////////////////////////////////////////////
    ' Create a form and three buttons
    ' Then you paste the following code.... all you will see
    ' Assuming that we are using access as the IDE.
    Option Explicit
    Dim wrdApp As Object
    Dim wrdDoc As Object

    Sub WordAutomate(TxtToInsert As String)
    Dim wrdSelection As Object
    Dim myString As String
    Set wrdApp = CreateObject("Word.application")
    wrdApp.Visible = True
    Set wrdDoc = wrdApp.Documents.Add
    wrdDoc.Select
    Set wrdSelection = wrdApp.Selection
    wrdSelection.Text = TxtToInsert
    End Sub

    Private Sub cmdClose_Click()
    wrdDoc.SaveAs currentproject.Path & "\" & Me.Name & Format(Now, "dd_mm_yyyy") & ".doc"
    wrdDoc.Close
    Set wrdDoc = Nothing
    wrdApp.quit
    End Sub

    Private Sub cmdOpen_Click()
    WordAutomate "This is the test"
    End Sub

    Private Sub cmdPreview_Click()
    wrdDoc.PrintPreview
    End Sub
    '//////////////////////////////////////////////////////
    'Nay kính thư...

    II. Cách tạo menubar trong access
    Tạo menubar trong access là một công việc khá thú vị. Hiện tại theo tôi biết thì có 2 cách cơ bản để tạo ra menubar trong access.
    + Dùng Macro với Addmenuitem (tôi không dùng nữa vì cũng không thích cách này lắm)
    + Dùng Code. Tôi sẽ giới thiệu cách này, (các bạn nên xem ví dụ trong file access kèm theo nhé)
    '////////////////////////////////////////
    Bắt đầu:
    + Tạo ra bảng có chứa các menu mà ta định chế tác.
    + Thực thi đoạn mã tạo menu.
    (Để có thêm chi tiết về bảng dữ liệu, các bạn download ví dụ về nhé)
    Sub CreateMenubar()
    ' Tạo Toolbar
    CreateMenubar "VDPToolBar", 0
    ' Tạo Menubar
    CreateMenubar "VDP Man", , False
    ' Tạo PopMenu
    CreateMenubar "VDPPop", 2
    End sub

    Private Sub CreateMenubar(mnuBar As String, Optional iType As Long = 1, Optional DontCreate As Boolean = True)
    Dim i As Long
    ' Create menubar
    Dim mnuRcs As Recordset
    Dim iCmb As CommandBar
    Dim cbCtrPar As Object
    Dim cbCtrChild As CommandBarControl
    ' Start creating the menu
    If Not DontCreate Then
    Set iCmb = CommandBars.Add(Name:=mnuBar, Position:=IIf(iType = 2, msoBarPopup, msoBarTop), MenuBar:=IIf(iType = 0 Or iType = 2, False, True), Temporary:=False)
    Else
    Set iCmb = CommandBars(mnuBar)
    End If

    ' Initialized recordset
    Set mnuRcs = CurrentDb.OpenRecordset("Select * from SysMenu where MenubarName='" & mnuBar & "' And [Tag] is null Order by [Order];")

    With mnuRcs
    While Not .EOF
    If IsNull(.Fields("BaseIndex")) Then
    Set cbCtrPar = iCmb.Controls.Add(msoControlPopup, , , , False)
    cbCtrPar.Caption = .Fields("MnuCaptionV")
    cbCtrPar.Tag = .Fields("AccessLevel")
    Else
    If iType <> 1 Then Set cbCtrPar = CommandBars(mnuBar)
    If .Fields("Action") = "import" Then
    Set cbCtrChild = cbCtrPar.Controls.Add(msoControlButton, .Fields("SysMenuID"), , , False)
    Else
    Set cbCtrChild = cbCtrPar.Controls.Add(msoControlButton, , , , False)
    If .Fields("Action") <> "" Then cbCtrChild.OnAction = .Fields("Action")
    End If
    cbCtrChild.Caption = .Fields("MnuCaptionV")
    cbCtrChild.Tag = .Fields("AccessLevel")
    cbCtrChild.BeginGroup = .Fields("Group")
    ' depend on type of bar, we can set the button face here
    If iType = 0 Then
    If Not IsNull(.Fields("SysMenuID")) Then
    CommandBars(CStr(.Fields("SysMenu"))).Controls(.Fi elds("SysMenuID")).CopyFace
    cbCtrChild.PasteFace
    End If
    cbCtrChild.Style = 3
    End If
    End If
    .MoveNext
    Wend
    .Close
    End With
    If iType <> 2 Then
    iCmb.Position = msoBarTop
    iCmb.Protection = msoBarNoChangeVisible + msoBarNoCustomize + msoBarNoResize + msoBarNoChangeDock
    iCmb.Visible = True
    End If
    Set iCmb = Nothing
    Set cbCtrPar = Nothing
    Set cbCtrChild = Nothing
    End Sub

    Function MenuBarExist(mnuBarName As String) As Boolean
    ' Cái này để xác định xem menubar có tồn tại không
    Dim mnuBar As Object
    ' Check for wherether toolbar M is installed
    For Each mnuBar In Application.CommandBars
    If mnuBar.Name = mnuBarName Then
    MenuBarExist = True
    Exit Function
    End If
    Next
    End Function

    Sub SetAccesslevel(mnuBarName As String, iLevel As Integer)
    Dim mnuBar As CommandBar
    Set mnuBar = CommandBars(mnuBarName)
    SetAccess mnuBar, iLevel
    Set mnuBar = Nothing
    End Sub

    Private Sub SetAccess(Mnb As Object, iLevel As Integer)
    ' Cái này để hiển thị các menubar tại các mức truy cập khác nhau
    Dim obj As Object
    For Each obj In Mnb.Controls
    If HasSubControl(obj) Then SetAccess obj, iLevel
    If InStr(obj.Tag, CStr(iLevel)) <> 0 Then obj.Visible = True Else obj.Visible = False
    Next
    End Sub
    ' Nếu các bạn có yêu cầu gì thêm thì gửi thư cho tôi nhé. ngocdd@itprog.gov.vn
    Attached Files
    Được sửa bởi paulsteigel lúc 12:50 ngày 17-03-2005

  15. Thành viên Like bài viết này:


  16. #10
    Tham gia
    08-07-2004
    Bài viết
    192
    Like
    0
    Thanked 14 Times in 14 Posts
    Mỗi một tập tin mdb đều có một số thuộc tính đặc biệt, theo đó các thuộc tính này nếu được điều chỉnh sẽ mang lại một ảnh hưởng nhất định đến cách “cư xử” của tập tin, một số thuộc tính cơ bản loại này thường không thể tác động trước khi ta tiến hành thủ tục tạo lập nó. Sau đây là tên một số thuộc tính cơ bản (tôi tạm dich tên thuộc tính sau dấu”/”):
    AppTitle / Tiêu đề của ứng dụng
    AppIcon / Đường dẫn của biểu tượng
    StartupShowDBWindow / Khi khởi thộng hiển thị cửa sổ Database
    StartupShowStatusBar / Khi khởi động hiển thị thanh trạng thái
    AllowShortcutMenus / Cho phép hiển thị thực đơn khi nhấn trái chuột
    AllowFullMenus / Cho phép hiển thị tất cả các thực đơn
    AllowBuiltInToolbars / Cho phép hiển thị các thanh công cụ hệ thống
    AllowToolbarChanges / Cho phép thay đổi thanh công cụ
    AllowBreakIntoCode / Cho phép xem mã nguồn
    AllowSpecialKeys / Cho phép nhấn phím đặc biệt (F11/ Alt + F11...)
    AllowBypassKey / Cho phép nhấn phím trượt
    Riêng các thuộc tính 1 và 2 thì ta cần có kiểu dữ liệu truyền cho nó là ký tự còn các thuộc tính còn lại, tham số truyền vào chỉ là true hoặc false.
    Sau đây là đoạn mã nguồn thực thi:
    ‘/////////////////////////////////////////
    Sub SetStartupProperties()
    ‘ Tôi dùng trong hệ thống của mình một bảng cung cấp các giá trị thuộc tính cũng như tên thuộc tính/ để sử dụng được mã nguồn này, bạn nên tạo ra một bảng có cấu trúc trường như trong câu lệnh sql sau:
    ‘Create Table Config(ID Integer, PropertyName Text(150), PropertyValue Text(150), Type Integer);
    ‘Sau đó thêm các giá trị thuộc tính trên đây vào bảng này
    Dim dbs As RecordSet
    Const DB_Text As Long = 10
    Const DB_Boolean As Long = 1
    Set dbs = CurrentDb.OpenRecordset("Select * from Config Where [Type]=1")
    ' Việc này chỉ làm thay đổi thuộc tính của CSDL
    While Not dbs.EOF
    If dbs.Fields(1) = "AppIcon" Then
    ChangeProperty dbs.Fields(1), DB_Text, CurrentProject.Path & "\" & dbs.Fields(2)
    Else
    ChangeProperty dbs.Fields(1), IIf(dbs.Fields(1) = "AppTitle", DB_Text, DB_Boolean), dbs.Fields(2)
    End If
    dbs.MoveNext
    Wend
    Application.RefreshTitleBar
    dbs.Close
    End Sub

    Function ChangeProperty(strPropName As String, varPropType As Variant, varPropValue As Variant) As Integer
    ‘ Hàm này dùng để thay đổi giá trị thuộc tính, nếu gặp lỗi thì nó sẽ tạo ra thuộc tính của CSDL (vì trên thực tế thuộc tính này chưa được tạo ra)
    Dim dbs As Object, prp As Variant
    Const conPropNotFoundError = 3270

    Set dbs = CurrentDb
    On Error GoTo Change_Err
    dbs.Properties(strPropName) = varPropValue
    ChangeProperty = True

    Change_Bye:
    Exit Function

    Change_Err:
    If Err = conPropNotFoundError Then ' Không thấy thuộc tính này.
    Set prp = dbs.CreateProperty(strPropName, _
    varPropType, varPropValue)
    dbs.Properties.Append prp
    Resume Next
    Else
    ' Lỗi không xác định được.
    ChangeProperty = False
    Resume Change_Bye
    End If
    End Function
    ‘ Bạn có thể dùng cách này để ngăn cản sự truy cập theo cách thông thường đến cơ sở dữ liệu của bạn. Tuy nhiên, một số thuộc tính chỉ thay đổi và kích hoạt sau lần khởi động thứ 2 của cơ sở dữ liệu.

  17. Thành viên Like bài viết này:


Trang 1 / 12 12346 ... LastLast

Bookmarks

Quy định

  • Bạn không thể tạo chủ đề mới
  • Bạn không thể trả lời bài viết
  • Bạn không thể gửi file đính kèm
  • Bạn không thể sửa bài viết của mình
  •