Lập trình để tỏ tình bằng excel (1 người xem)

[tuan_anhbm]

Gửi các bạn file này tham khảo và thư giãn cho vui.

 

[bemyself]

Làm thế nào thế pác ơi. Từ hồi vô diễn đàn thấy khôn ra nhiều. Thấy j cũng muốn học

 

[ndu96081631]

Gửi các bạn file này tham khảo và thư giãn cho vui.

Biểu diển thì hay nhưng mà xem code thì thấy... lằng nhằng quá ---> Còn phải rút gọn và cải tiến thêm rất nhiều
(chỉ nội mấy cái Select và Selection thôi cũng đủ mất thời gian)

 

[Tigon-ETC]

Cái này phải gửi đích danh cho ai đó mới có tác dụng hí hí

 

[tuan_anhbm]

Biểu diển thì hay nhưng mà xem code thì thấy... lằng nhằng quá ---> Còn phải rút gọn và cải tiến thêm rất nhiều
(chỉ nội mấy cái Select và Selection thôi cũng đủ mất thời gian)

Thầy NDU thấy chưa được chỗ nào xin làm ơn chỉ giáo, đó cũng là mục đích khi posst bài của tôi mà. Còn "mấy cái Select và Selection" - ấy là do tôi muốn con trỏ chuột nó chạy lòng vòng chút cho thêm phần "khí thế".
Thanks.

 

[ndu96081631]

Thầy NDU thấy chưa được chỗ nào xin làm ơn chỉ giáo, đó cũng là mục đích khi posst bài của tôi mà. Còn "mấy cái Select và Selection" - ấy là do tôi muốn con trỏ chuột nó chạy lòng vòng chút cho thêm phần "khí thế".
Thanks.

Lấy ví dụ việc kẽ khung vòng quanh, tôi chỉ cần thế này là đủ

Private Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)
Sub ToMau()
  Dim i As Long, iR As Long, iC As Long
  Range("A:AY").Clear
  For i = 1 To 118
    With Range("A1").Offset(iR, iC)
      .Select: .Interior.ColorIndex = 8 - 4 * (i Mod 2)
    End With
    Select Case i
      Case i = 1 To 50: iC = iC + 1
      Case i = 51 To 59: iR = iR + 1
      Case i = 60 To 109: iC = iC - 1
      Case i = 109 To 118: iR = iR - 1
    End Select
    Sleep 20
  Next i
End Sub

Các phần còn lại tự bạn suy nghĩ nhé

 

[ndu96081631]

Phân tích quá trình chạy code trên file của bạn, ta thấy nó bao gồm các bước sau:
1) Bước 1: Kẽ khung và chạy chữ
2) Bước 2: Clear bảng tính và lập lại bước 1
3) Bước 3: Co giãn dong 2 lần
4) Bước 4: Nhấp nháy chữ và nền
Vậy ta chia code thành 4 sub như sau:

Private Sub Enframe()
  Dim i As Long, iR As Long, iC As Long
  Range("A:AY").Clear
  For i = 1 To 118
    With Range("A1").Offset(iR, iC)
      .Select: .Interior.ColorIndex = 8 - 4 * (i Mod 2)
    End With
    Select Case i
      Case i = 1 To 50: iC = iC + 1
      Case i = 51 To 59: iR = iR + 1
      Case i = 60 To 109: iC = iC - 1
      Case i = 109 To 118: iR = iR - 1
    End Select
    DoEvents
    Sleep 20
  Next i
End Sub

