根据另一列中的文件名自动将图像和声音文件包含在excel列中
我有我的excel文件中的文件名列。
在Excel文件的同一个文件夹中，我使用文件名+'.jpg'的forms存在图像文件。 另外我有相同的文件名+'.mp3'的小mp3文件。
现在我想让每行的图像显示在一个新的列中，并且在另一个列中显示一个播放button来播放mp3文件。
我已经知道了“= HYPERLINK（）”函数 – 用它，我可以构buildpath并链接到文件。 如果我有一个公式，它返回的对象本身，而不是只有一个链接，这将是好得多。
这可能吗？
理想情况下，多媒体文件不在Excel文件中。 但是，如果embedded文件更容易，那也是可以接受的。
也有一些非公式的方法可以，就像一些VBA脚本，它遍历所有的行。
编辑 ：我发现以下工作代码播放.wav文件。 我可以转换所有的MP3文件 – 任何更好的主意？
Private Declare Function sndPlaySound Lib "winmm.dll" _ Alias "sndPlaySoundA" (ByVal lpszSoundName As String, _ ByVal uFlags As Long) As Long Private Const SND_SYNC = &H0 Private Const SND_ASYNC = &H1 Private Const SND_NODEFAULT = &H2 Private Const SND_LOOP = &H8 Private Const SND_NOSTOP = &H10 Sub Test() If sndPlaySound("C:\WINDOWS\Media\tada.wav", SND_ASYNC Or SND_NODEFAULT) = 0 Then MsgBox "Unable to play sound." End If End Sub 我还需要找出如何插入一个button，并从它运行此代码…
OK :-)）））我已经为你工作了，因为这是一个有趣的问题。
在Module使用这个代码。
组态：
专栏A ：名字。
B栏：图片
列C ：embedded对象。 擦除。
D列：播放button。
宣言：
Private Declare Function mciSendString Lib "winmm.dll" Alias _ "mciSendStringA" (ByVal lpstrCommand As String, ByVal _ lpstrReturnString As Any, ByVal uReturnLength As Long, ByVal _ hwndCallback As Long) As Long Dim sMusicFile As String Dim Play
如果您需要停止button：
Public Sub cmdStopMusic_Click() Play = mciSendString("close " & sMusicFile, 0&, 0, 0) End Sub
创build图像和button对象的序列：
你可以随时调用，它已经实现了检查已经插入的线的存在…（升级!!!）
Sub CreateMP3() For i = 1 To 9999 If Range("A" & i).Value = "" Then Exit For FoundT = False For e = 1 To ActiveSheet.Shapes.Count If ActiveSheet.Shapes.Range(e).Top = Range("C" & i).Top And ActiveSheet.Shapes.Range(e).Left = Range("C" & i).Left Then FoundT = True End If Next If FoundT = False Then ActiveSheet.Pictures.Insert("e:\0\A\xx\" & Range("A" & i).Value & ".jpg").Select Selection.ShapeRange.Top = Range("B" & i).Top Selection.ShapeRange.Left = Range("B" & i).Left Selection.ShapeRange.Height = Range("B" & i).Height BottoniMP3 (i) End If Next End Sub
button的创build：
在这个子文件中，您还可以创build与button操作的连接。 只有一个动作，许多button…
Sub BottoniMP3(NumB As Integer) Dim xx As Range Set xx = Range("D" & NumB) ActiveSheet.Buttons.Add(xx.Left, xx.Top, xx.Width, xx.Height).Select Selection.OnAction = "'SoundMP3 """ & NumB & """'" Selection.Characters.Text = Range("A" & NumB).Value End Sub
button事件：
该事件有一个parameter passing的行数…
Sub SoundMP3(xx As Integer) ' Stop the Prev... Play = mciSendString("close " & sMusicFile, 0&, 0, 0) ' Start the New... sMusicFile = "E:\0\A\xx\" & Range("A" & xx).Value & ".mp3" Play = mciSendString("play " & sMusicFile, 0&, 0, 0) If Play <> 0 Then MsgBox "Can't PLAY!" End Sub
清理：
注意传递的参数，如果删除了一些行，可以更好地清理Sheet并重build：
Sub ERASEALL() For i = ActiveSheet.Shapes.Count To 1 Step -1 Select Case ActiveSheet.Shapes(i).Name Case "Button 86": Case "Button 87": Case "Button 88": Case Else: ActiveSheet.Shapes(i).Delete End Select Next End Sub
案例Button xxx是我不想被删除的button。 例如，我用来减less工作表的button。
如果你喜欢，你可以传递一个参数的MP3名称，在这种情况下，我认为你没有prb …如你所愿。
最后 ！！！ ;-)））：
如果你喜欢，你可以添加一个图像和button的Shape 。 形状遵循单元尺寸：
Private Declare Function mciSendString Lib "winmm.dll" Alias _ "mciSendStringA" (ByVal lpstrCommand As String, ByVal _ lpstrReturnString As Any, ByVal uReturnLength As Long, ByVal _ hwndCallback As Long) As Long Dim sMusicFile As String Dim PlayN Sub xxxxMP3Sh() For i = 1 To 9999 If Range("A" & i).Value = "" Then Exit For FoundT = False For e = 1 To ActiveSheet.Shapes.Count If ActiveSheet.Shapes.Range(e).Top = Range("B" & i).Top And ActiveSheet.Shapes.Range(e).Left = Range("B" & i).Left Then FoundT = True End If Next If FoundT = False Then ActiveSheet.Shapes.AddShape(msoShapeRectangle, Range("B" & i).Left, Range("B" & i).Top, Range("B" & i).Width, Range("B" & i).Height).Select With Selection.ShapeRange.Fill .Visible = msoTrue .UserPicture "e:\0\A\xx\" & Range("A" & i).Value & ".jpg" .TextureTile = msoFalse End With Selection.OnAction = "'SoundMP3Sh """ & i & """'" End If Next End Sub Sub SoundMP3Sh(xx As Integer) ' Stop the Prev... PlayN = mciSendString("close " & sMusicFile, 0&, 0, 0) ' Start the New... sMusicFile = "E:\0\A\xx\" & Range("A" & xx).Value & ".mp3" PlayN = mciSendString("play " & sMusicFile, 0&, 0, 0) If PlayN <> 0 Then MsgBox "Can't PLAY!" End Sub Sub StopPl() PlayN = mciSendString("close " & sMusicFile, 0&, 0, 0) End Sub
我也学到了很多！ 做得好
长文件名和path：
在模块中添加：
Private Declare Function GetShortPathName Lib "kernel32" Alias _ "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal _ lpszShortPath As String, ByVal lBuffer As Long) As Long
并在代码中更改子：
Public Function GetShortPath(ByVal sLongPath As String) As String Dim sShortPath As String sShortPath = VBA.String(260, 0) If GetShortPathName(sLongPath, sShortPath, Len(sShortPath)) Then GetShortPath = VBA.Left(sShortPath, _ VBA.InStr(sShortPath, vbNullChar) - 1) End If End Function Sub SoundMP3Sh(xx As Integer) ' Stop the Prev... PlayN = mciSendString("close " & sMusicFile, 0&, 0, 0) ' Start the New... sMusicFile = "E:\0\A\xx\" & Range("A" & xx).Value & ".mp3" sMusicFile = GetShortPath(sMusicFile) PlayN = mciSendString("play " & Chr(34) & sMusicFile & Chr(34), 0&, 0, 0) If PlayN <> 0 Then MsgBox "Can't PLAY!" End Sub
我认为，与公式，你可以只有一个链接…
代码如下：
For i = 1 To 9999 If Range("A" & i).Value = "" Then Exit For ActiveSheet.Pictures.Insert("e:\0\xx\" & Range("A" & i).Value & ".jpg").Select Selection.ShapeRange.Top = Range("B" & i).Top Selection.ShapeRange.Left = Range("B" & i).Left Selection.ShapeRange.Height = Range("B" & i).Height ActiveSheet.OLEObjects.Add(Filename:="e:\0\xx\" & Range("A" & i).Value & ".mp3", Link:=False, DisplayAsIcon:=False).Select Selection.ShapeRange.Top = Range("c" & i).Top Selection.ShapeRange.Left = Range("c" & i).Left Selection.ShapeRange.Height = Range("c" & i).Height Next
导入图片和MP3从A1开始…使用列B的图像和列C的对象。
要聆听你需要单击对象的声音。
如果你想要一个button，代码会复杂一点
笔记：
您需要在创build名称为“A”的列后运行macros。 如果您想在每次更改文件（添加）时运行，则需要为已经创build的行添加一个检查…