Spielkarten

Die Betriebssysteme von Microsoft enthalten standardmäßig einen Satz Spielkarten. Enthalten ist er in der Datei cards.dll oder in cards32.dll. Die Bildchen müssen nur rausgekitzelt werden.

Beispieldatei (Karten.zip 88 KB)

Option Explicit
Private Declare Function FreeLibrary& Lib "kernel32" _
    (ByVal hLibModule As Long)
Private Declare Function DeleteObject Lib "gdi32" _
    (ByVal hObject As Long) As Long
Private Declare Sub Sleep Lib "kernel32" _
    (ByVal dwMilliseconds As Long)
Private Declare Function FindWindow Lib "user32" _
    Alias "FindWindowA" (ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long
Private Declare Function CloseClipboard Lib "user32" _
    () As Long
Private Declare Function OpenClipboard Lib "user32" _
    (ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" _
    () As Long
Private Declare Function SetClipboardData Lib "user32" _
    (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function LoadBitmapBynum& Lib "user32" _
    Alias "LoadBitmapA" (ByVal hInstance As Long, _
    ByVal lpBitmapName As Long)
Private Declare Function LoadLibrary& Lib "kernel32" _
    Alias "LoadLibraryA" (ByVal lpLibFileName As String)

Sub KartenHolen()
Dim lZähler As Long, lZähler1 As Long
Dim hModul As Long, hBitmap As Long
Dim hMyWnd As Long, lIndex As Long
Dim lZeile As Long, lSpalte As Long
Dim dummy As Long, oKarte As Shape
With ActiveSheet
    For lZähler = .Shapes.Count To 1 Step -1
        If InStr(1, .Shapes(lZähler).Name, "Bild") Then
            .Shapes(lZähler).Delete
        End If
    Next
    hMyWnd = FindWindow(vbNullString, Application.Caption)
    hModul = LoadLibrary("Cards.dll")
    If hModul = 0 Then hModul = LoadLibrary("Cards32.dll")
    For lZähler1 = 1 To 4
        For lZähler = 1 To 13
            DeleteObject hBitmap
            CloseClipboard
            OpenClipboard hMyWnd
            EmptyClipboard
            lZeile = lZähler1 * 3
            lSpalte = lZähler
            If lSpalte = 13 Then
                lIndex = (lZähler1 - 1) * 13 + 1
            Else
                lIndex = (lZähler1 - 1) * 13 + lSpalte + 1
            End If
            hBitmap = LoadBitmapBynum(hModul, lIndex)
            SetClipboardData 2, hBitmap
            .Paste
            Set oKarte = .Shapes(.Shapes.Count)
            oKarte.Left = .Cells(lZeile, lSpalte).Left
            oKarte.Top = .Cells(lZeile, lSpalte).Top
            oKarte.Name = "Bild " & lIndex
            'Verzerrung zulassen
'            oKarte.LockAspectRatio = msoFalse
            'Auf Zellenbreite
            oKarte.Width = .Cells(lZeile, lSpalte).Width
            'Auf Zellenhöhe
'            oKarte.Height = .Cells(lZeile, lSpalte).Height
        Next lZähler
    Next lZähler1
End With
DeleteObject hBitmap
CloseClipboard
FreeLibrary hModul
End Sub



Sub test()
'Karo König, Zellenhöhe, Verzerrung nicht zulassen
KartenInZelle Worksheets("Karten").Range("A21"), "ck"
'Kreuz As, An Zellengröße anpassen, Verzerrung zulassen
KartenInZelle Worksheets("Karten").Range("B21"), "KA", 1
'Rückseite 13, Zellenbreite, Verzerrung nicht zulassen
KartenInZelle Worksheets("Karten").Range("C21"), "R13", 1
End Sub


Public Sub KartenInZelle(Zielzelle As Range, _
   Karte As String, Optional Anpassmodus As Long)
Dim lFarbe As Long, lWert As Long
Dim hModul As Long, hBitmap As Long
Dim hMyWnd As Long, lIndex As Long
Dim lZeile As Long, lSpalte As Long
Dim sName  As String, oKarte As Shape
Dim sDummy As String
Select Case UCase(Left(Karte, 1))
   Case "C": lFarbe = 2 'Karo
   Case "K": lFarbe = 1 'Kreuz
   Case "H": lFarbe = 3 'Herz
   Case "P": lFarbe = 4 'Pik
   Case Else: lFarbe = 5 'Rückseite
End Select
sDummy = UCase(Mid(Karte, 2, 2))
Select Case sDummy
   Case "Z": lWert = 10 'Zehn
   Case "B": lWert = 11 'Bube
   Case "D": lWert = 12 'Dame
   Case "K": lWert = 13 'König
   Case "A": lWert = 1 'As
   Case Else
      If IsNumeric(sDummy) Then
         lWert = sDummy
         If lWert > 13 Then lWert = 13
      Else
         lWert = 1
      End If
End Select
hMyWnd = FindWindow(vbNullString, Application.Caption)
hModul = LoadLibrary("Cards.dll")
If hModul = 0 Then hModul = LoadLibrary("Cards32.dll")
OpenClipboard hMyWnd
EmptyClipboard
hBitmap = LoadBitmapBynum(hModul, (lFarbe - 1) * 13 + lWert)
SetClipboardData 2, hBitmap
sName = Zielzelle.Worksheet.Name
With Worksheets(sName)
   sName = Zielzelle(1, 1).Address
   For Each oKarte In .Shapes
      If oKarte.Name = sName Then
         oKarte.Delete: Exit For
      End If
   Next
   .Select
   .Paste
   Set oKarte = .Shapes(.Shapes.Count)
   oKarte.Left = Zielzelle(1, 1).Left
   oKarte.Top = Zielzelle(1, 1).Top
   oKarte.Name = sName
   Select Case Anpassmodus
      Case 1 'Verzerrung zulassen
         oKarte.LockAspectRatio = msoFalse
         'Auf Zellenbreite
         oKarte.Width = Zielzelle(1, 1).Width
         'Auf Zellenhöhe
         oKarte.Height = Zielzelle(1, 1).Height
      Case 2 'Nur Zeilenbreite
         oKarte.Width = Zielzelle(1, 1).Width
      Case Else 'Nur Zeilenhöhe
         'Auf Zellenhöhe
         oKarte.Height = Zielzelle(1, 1).Height
   End Select
End With
DeleteObject hBitmap
CloseClipboard
FreeLibrary hModul
End Sub