Private Sub TypeLetter()
  Dim Clls As Range
  Set ForeRng = Union([C3:E3], [D4:D7], [C8:E8], [I3:I8], [J8:L8], [N3:N8], [O3:P3], [Q3:Q8], _
                [O8:P8], [S3:S6], [T7], [U8], [V3:V7], [X3:X8], [Y3:AA3], [Y5:AA5], [Y8:AA8], _
                [AE3:AE5], [AF5:AG5], [AH3:AH8], [AE8:AG8], [AJ3:AJ8], [AK3:AL3], _
                [AM3:AM8], [AK8:AL8], [AO3:AO8], [AR3:AR8], [AP8:AQ8], [AV3:AV6], [AV8])
  For Each Clls In ForeRng
    Clls.Select: Clls.Interior.ColorIndex = 10
    DoEvents
    Sleep 30
  Next
End Sub

Private Sub Elastic()
  Dim i As Long
  For i = 1 To 28
    With Rows("2:9")
      .RowHeight = .RowHeight + IIf(i < 15, -1, 1)
    End With
    DoEvents
    Sleep 100
  Next
End Sub

Private Sub FlashCell()
  Dim i As Long, j As Long
  Set BackRng = Range("B2:AX9")
  For i = 1 To 2
    For j = 1 To 6
      BackRng.Interior.ColorIndex = -(i = 2) * (j Mod 2) * 36
      ForeRng.Interior.ColorIndex = 10 + ((j Mod 2) * 36) * (i Mod 2)
      Sleep 500
      DoEvents
    Next j
  Next i
End Sub

Cuối cùng là sub chính để gọi các sub trên

Private Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)
Private ForeRng As Range, BackRng As Range

Sub Auto_Open()
  Enframe
  TypeLetter
  Sleep 1000
  Enframe
  TypeLetter
  Sleep 1000
  Elastic
  Elastic
  Sleep 1000
  FlashCell
  Set ForeRng = Nothing: Set BackRng = Nothing
End Sub

Ngắn gọn không!
(Tôi nghĩ vẫn còn cải tiến thêm được nữa đấy)

 

[quachcongluanadong]

em muốn học lập trình trong exccell từ căn bản nhất mà k biết tìm tài liệu ở đâu và tài liệu gì phù hợp! là thành viên mới nên ....còn bói rói rất mong được sự giúp đở của mọi người, xin cảm ơn!

 

[ndu96081631]

Buồn quá, chẳng có gì làm nên vọc tiếp file này!
- Cải tiến thêm mấy hiệu ứng: Chữ vỡ ra từng mảnh rồi ráp vào
- Bẫy thêm 1 số lỗi có thể xảy ra, ví dụ đứng từ file khác và gọi sub ở file này!
Mời xem file và thưởng thức nhé
------------------------------------
Nói thêm: Thuật toán làm việc không khó, cái vã nhất là THIẾT KẾ GIAO DIỆN ---> Ai có năng khiếu về vụ này hãy cải tiến tiếp nhé (chẳng hạn làm cho chữ "bay" từ trên xuống... và lồng bài hát vào... vân vân...)
(Tặng người phụ nữ mà ta yêu nhất nhân ngày 8/3 cũng là món quà ý nghĩa đây)

 

[yeudoi]

Cái vụ này chắc anh xem cải tiến tiếp đi, thấy hơi bị hay đó

 

[tienphattien]

hay wa di ma sao may cua em ko xem dc vay cac bac

 

[tuan_anhbm]

hay wa di ma sao may cua em ko xem dc vay cac bac

