Excel Forum - Porady, Pomoc, Excel Help, Excel FAQ - Jak to się robi

apollo · ExcelSpec **Pomógł:** 1306 razy Posty: 4517

Nie wiem, czy ktoś już zna tę zagadkę, ale podaję.

Sprawa jest prosta: prawy klik na każdej z komórek A1:B2 -> Format Cells -> zakładka Fill -> wybrać odpowiedni kolor.

Pytanie: jak wypełnić te 4 komórki kolorami ale bez wykonania powyższych czynności, bez użycia żadnej pozycji menu Ribbon, bez użycia kodu VBA, bez użycia żadnej zewnętrznej aplikacji - dozwolony jest tylko Notatnik. Kolory mogą być dowolne.

kolory.jpg

Plik ściągnięto 23 raz(y) 12.23 KB

Rafał B. · Wysłany: 05-10-2020, 09:11

Rozumiem, że wypakowanie pliku nie wchodzi w grę jako zewnętrzna aplikacja? Wówczas zagadka dotyczyłaby oczywiście tylko plików niebinarnych .xlsx, .xslm i polegała zapewne na jakichś modyfikacjach jednego z plików .xlm.

Drugie rozwiązanie spełniające opisane kryteria, to napisanie krótkiego kodu VBS.

apollo · ExcelSpec **Pomógł:** 1306 razy Posty: 4517

Rafał B. · Wysłany: 05-10-2020, 12:15

apollo · ExcelSpec **Pomógł:** 1306 razy Posty: 4517

Rafał B. · Wysłany: 05-10-2020, 13:58

A dziękuję :-D

Ale w tym momencie się poddaję, być może da się spreparować COŚ (może wspomniany html z określeniem excelowskiej schemy, o ile taka istnieje), co po skopiowaniu z notatnika da się wkleić przez prawoklik: wklej specjalnie -> jako, ale co tam w notatniku wpisać nie mam pojęcia, a nie chcę guglać (o ile to w ogóle właściwy trop i menu kontekstowe dopuszczalne w zagadce). Życzę powodzenia innym, na pewno ktoś rozgryzie!

apollo · ExcelSpec **Pomógł:** 1306 razy Posty: 4517

Rafał B. · Wysłany: 07-10-2020, 12:04

Skoro nikt się nie kwapi z rozwiązaniem, to spróbowałem pociągnąć temat dalej.
1. Pokolorowałem komórki
2. Zapisałem plik jako stronę sieci WEB (zaznaczyłem publikację tylko A1:B2)
3. Otworzyłem stronę w notatniku, skopiowałem tekst
4. PPM na A1 w nowym arkuszu -> wklej specjalnie -> i Tekst Unicode* i sukces, pokolorowało komórki.

Następnie z ciekawości okrajałem ten plik aż nawet wywaliłem schemę z nagłówka:

Kod:

i... działa! Office 2016. Więc nawet notatnik nie jest potrzebny, można wpisać sobie w pasku formuły prosty kod tabeli HTML i go przekopiować bez problemu. Fajna ciekawostka, bo może nawet znajdzie kiedyś jakieś zastosowanie 8-)

Pozdrawiam!

* nie wiem czemu raz się pojawia na liście wklejania HTML, a raz nie, ale i tak działa tylko jak używam Unicode

apollo · ExcelSpec **Pomógł:** 1306 razy Posty: 4517

Marecki · Wysłany: 07-10-2020, 21:00

Super. Fajna ciekawostka. :beer

Rafał B.,

Rafał B. · Wysłany: 08-10-2020, 06:03

@apollo Bardzo ładny zrzut ekranu w Excelu! :danke

Jakbyś mógł jeszcze w paru słowach powiedzieć jak go przygotowałeś, jeśli to nie tajemnica (chdzi mi o proces zamiany każdego piksela na sformatowaną komórkę tabeli), czy sam to pisałeś, czy jakieś gotowe automaty są.

apollo · ExcelSpec **Pomógł:** 1306 razy Posty: 4517

@Rafał B.,

Jak widzisz, trzeba w kodzie VBA tworzyć string postaci:
<table>
<tr><td bgcolor='EDF6FD'></td><td bgcolor='FF0000'></td></tr>
<tr><td bgcolor='00FF00'></td><td bgcolor='0000FF'></td></tr>
</table>

Czyli trzeba znać kolor każdego piksla. Kolor piksla odczytam funkcją API GetPixel. Trzeba w 2 pętlach odczytać kolor i łączyć stringi. Zazwyczaj mały obraz ma dużo piksli, np. 500 x 200 ma 100 000 piksli, więc łączenie tekstów trzeba realizować w inny sposób. Inaczej proces trwa wiekami.

