Thêm logo công ty vào userform trong excel VBA

[BOng map]

Các tiền bối giúp em với ah.
Em có 1 userform trong excel VBA, bgio em muốn thêm cái logo công ty vào caption của userform. Các tiền bối có cách nào chỉ giúp em với ah. Em muốn logo công ty để giống như biểu tượng của VBA đấy ah.
Mong các tiền bối chỉ giáo ah.
Em cảm ơn ah.

 

[Doãn Quốc Bình]

Không phải sửa ExtractIcon thành LoadIcon đâu.

Giả sử trên c:\ có tập tin logo.ico.

Code trong UserForm

Option Explicit

Private Const WM_SETICON = &H80
   
#If VBA7 Then
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr     
    Private Declare PtrSafe Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As LongPtr, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As LongPtr
    Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
#Else
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long     
    Private Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
#End If

Private Sub UserForm_Initialize()
#If VBA7 Then
    Dim lngIcon As LongPtr
    Dim lnghWnd As LongPtr
#Else
    Dim lngIcon As Long
    Dim lnghWnd As Long
#End If

    If Val(Application.Version) < 9 Then
        lnghWnd = FindWindow("ThunderXFrame", Caption)  'XL97
    Else
        lnghWnd = FindWindow("ThunderDFrame", Caption)  'XL2000
    End If
#If VBA7 Then
    lngIcon = ExtractIcon(Application.HinstancePtr, "c:\logo.ico", 0)
#Else
    lngIcon = ExtractIcon(Application.Hinstance, "c:\logo.ico", 0)
#End If
   
    SendMessage lnghWnd, WM_SETICON, 0, lngIcon
End Sub

Cho mình hỏi khi chuyển file sang máy khác mà không có file ico đó thì nó vẫn hiện hay mất đi? Nếu mất thì có cách nào để hiện mà không cần có file ico đó không?

 

[batman1]

Cho mình hỏi khi chuyển file sang máy khác mà không có file ico đó thì nó vẫn hiện hay mất đi? Nếu mất thì có cách nào để hiện mà không cần có file ico đó không?

Code khi chạy, tức ở Real Time, nó mới lấy ICO từ đĩa cứng nên khi sang máy khác lúc chạy code sẽ không tìm thấy ICO ở máy khác "kia".

Vậy nếu trên máy khác không có tập tin ICO thì phải "mang nó theo". "Mang nó theo" có muôn vàn cách. Vd. tôi chỉ ra 2 cách. Nếu bạn chịu khó suy nghĩ thì bạn sẽ thấy có những cách khác. Vd. đặt ICO trên sheet.

1. Trên máy gốc có thư mục "hic hic", và trong nó có 2 tập tin: tập tin Xuat.xlsm và logo.ico. Khi sang máy khác ta không mang Xuat.xlsm mà mang thư mục "hic hic". Nếu thế thì chỉ sửa 1 đoạn thành

#If VBA7 Then
    lngIcon = ExtractIcon(Application.HinstancePtr, ThisWorkbook.Path & "\logo.ico", 0)
#Else
    lngIcon = ExtractIcon(Application.Hinstance, ThisWorkbook.Path & "\logo.ico", 0)
#End If

2. Điểm 1 hơi phiền phức. Ta có thể mang ICO theo bằng cách "cất" nó trên UserForm.
Thao tác: chọn chỗ "trống" trên Form -> đặt 1 Image1 -> thu nhỏ Image1 cho gọn -> trong cửa sổ Properties chọn thuộc tính Picture -> nhấn vào nút ba chấm "..." bên cạnh trường Picture -> duyệt tới và chọn tập tin logo.ico để nhập ICO vào Image1 -> thiết lập thuộc tính Visible (của Image1) thành False để ẩn Image1. Lúc này thì toàn bộ code trong UserForm là

Option Explicit

Private Const WM_SETICON = &H80
   
#If VBA7 Then
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
#Else
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
#End If

Private Sub UserForm_Initialize()
#If VBA7 Then
    Dim lnghWnd As LongPtr
#Else
    Dim lnghWnd As Long
#End If

    If Val(Application.Version) < 9 Then
        lnghWnd = FindWindow("ThunderXFrame", Caption)  'XL97
    Else
        lnghWnd = FindWindow("ThunderDFrame", Caption)  'XL2000
    End If

    SendMessage lnghWnd, WM_SETICON, 0, Image1.Picture.Handle
End Sub