- Vào menu Tools\Macro\Security và check vào mục "Mediium…"
- Đóng file rồi mở lại lần nữa, bấm chọn nút Enable Macros
----------------------------
NDU quả ko hổ danh cao thủ, từ 1 ý tưởng thô sơ, sư phụ đã phát triển nó lên thành 1 “món quà ý nghĩa” thật đẳng cấp với trò “gương vỡ lại lành”… để “Tặng người phụ nữ mà ta yêu nhất nhân ngày 8/3”, cái này mới thực sự mang “phong cách NDU” đây, sản phẩm từ VBA trong excel mà.
Mong các cao thủ hãy cùng ra tay góp sức để tạo thêm những tuyệt chiêu khác.
Vậy là 8/3 này tôi có món quà ngon rồi nha!
----------------------------
* Bổ sung 1 hiệu ứng:
Tôi muốn bổ sung 1 hiệu ứng như thế này (sau khi kết thúc màn biểu diễn đã có):
Các con chữ sẽ chạy từ dưới màn hình chạy lên vị trí trong khung. Ban đầu là lần lượt từng chữ (I, L, O,…) sau đó cả cả cụm từ “I Love You”. Và làm sao để khi đi qua khung (dòng 10) thì không làm đổi hay mất màu khung - tức là chữ tựa hồ như “chui” qua khung vậy.
Nhờ các bạn giúp giùm tôi biến ý tưởng thành hiện thực. Các cao thủ chắc dư sức. Tuy tôi cũng có thể làm được nhưng ngại code dài dòng lại mất công phải cải tiến…
------------
* Một nhận xét:
Xem giải pháp của NDU, tôi thấy code này (Sub Elastic ở bài số 7):
.RowHeight = .RowHeight + IIf(i < 15, -1, 1)
là “đã” nhất: rất ngắn gọn & sáng tạo. Các phần khác: chỗ hiểu, chỗ không nên chưa thể nhận xét hết.
----------
* Một câu hỏi nhờ thầy NDU giải thích:
Trong Sub Enframe ở bài số 7:

[/FONT][/COLOR]
[COLOR=black][FONT=Tahoma]Private Sub Enframe()
  Dim i As Long, iR As Long, iC As Long
  Range("A:AY").Clear
  For i = 1 To 118
    With Range("A1").Offset(iR, iC)
      .Select: .Interior.ColorIndex = 8 - 4 * (i Mod 2)
    End With
    Select Case i
      Case i = 1 To 50: iC = iC + 1
      Case i = 51 To 59: iR = iR + 1
      Case i = 60 To 109: iC = iC - 1

Theo suy luận của tôi thì 2 biến iR, iC sẽ nhận giá trị ban đầu = 0 (?), nhưng tôi không hiểu căn cứ vào đâu để 2 biến này nhận giá trị ấy nhỉ ? nhờ thầy giải đáp cho tôi rõ ạ.
-------------
Hỏi thì ngại, còn không hỏi thì….. dại!

 

[ndu96081631]

Trả lời toàn bộ câu hỏi của tuan_anhbm quả..mất nhiều thời gian... Thôi thì cải tiến file này thêm 1 bước (thay lời muốn nói), từ đó bạn phát triển tiếp nhé
File mới này có thêm mấy cải tiến như sau:
- Viết sub có tham số truyền cho ta dể tùy biến
- Thêm mấy hiệu ứng (thuộc dạng khó)
1> Hiệu ứng vẽ chữ:

Private Sub DrawText(TextRng As Range, Color As Long)
  Dim Clls As Range
  On Error GoTo ExitSub
  For Each Clls In TextRng
    Clls.Select: Clls.Interior.ColorIndex = Color
    DoEvents
    Sleep 30
  Next
ExitSub:
  Ws.Range("CJ17").Select
End Sub

Áp dụng nó chỉ cần gọi DrawText ForeRng1, 7 là nó chạy ngay
--------------------------------------------------------------------------------------
2> Hiệu ứng nhấp nháy:

Private Sub Flicker(FlRng As Range, Color1 As Long, Color2 As Long, iTime As Long)
  Dim i As Long
  On Error GoTo ExitSub
  For i = 1 To iTime
    FlRng.Interior.ColorIndex = IIf(i Mod 2, Color1, Color2)
    Sleep 500
    DoEvents
  Next i
ExitSub:
End Sub

--------------------------------------------------------------------------------------
3> Hiệu ứng chữ vỡ ra và ráp vào

