Zurück zur Homepage

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 LongAs 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 StringAs Long
Private Declare Function CloseClipboard Lib "user32" _
    () 
As Long
Private Declare Function OpenClipboard Lib "user32" _
    (
ByVal hwnd As LongAs Long
Private Declare Function EmptyClipboard Lib "user32" _
    () 
As Long
Private Declare Function SetClipboardData Lib "user32" _
    (
ByVal wFormat As LongByVal hMem As LongAs 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 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 StringOptional 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 'Verzerrung zulassen
         oKarte.LockAspectRatio = msoFalse
         
'Auf Zellenbreite
         oKarte.Width = Zielzelle(1, 1).Width
         
'Auf Zellenhöhe
         oKarte.Height = Zielzelle(1, 1).Height
      
Case '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