SysMonthCal32

[THFR]

Ich suche eine "Einklick"-Lösung ohne GetMessage um ans Datum zu kommen.
Hat einer von euch eine Lösung/ Vorschlag.

declare calender&,calender2&
DEF getsystime(2) SendMessage(&(1),4097,0,&(2))

PROC GETDATE
    declare d$,m$,y$,dtp#
    dim dtp#,20
    parameters chdl&
    getsystime(chdl&,dtp#)
    d$=format$("00",word(dtp#,6))
    m$=format$("00",word(dtp#,2))
    y$=format$("0000",word(dtp#,0))
    dispose dtp#
    return d$+"."+m$+"."+y$
ENDPROC
usermessages 16
cls

var ELEMENT2&=Control("DIALOG","",$54000000,255,26,184,169,%hwnd,0,%hinstance,$0)
calender2&=Control("SysMonthCal32","",$54000000,2,2,180,165,ELEMENT2&,$0,%hinstance)

while 1
    waitinput
    case %umessage=16:break
    
    If  %MWnd=ELEMENT2&
      If %MouseKey=1
        getdate calender2&
        locate 0,0
        print $(0)
      endIf
   endIf
wend
DestroyWindow(ELEMENT2&)
End

Thomas

[Andreas Miethe]

Zitat von THFR

Ich suche eine "Einklick"-Lösung ohne GetMessage um ans Datum zu kommen.
Hat einer von euch eine Lösung/ Vorschlag.

So sollte es gehen.

declare calender&,calender2&
DEF getsystime(2) SendMessage(&(1),4097,0,&(2))

Proc GetDate
    Declare Datum#
    dim Datum#,20
    SendMessage(Calender2&,4097,0,Datum#)
    Var Zurück$ = format$("00",word(Datum#,6))+"."+format$("00",word(Datum#,2))+"."+format$("0000",word(Datum#,0))
    Dispose Datum#
    Return Zurück$
ENDPROC

usermessages 16
cls

var ELEMENT2&=Control("DIALOG","",$54000000,255,26,184,169,%hwnd,0,%hinstance,$0)
calender2&=Control("SysMonthCal32","",$54000000,2,2,180,165,ELEMENT2&,$0,%hinstance)

while 1
    waitinput
    case %umessage=16:break

    If  %MWnd=ELEMENT2&
      If %MouseKey=1
        GetDate
        locate 0,0
        print $(0)
      endIf
   endIf
wend
DestroyWindow(ELEMENT2&)
End

[Frabbing]

Geht unter Windows 7. Ich würde Prozeduren aber immer als Funktion aufrufen:

declare calender&,calender2&
DEF getsystime(2) SendMessage(&(1),4097,0,&(2))

Proc GetDate
    Declare Datum#
    dim Datum#,20
    SendMessage(Calender2&,4097,0,Datum#)
    Var Zurück$ = format$("00",word(Datum#,6))+"."+format$("00",word(Datum#,2))+"."+format$("0000",word(Datum#,0))
    Dispose Datum#
    Return Zurück$
ENDPROC

usermessages 16
cls

var ELEMENT2&=Control("DIALOG","",$54000000,255,26,184,169,%hwnd,0,%hinstance,$0)
calender2&=Control("SysMonthCal32","",$54000000,2,2,180,165,ELEMENT2&,$0,%hinstance)

while 1
    waitinput
    case %umessage=16:break

    If  %MWnd=ELEMENT2&
      If %MouseKey=1
        locate 0,0
        Print GetDate()
      endIf
   endIf
wend
DestroyWindow(ELEMENT2&)
End

[p. specht]

Das Kalenderfenster des Controls berandet in Win7 zu eng und schneidet in die ersten und letzten, obersten und untersten Zeichen fast zur Hälfte rein. EDIT: Nach einigen Experimenten Abhilfe gefunden:

var ELEMENT2&=Control("DIALOG","",$54000000,255,26,200,180,%hwnd,0,%hinstance,$0)
calender2&=Control("SysMonthCal32","",$54000000,0,0,200,200,ELEMENT2&,$0,%hinstance)

[Frabbing]

Kann ich nicht bestätigen, hast du einen Screenshot?

[p. specht]

Gelöst, siehe oben. Scheint von der Systemschrift abzuhängen...
(Blöd nur, daß das nun keine universelle Lösung ist).

[THFR]

Danke, der Vorschlag hat den Vorteil, dass

DEF getsystime(2) SendMessage(&(1),4097,0,&(2))

nicht mehr erforderlich ist.
Leider reagiert es auf meinem System (XP SP2) nicht anders, d.h. 1. Klick markiert das gewählte Datum und der 2. Klick zeigt es an.
Leiter ging es ohne "Träger" bei mir gar nicht, und Darstellungsgröße muß ggf. den Systemeinstellungen angepasst werden.

Thomas

[Andreas Miethe]

Zitat von THFR

Leider reagiert es auf meinem System (XP SP2) nicht anders, d.h. 1. Klick markiert das gewählte Datum und der 2. Klick zeigt es an.
Leiter ging es ohne "Träger" bei mir gar nicht, und Darstellungsgröße muß ggf. den Systemeinstellungen angepasst werden.
Thomas

Dann versuchs mal mit Subclassing.

Declare Kalender&, Ende%

SubClassProc
    If SubClassMessage(Kalender& , 15)'Tag angeklickt
        SetMenuItem 15000
        Set("WinProc",1)
    EndIf
EndProc

Proc Kal_GetDate
    Declare Datum#
    Dim Datum#,20
    SendMessage(Kalender&,4097,0,Datum#)
    Var Zurück$ = format$("00",word(Datum#,6))+"."+format$("00",word(Datum#,2))+"."+format$("0000",word(Datum#,0))
    Dispose Datum#
    Return Zurück$
EndProc

Window 800,600
Kalender&=Control("SysMonthCal32","Kalender",$50000000,600,0,180,200,%HWnd,5000,%hinstance,0)
SubClass Kalender&,1

WhileNot Ende%
    Waitinput
    If %Key = 2
        Ende% = 1
    ElseIf @MenuItem(15000)
        Locate 0,0
        Print  Kal_GetDate()
    EndIf
EndWhile
SubClass Kalender&,0
end

[THFR]

@Andreas, Danke, damit geht es wie gewünscht. SubClassProc setze ich so selten ein und musste im alten Programm, einmal eingesetzt für die ScrollArea, Dank meiner Unordnung länger suchen bis ich es gefunden hatte.
Daher an dieser Stelle meine Bitte für deinen Editor: ein "naktes" SubClassProc mit auflisten.
Wie ist der Stand beim MultiTiff?
Benötige ich zwar im Moment nicht mehr, aber wer weis wann.

Gruß Thomas

[Andreas Miethe]

Zitat von THFR

@Andreas, Danke, damit geht es wie gewünscht. SubClassProc setze ich so selten ein und musste im alten Programm, einmal eingesetzt für die ScrollArea, Dank meiner Unordnung länger suchen bis ich es gefunden hatte.
Daher an dieser Stelle meine Bitte für deinen Editor: ein "naktes" SubClassProc mit auflisten.
Wie ist der Stand beim MultiTiff?
Benötige ich zwar im Moment nicht mehr, aber wer weis wann.

Gruß Thomas

Was wollte ich da gleich machen beim Multitiff ? Bin da nicht mehr auf dem laufenden.

Was Subclassproc angeht.
Füge folgenden Code per Drag&Drop in den Editor ein.
Dann Rechtsklick in den Code und '' Datei als Vorlage speichern '' auswählen und speichern.
So hast du auf der linken Seite des Editors unter Vorlagen die ''xprf-Vorlagen'' zur Verfügung. Einfach einen Doppelklick darauf und Du hast Dein Grundgerüst als neue Datei im Editor.

'######################
'Header-Dateien
'######################
$H Windows.ph
$H Messages.ph
'######################

Windowstyle 543

$H Windows.ph
Declare Ende&
CLS ~GetSysColor(~Color_BTNFACE)
SubClass %HWnd,1
WindowTitle "Neues Projekt"
Whilenot Ende&
  Waitinput
Endwhile
End

SubClassProc
  If SubClassMessage(&sWnd,~WM_CLOSE)
    Ende& = 1
    Set("WinProc", 1)
  EndIf
EndProc

[THFR]

@Andreas, bei deinen GDIplus-Beispielen neben dem Anzeigen von Multi-Tiff auch ein Beispiel zum Erstellen von Multi-Tiff erarbeiten.
Zur Proc-Auflistung: SubClassProc wird nur gelistet, wenn noch Zeichen hinter SubClassProc kommen. Geht's auch ohne?

Gruß Thomas

[GT43A]

Hallo,

es geht auch mit den Mauskoordinaten

Declare Kalender1&,Kalender2&, Ende%
Proc Kal_GetDate
    Parameters Aktive_Kalender&
    Declare Datum#
    Dim Datum#,20
    SendMessage(Aktive_Kalender&,4097,0,Datum#)
    Var Zurück$ = format$("00",word(Datum#,6))+"."+format$("00",word(Datum#,2))+"."+format$("0000",word(Datum#,0))
    Dispose Datum#
    Return Zurück$
EndProc
Window 800,600
Kalender1& = Control("SysMonthCal32", "Kalender", $54000004, 20, 45 ,243, 208, %Hwnd, 0, %hInstance, 0)
Kalender2& = Control("SysMonthCal32", "Kalender", $54000000, 20, 300 ,243, 208, %Hwnd, 0, %hInstance, 0)
WhileNot Ende%
    Waitinput
    If %Key = 2
        Ende% = 1
    EndIf
 
     If ((%MouseX > 20) & (%MouseX < 243))
      If ((%MouseY > 45) & (%MouseY < 208))
        Locate 0,0
        Print  Kal_GetDate(Kalender1&), + " mit der KW"
      Endif
    EndIf
 
     If ((%MouseX > 20) & (%MouseX < 243))
      If ((%MouseY > 300) & (%MouseY < 508))
        Locate 0,0
        Print  Kal_GetDate(Kalender2&) , + " ohne der KW"
      Endif
    EndIf
EndWhile
end

[Andreas Miethe]

Zitat von THFR

@Andreas, bei deinen GDIplus-Beispielen neben dem Anzeigen von Multi-Tiff auch ein Beispiel zum Erstellen von Multi-Tiff erarbeiten.
Zur Proc-Auflistung: SubClassProc wird nur gelistet, wenn noch Zeichen hinter SubClassProc kommen. Geht's auch ohne?

Ach ja, speichern von Multitif.
Werde ich dran bleiben.

Proc-Auflistung ist geändert und hochgeladen.
Download : http://www.ampsoft.eu/xprofed32a1.zip

[THFR]

@Andreas, Danke!
@Gerd, unter XP keine Einklick-Übernahme.

Gruß Thomas

[GT43A]

Hallo Andreas,

mit den Sub ist ne gute Lösung, der Vorschlag von Rolland geht auch nicht unter XP

'SysMonthCal
 '-----------
 
   $H Windows.ph
   $H Messages.ph
   $H commctrl.ph
 
 Declare OldTest&,ende%
 
 Struct POINT = \
      x&, \
      y&
 
 Struct SYSTEMTIME = \
      wYear%, \
      wMonth%, \
      wDayOfWeek%, \
      wDay%, \
      wHour%, \
      wMinute%, \
      wSecond%, \
      wMilliseconds%
 
 Struct MCHITTESTINFO = \
      cbSize&, \
      pt!POINT, \
      uHit&, \
      st!SYSTEMTIME
 
  Proc Get_MonthCalHit
       Declare DATA#, HIT%
       Dim DATA#,MCHITTESTINFO
       DATA#.cbSize& = SizeOf(DATA#)
       DATA#.pt!x& = %MouseX - 500
       DATA#.pt!y& = %MouseY - 150
       Var QT% = SendMessage(KAL1&,$100E,0,DATA#) ' $100E = $1000 + 14 = HITTEST
       Var TEXT$ = str$(DATA#.st!wDay%)+"."+str$(DATA#.st!wMonth%)+"."+str$(DATA#.st!wYear%) 
       Messagebox(TEXT$,"HITFLAG "+Str$(QT%),$40000)
       Dispose DATA#
       RETURN QT%
  EndProc
 
  WINDOW 0,0 - 800,600
  Var KAL1& = Control("SysMonthCal32", "Kalender",$54000000, 500, 150, 180, 300, %HWND, 0, %hInstance, 0)
 
  WhileNot Ende%
  Waitinput
     If %Key = 2
        Ende% = 1
     Else
        Get_MonthCalHit
     EndIf
  EndWhile

würde gerne deinen Vorschlag aufnehmen und deinen Code auch als Vorlage Speichern,
eine Frage hab ich dazu noch, ist es wirklich nötig die $H Windows.ph 2-mal zu laden?
Oder kann ich einmal löschen?
MfG