Private Sub Dream(TextRng As Range, Color As Long)
  Dim i As Long, n As Long, Arr, Clls As Range
  On Error GoTo ExitSub
  With CreateObject("Scripting.Dictionary")
    For Each Clls In TextRng
      .Add Clls.Address, ""
    Next
    Arr = .Keys
  End With
  With CreateObject("Scripting.Dictionary")
    Do
      Randomize
      n = Int(Rnd * (UBound(Arr) + 1))
      If Not .Exists(Arr(n)) Then
        BorRng3.Interior.ColorIndex = 4                                       '<---  Khuyen mai them
        BorRng1.Offset(, i Mod 3).Interior.ColorIndex = 6              '<--- Khuyen mai them
        BorRng2.Offset(i Mod 3).Interior.ColorIndex = 6                '<--- Khuyen mai them
        BorRng1.Offset(9, 3 - (i Mod 3)).Interior.ColorIndex = 6     '<--- Khuyen mai them
        BorRng2.Offset(3 - (i Mod 3), -51).Interior.ColorIndex = 6  '<--- Khuyen mai them
        i = i + 1                                                                         ' Ec... Ec...
        .Add Arr(n), ""
        With Ws.Range(Arr(n))
          .Select: .Interior.ColorIndex = Color
        End With
        Sleep 50
      End If
      DoEvents
    Loop Until UBound(Arr) + 1 = .Count
  End With
ExitSub:
  Ws.Range("CJ17").Select
End Sub

Lứu ý: Việc cảm nhận chữ vỡ ra hay ráp vào là tùy thuộc vào màu nền và màu chữ ---> Ví dụ khi màu nền trùng với màu chữ thì ta sẽ có cảm giác chữ bị vỡ ra (và ngược lại)
--------------------------------------------------------------------------------------
4> Hiệu ứng chữ lượn sóng

Private Sub Wave(FRng As Range, FColor As Long, BRng As Range, BColor As Long)
  Dim i As Long, j As Long, n() As Byte
  ReDim n(1 To FRng.Count)
  On Error Resume Next
  For i = 1 To 7 + FRng.Count
    BRng.Interior.ColorIndex = BColor
    For j = 1 To FRng.Count
      n(j) = n(j) + IIf(i > j - 1 And i < 4 + j, 1, -1)
      Intersect(BRng, Ws.Range(FRng(j)).Offset(-n(j))).Interior.ColorIndex = FColor
    Next j
    Sleep 50
    DoEvents
  Next i
End Sub

--------------------------------------------------------------------------------------
5> Hiệu ứng chữ bay vào

Private Sub FlyIn(FRng As Range, FColor As Long, BRng As Range, BColor As Long, iType)
  'iType co gia tri tu 1 den 8, bieu dien huong bay cua text (tinh theo chieu kim dong ho)
  'VD: iType = 1, bay tu tren xuong, iType = 2, bay tu goc phai phia tren xuong...
  Dim Clls As Range, i As Long, n As Long, Delay As Long, Dist As Long
  Dim Tmp1 As Range, Tmp2 As Range, Tmp3 As Range, iR, iC
  On Error Resume Next
  iR = Array(1, 1, 0, -1, -1, -1, 0, 1)
  iC = Array(0, -1, -1, -1, 0, 1, 1, 1)
  Set Tmp2 = BRng
  If iType = 3 Or iType = 7 Then
    Delay = 0
    Dist = Int((BRng.Columns.Count + FRng.Columns.Count) / 2) + 15
  Else
    Delay = 10
    Dist = Int((BRng.Rows.Count + FRng.Rows.Count) / 2)
  End If
  For Each Clls In FRng
    For i = n - Dist To 0
      Set Tmp1 = Intersect(Ws.Range(Clls).Offset(i * iR(iType - 1), i * iC(iType - 1)), BRng)
      Tmp2.Interior.ColorIndex = BColor
      Tmp1.Interior.ColorIndex = FColor
      Sleep Delay
      DoEvents
    Next i
    If Tmp3 Is Nothing Then
      Set Tmp3 = Tmp1
    Else
      Set Tmp3 = Union(Tmp3, Tmp1)
    End If
    Set Tmp2 = InvertRange(BRng, Tmp3)
    If iType = 3 Or iType = 7 Then n = n + 5
  Next Clls