GetPixel zwraca Long, więc żeby otrzymać string np. "EDF6FD" używam Hex$. Ale Hex$ dla niektórych wartości zwraca < 6 znaków (np. dla niebieskiego zwraca "FF"), więc jeśli trzeba to dodać na początku kilka zer "0...0" (w przypadku niebieskiego to dodać "0000")

Na razie nie mam czasu, postaram się później podać kod dla zainteresowanych.

apollo · ExcelSpec **Pomógł:** 1306 razy Posty: 4517

Podaję obiecany kod.

Kod:

Option Explicit

Private Const IMAGE_BITMAP As Long = 0
Private Const LR_CREATEDIBSECTION As Long = &H2000
Private Const LR_LOADFROMFILE As Long = &H10

#If VBA7 Then
Private Declare PtrSafe Function GetPixel Lib "gdi32" (ByVal hdc As LongPtr, ByVal x As Long, ByVal y As Long) As Long
Private Declare PtrSafe Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As LongPtr, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hdc As LongPtr) As Long
Private Declare PtrSafe Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As LongPtr, ByVal nCount As Long, lpObject As Any) As Long
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As LongPtr
End Type
#Else
Private Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Private Declare Function GetPixel Lib "gdi32.dll" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function LoadImage Lib "user32.dll" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function GetObject Lib "gdi32.dll" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, ByRef lpObject As Any) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
#End If

Sub concat_text(text As String, curr_pos, ByVal fragment As String, ByVal delim As String)
If Len(text) < curr_pos + Len(fragment) + Len(delim) Then text = text & String(10 ^ 6, Chr(0))
Mid(text, curr_pos, Len(fragment)) = fragment
curr_pos = curr_pos + Len(fragment)
Mid(text, curr_pos, Len(delim)) = delim
curr_pos = curr_pos + Len(delim)
End Sub

Sub DoColorTable(ByVal picFullName As String)
' picFullName: ścieżka do pliku BMP
#If VBA7 Then
Dim DC As LongPtr, hbmp As LongPtr, oldBitmap As LongPtr
#Else
Dim DC As Long, hbmp As Long, oldBitmap As Long
#End If
Dim h As Long, w As Long, curr_pos As Long, width As Long, height As Long, kolor As Long, r As Byte, g As Byte, b As Byte
Dim fso As Object, bmp As BITMAP, text As String, colorStr As String, tmp As String
' load bitmap
hbmp = LoadImage(0, picFullName, IMAGE_BITMAP, 0, 0, _
LR_CREATEDIBSECTION Or LR_LOADFROMFILE)
' tworzyć memory device context zgodnego z current screen
DC = CreateCompatibleDC(0)
' wybrać bitmap do device context
oldBitmap = SelectObject(DC, hbmp)
' odczytać informacje obiektu bitmap
GetObject hbmp, Len(bmp), bmp
' długość obrazu
width = bmp.bmWidth
' wysokość obrazu
height = bmp.bmHeight
colorStr = String(6, "0")
curr_pos = 1
concat_text text, curr_pos, "<body><table>" & vbCrLf, ""
' odczytać kolor piksla
For h = 1 To bmp.bmHeight
concat_text text, curr_pos, "<tr>", ""
For w = 1 To bmp.bmWidth
kolor = GetPixel(DC, w - 1, h - 1)
b = kolor \ 256 ^ 2
g = (kolor - b * 256 ^ 2) \ 256
r = kolor And &HFF
Mid(colorStr, 1, 2) = Application.Dec2Hex(r, 2)
Mid(colorStr, 3, 2) = Application.Dec2Hex(g, 2)
Mid(colorStr, 5, 2) = Application.Dec2Hex(b, 2)
tmp = "<td bgcolor='" & colorStr & "'></td>"
concat_text text, curr_pos, tmp, ""
Next w
concat_text text, curr_pos, "</tr>" & vbCrLf, ""
Next h
concat_text text, curr_pos, "</table></body>" & vbCrLf, ""

text = Mid(text, 1, curr_pos - 1)

SelectObject DC, oldBitmap
DeleteDC DC
DeleteObject hbmp

Set fso = CreateObject("Scripting.FileSystemObject")
fso.CreateTextFile(picFullName & ".txt").Write (text)
Set fso = Nothing
End Sub

Sub test()
DoColorTable ThisWorkbook.Path & "\dziewczyna.bmp"
MsgBox "Zrobione"
End Sub