End Sub

Hiệu ứng chữ bay vào này cho phép bay từ 8 hướng khác nhau tùy vào biến iType (giá trị thay đổi từ 1 đến 8)
--------------------------------------------------------------------------------------
Việc cuối cùng là từ Sub chính ta gọi cái gì trước, cái gì sau, truyền tham số thế nào (là việc thuộc về con mắt thẩm mỹ)
Mời xem file và thưởng thức
Code vẫn còn nhiều khuyết điểm, xin các cao thủ hoàn thiện thêm!
Lưu ý:
- Hãy Unhide toàn bộ dòng cột để thấy được vùng tạm, ở đó lưu các địa chỉ cell dùng vào việc vẽ chữ
- Trong này có hiệu ứng âm thanh, nhớ mở loa nhé!
--------------------------------------------------------------------------------------
(Đến đây thì topic này có vẽ không phù hợp khi cho vào box thư giãn rồi, nó thiên về lập trình nhiều hơn... Nếu có thể được xin nhờ các Mod di chuyển giúp)

 

[ndu96081631]

Hôm nay tôi viết bài hướng dẩn này hy vọng giúp cho các bạn dể dàng tự mình làm 1 file mang dấu ấn cá nhân
1> Các bước chuẩn bị:
- Đầu tiên các bạn hãy down file I_LOVE_YOU_4.xls về máy, bấm giữ phím Shift rồi double vào file (mục đích không cho Autpen khởi động)
- Tiếp theo, mở 1 workbook mới, bấm Alt + F11 ---> Trong cửa số VBE, hãy dùng chuột nắm kéo các Module của file I_LOVE_YOU.xls và thả vào Workbook mới
- Đóng file I_LOVE_YOU.xls (không lưu)

2> Tiến hành vẽ chữ:
- Bây giờ trong workbook mới đã có toàn bộ code cần thiết, hãy đóng cửa số VBE (Alt + Q) để trở về bảng tính Excel
- Định dạng lại bảng tính, chỉnh độ cao dòng, độ rộng cột sao cho vừa ý
- Bôi màu lên các cell để tô nền, kẻ khung và vẽ chữ gì đó tùy ý, chẳng hạn khung nằm tại G7:BW16, nền trắng nằm tại H8:BV15 và chữ GIAI PHAP EXCEL nằm bên trong
- Lưu ý: Phải chừa lại phía trên và bên trái của khung 1 số dòng, cột tối thiểu nào đó... Cụ thể như sau:

Ví dụ chữ của bạn có độ cao = 6 cell
Vậy hãy chừa lại 6 dòng phía trên, tính từ dòng 1 đến bìa biên của khung... đồng thời chừa lại 6 cột bên trái, tình từ cột A đến bìa biên của khung
​

3> Sao lưu các địa chỉ cell chứa các nét vẽ
- Tôi đã chuẩn bị sẳn 1 code để các bạn làm việc này ---> Hãy bấm Alt + F8, chọn Config và bấm nút Run
- InputBox đầu tiên cho bạn chọn cell đầu tiên, nơi sẽ lưu lại địa chỉ các nét vẽ ---> Hãy chọn 1 cell và bấm OK (chẳng hạn chọn cell A1)
- Khi InputBox thứ 2 xuất hiên, hãy bấm giữ phím Ctrl rồi dùng chuột quét qua các nét vẽ của chữ đầu tiên ---> chẳng hạn bây giờ tôi sẽ dùng chuột quét qua các nét của chữ G ---> Xong, hãy bấm OK
- InputBox tiếp theo lại xuất hiện cho bạn quét tiếp chữ thứ 2 (ví dụ là chữ I)
- Cứ thế tiếp tục đến chữ cuối cùng, xong hãy bấm Cancell
Vậy là hoàn tất việc sao lưu địa chỉ cell chứa các nét vẽ

4> Chạy thí nghiệm các hiệu ứng
- Bấm Alt + F11, xóa sub Autpen và tạo 1 sub mới với tên tùy ý (ví dụ là Sub Test)
- Khai báo 1 vài biến miêu tả vị trí của khung, nền

Sub Test()
  Dim i As  Long, BackRng As Range, Frame As Range
  Set BackRng = [H8:BV15]   '<----Trên bảng tính của bạn có thể là vùng khác
  Set Frame =  [G7:BW16]   '<----Trên bảng tính của bạn có thể là vùng khác
   .....
End Sub

- Thử hiệu ứng kẻ khung:
Cú pháp

Enframe Vùng ,  màu 1,  màu  2

ví dụ:

Enframe Frame, 4, 8

- Thử hiệu ứng vẽ chữ
Cú pháp

DrawText  CollectRng(Vùng chứa địa chỉ các nét vẽ), màu chữ

ví dụ:

DrawText  CollectRng([A1:A13]), 3

- Thử hiệu ứng co giãn
Cú pháp

Elastic Vùng cần co  giãn

Ví dụ:

Elastic BackRng

- Thử hiệu ứng chữ nhấp nháy
Cú pháp:

Flicker  CollectRng(Vùng chứa địa chỉ các nét vẽ),  màu 1,  màu 2, số lần nhấp  nháy

Ví dụ:

Flicker CollectRng([A1:A13]), 3, 7, 6

- Thử hiệu ứng chữ vỡ ra hoặc ráp vào
Cú pháp:

DrawText CollectRng(Vùng chứa địa chỉ các nét vẽ), màu  chữ

Ví dụ

DrawText CollectRng([A1:A13]), 3

- Thử hiệu ứng chữ lượn sóng
Cú pháp

Wave Vùng chứa địa chỉ các nét vẽ, màu chữ, Vùng nền, màu  nền

Ví dụ

Wave [A1:A13], 3, BackRng, 36

- Thử hiệu ứng chữ bay vào:
Cú pháp:

FlyIn  Vùng chứa địa chỉ các nét vẽ, màu chữ, Vùng nền, màu nền, kiểu bay,  thời gian trể

Ví dụ:

FlyIn [A1:A13], 7, BackRng, 0, 2,  10

Để bay 1 lần 8 hướng khác nhau, hãy thí nghiệm với code này:

For  i = 0 To 7
   FlyIn [A1:A13], 7, BackRng, 0, i, 10
Next i

---------------------------------------
Việc còn lại của các bạn là phối hợp các hiệu ứng lại với nhau sao cho đẹp mắt , chẳng hạn là thế này:

Sub Test()
  Dim i As Long, BackRng As Range, Frame As Range
  Set BackRng = [H8:BV15]
  Set Frame = [G7:BW16]
  Frame.Clear
  Enframe Frame, 4, 8
  DrawText CollectRng([A1:A13]), 3
  Elastic BackRng
  Dream CollectRng([A1:A13]), 0
  Flicker CollectRng([A1:A13]), 3, 7, 6
  Wave [A1:A13], 3, BackRng, 36
  For i = 0 To 7
    FlyIn [A1:A13], 7, BackRng, 0, i, 10
  Next i
End Sub

Chúc vui vẽ với món quà này!
(Định post hình minh họa, nhưng chẳng hiểu sao sáng giờ chẳng tài nào post được... Đành phải cho hình vào file đính kèm dưới đây ---> Hãy tải về, giải nén và xem chi tiết nhé)

 

[khuongvietphong]

Chú Ndu ơi... chú giúp con sửa File bên trên ngày 8 - 3 thành 20 -10 với chú ....con đọc hướng dẫn của chú rồi mà không biết làm